msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

refactor the compilation of CFG and EBNF grammars. Now they are parsed by using GF.Grammar.Parser just like the ordinary GF grammars. Furthermore now GF.Speech.CFG is moved to GF.Grammar.CFG. The new module is used by both the speech conversion utils and by the compiler for CFG grammars. The parser for CFG now consumes a lot less memory and can be used with grammars with more than 4 000 000 productions.

Browse Source
This commit is contained in:
kr.angelov
2014-03-21 21:25:05 +00:00
parent 8695d8724d
commit 5f3b35a5f9
19 changed files with 236 additions and 413 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
src/compiler/GF/Command/Importing.hs
View File

@@ -5,23 +5,25 @@ import PGF.Data
import GF.Compile
import GF.Compile.Multi (readMulti)
import GF.Compile.GetGrammar (getCFRules, getEBNFRules)
import GF.Grammar (identS, SourceGrammar) -- for cc command
import GF.Grammar.CF
import GF.Grammar.CFG
import GF.Grammar.EBNF
import GF.Compile.CFGtoPGF
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Data.ErrM
--import Data.List (nubBy)
import System.FilePath
import qualified Data.Set as Set
-- import a grammar in an environment where it extends an existing grammar
importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
importGrammar pgf0 _ [] = return pgf0
importGrammar pgf0 opts files =
case takeExtensions (last files) of
".cf" -> importCF opts files getCF
".ebnf" -> importCF opts files getEBNF
".cf" -> importCF opts files getCFRules id
".ebnf" -> importCF opts files getEBNFRules ebnf2cf
".gfm" -> do
ascss <- mapM readMulti files
let cs = concatMap snd ascss
@@ -52,13 +54,17 @@ importSource src0 opts files = do
return src0
-- for different cf formats
importCF opts files get = do
s <- fmap unlines $ mapM readFile files
gf <- case get (last files) s of
Ok gf -> return gf
Bad s -> error s ----
Ok gr <- appIOE $ compileSourceGrammar opts gf
epgf <- appIOE $ link opts (identS (justModuleName (last files) ++ "Abs"), (), gr)
case epgf of
Ok pgf -> return pgf
Bad s -> error s ----
importCF opts files get convert = do
res <- appIOE impCF
case res of
Ok pgf -> return pgf
Bad s -> error s
where
impCF = do
rules <- fmap (convert . concat) $ mapM (get opts) files
startCat <- case rules of
(CFRule cat _ _ : _) -> return cat
_ -> fail "empty CFG"
let gf = cf2gf (last files) (uniqueFuns (mkCFG startCat Set.empty rules))
gr <- compileSourceGrammar opts gf
link opts (identS (justModuleName (last files) ++ "Abs"), (), gr)

58
src/compiler/GF/Compile/CFGtoPGF.hs Normal file
View File

@@ -0,0 +1,58 @@
module GF.Compile.CFGtoPGF (cf2gf) where
import GF.Grammar.Grammar hiding (Cat)
import GF.Grammar.Macros
import GF.Grammar.CFG
import GF.Infra.Ident(Ident,identS)
import GF.Infra.Option
import GF.Infra.UseIO
import GF.Data.Operations
import PGF(showCId)
import qualified Data.Set as Set
import qualified Data.Map as Map
--------------------------
-- the compiler ----------
--------------------------
cf2gf :: FilePath -> CFG -> SourceGrammar
cf2gf fpath cf = mGrammar [
(aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath Nothing abs),
(cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath Nothing cnc)
]
where
name = justModuleName fpath
(abs,cnc,cat) = cf2grammar cf
aname = identS $ name ++ "Abs"
cname = identS name
cf2grammar :: CFG -> (BinTree Ident Info, BinTree Ident Info, String)
cf2grammar cfg = (buildTree abs, buildTree conc, cfgStartCat cfg) where
abs = cats ++ funs
conc = lincats ++ lins
cats = [(identS cat, AbsCat (Just (L NoLoc []))) | cat <- Map.keys (cfgRules cfg)]
lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule (concatMap Set.toList (Map.elems (cfgRules cfg))))
cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
cf2rule (CFRule cat items (CFObj fun _)) = (def,ldef) where
f = identS (showCId fun)
def = (f, AbsFun (Just (L NoLoc (mkProd args' (Cn (identS cat)) []))) Nothing Nothing (Just True))
args0 = zip (map (identS . ("x" ++) . show) [0..]) items
args = [((Explicit,v), Cn (identS c)) | (v, NonTerminal c) <- args0]
args' = [(Explicit,identS "_", Cn (identS c)) | (_, NonTerminal c) <- args0]
ldef = (f, CncFun
Nothing
(Just (L NoLoc (mkAbs (map fst args)
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
Nothing
Nothing)
mkIt (v, NonTerminal _) = P (Vr v) theLinLabel
mkIt (_, Terminal a) = K a
foldconcat [] = K ""
foldconcat tt = foldr1 C tt

36
src/compiler/GF/Compile/GetGrammar.hs
View File

@@ -12,27 +12,25 @@
-- this module builds the internal GF grammar that is sent to the type checker
-----------------------------------------------------------------------------
module GF.Compile.GetGrammar (getSourceModule) where
module GF.Compile.GetGrammar (getSourceModule, getCFRules, getEBNFRules) where
import Prelude hiding (catch)
import GF.Data.Operations
--import GF.System.Catch
import GF.Infra.UseIO
import GF.Infra.Option(Options,optPreprocessors,addOptions,renameEncoding,optEncoding,flag,defaultEncoding)
import GF.Grammar.Lexer
import GF.Grammar.Parser
import GF.Grammar.Grammar
--import GF.Compile.Coding
import GF.Grammar.CFG
import GF.Grammar.EBNF
import GF.Compile.ReadFiles(parseSource,lift)
--import GF.Text.Coding(decodeUnicodeIO)
import qualified Data.ByteString.Char8 as BS
import Data.Char(isAscii)
import Control.Monad (foldM,when,unless)
import System.Cmd (system)
--import System.IO(mkTextEncoding) --,utf8
import System.Directory(removeFile,getCurrentDirectory)
import System.FilePath(makeRelative)
@@ -64,17 +62,25 @@ getSourceModule opts file0 =
--lift $ transcodeModule' (i,mi) -- old lexer
return (i,mi) -- new lexer
{-
transcodeModule sm00 =
do enc <- mkTextEncoding (getEncoding (mflags (snd sm00)))
let sm = decodeStringsInModule enc sm00
return sm
getCFRules :: Options -> FilePath -> IOE [CFRule]
getCFRules opts fpath = do
raw <- liftIO (BS.readFile fpath)
(optCoding,parsed) <- parseSource opts pCFRules raw
case parsed of
Left (Pn l c,msg) -> do cwd <- lift $ getCurrentDirectory
let location = makeRelative cwd fpath++":"++show l++":"++show c
raise (location++":\n "++msg)
Right rules -> return rules
transcodeModule' sm00 =
do let enc = utf8
let sm = decodeStringsInModule enc sm00
return sm
-}
getEBNFRules :: Options -> FilePath -> IOE [ERule]
getEBNFRules opts fpath = do
raw <- liftIO (BS.readFile fpath)
(optCoding,parsed) <- parseSource opts pEBNFRules raw
case parsed of
Left (Pn l c,msg) -> do cwd <- lift $ getCurrentDirectory
let location = makeRelative cwd fpath++":"++show l++":"++show c
raise (location++":\n "++msg)
Right rules -> return rules
runPreprocessor :: Temporary -> String -> IO Temporary
runPreprocessor tmp0 p =

143
src/compiler/GF/Grammar/CF.hs
View File

@@ -1,143 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/15 17:56:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- parsing CF grammars and converting them to GF
-----------------------------------------------------------------------------
module GF.Grammar.CF (getCF,CFItem,CFCat,CFFun,cf2gf,CFRule) where
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Infra.Ident(Ident,identS)
import GF.Infra.Option
import GF.Infra.UseIO
import GF.Data.Operations
import GF.Data.Utilities (nub')
import qualified Data.Set as S
import Data.Char
import Data.List
--import System.FilePath
getCF :: ErrorMonad m => FilePath -> String -> m SourceGrammar
getCF fpath = fmap (cf2gf fpath . uniqueFuns) . pCF
---------------------
-- the parser -------
---------------------
pCF :: ErrorMonad m => String -> m CF
pCF s = do
rules <- mapM getCFRule $ filter isRule $ lines s
return $ concat rules
where
isRule line = case dropWhile isSpace line of
'-':'-':_ -> False
_ -> not $ all isSpace line
-- rules have an amazingly easy parser, if we use the format
-- fun. C -> item1 item2 ... where unquoted items are treated as cats
-- Actually would be nice to add profiles to this.
getCFRule :: ErrorMonad m => String -> m [CFRule]
getCFRule s = getcf (wrds s) where
getcf ws = case ws of
fun : cat : a : its | isArrow a ->
return [L NoLoc (init fun, (cat, map mkIt its))]
cat : a : its | isArrow a ->
return [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
_ -> raise (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="]
mkIt w = case w of
('"':w@(_:_)) -> Right (init w)
_ -> Left w
chunk its = case its of
[] -> [[]]
_ -> chunks "|" its
mkFun cat its = case its of
[] -> cat ++ "_"
_ -> concat $ intersperse "_" (cat : map clean its) -- CLE style
clean = filter isAlphaNum -- to form valid identifiers
wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
type CF = [CFRule]
type CFRule = L (CFFun, (CFCat, [CFItem]))
type CFItem = Either CFCat String
type CFCat = String
type CFFun = String
--------------------------------
-- make function names unique --
--------------------------------
uniqueFuns :: CF -> CF
uniqueFuns = snd . mapAccumL uniqueFun S.empty
where
uniqueFun funs (L l (fun,rule)) = (S.insert fun' funs,L l (fun',rule))
where
fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),
let fun'=fun++suffix,
not (fun' `S.member` funs)]
--------------------------
-- the compiler ----------
--------------------------
cf2gf :: FilePath -> CF -> SourceGrammar
cf2gf fpath cf = mGrammar [
(aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath Nothing abs),
(cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath Nothing cnc)
]
where
name = justModuleName fpath
(abs,cnc,cat) = cf2grammar cf
aname = identS $ name ++ "Abs"
cname = identS name
cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info, String)
cf2grammar rules = (buildTree abs, buildTree conc, cat) where
abs = cats ++ funs
conc = lincats ++ lins
cat = case rules of
(L _ (_,(c,_))):_ -> c -- the value category of the first rule
_ -> error "empty CF"
cats = [(cat, AbsCat (Just (L NoLoc []))) |
cat <- nub' (concat (map cf2cat rules))] ----notPredef cat
lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident]
cf2cat (L loc (_,(cat, items))) = map identS $ cat : [c | Left c <- items]
cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
f = identS fun
def = (f, AbsFun (Just (L loc (mkProd args' (Cn (identS cat)) []))) Nothing Nothing (Just True))
args0 = zip (map (identS . ("x" ++) . show) [0..]) items
args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0]
args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0]
ldef = (f, CncFun
Nothing
(Just (L loc (mkAbs (map fst args)
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
Nothing
Nothing)
mkIt (v, Left _) = P (Vr v) theLinLabel
mkIt (_, Right a) = K a
foldconcat [] = K ""
foldconcat tt = foldr1 C tt

18
src/compiler/GF/Speech/CFG.hs → src/compiler/GF/Grammar/CFG.hs
View File

@@ -4,7 +4,7 @@
--
-- Context-free grammar representation and manipulation.
----------------------------------------------------------------------
module GF.Speech.CFG where
module GF.Grammar.CFG where
import GF.Data.Utilities
import PGF
@@ -53,6 +53,7 @@ data CFG = CFG { cfgStartCat :: Cat,
cfgRules :: Map Cat (Set CFRule) }
deriving (Eq, Ord, Show)
--
-- * Grammar filtering
--
@@ -222,6 +223,21 @@ mkCFG start ext rs = CFG { cfgStartCat = start, cfgExternalCats = ext, cfgRules
groupProds :: [CFRule] -> Map Cat (Set CFRule)
groupProds = Map.fromListWith Set.union . map (\r -> (lhsCat r,Set.singleton r))
uniqueFuns :: CFG -> CFG
uniqueFuns cfg = CFG {cfgStartCat = cfgStartCat cfg
,cfgExternalCats = cfgExternalCats cfg
,cfgRules = Map.fromList (snd (mapAccumL uniqueFunSet Set.empty (Map.toList (cfgRules cfg))))
}
where
uniqueFunSet funs (cat,rules) =
let (funs',rules') = mapAccumL uniqueFun funs (Set.toList rules)
in (funs',(cat,Set.fromList rules'))
uniqueFun funs (CFRule cat items (CFObj fun args)) = (Set.insert fun' funs,CFRule cat items (CFObj fun' args))
where
fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),
let fun'=mkCId (showCId fun++suffix),
not (fun' `Set.member` funs)]
-- | Gets all rules in a CFG.
allRules :: CFG -> [CFRule]
allRules = concat . map Set.toList . Map.elems . cfgRules

232
src/compiler/GF/Grammar/EBNF.hs
View File

@@ -12,34 +12,19 @@
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Grammar.EBNF (getEBNF) where
module GF.Grammar.EBNF (EBNF, ERule, ERHS(..), ebnf2cf) where
import GF.Data.Operations
--import GF.Infra.Comments
import GF.Grammar.CF
--import GF.CF.CFIdent
import GF.Grammar.Grammar
--import GF.Grammar.PrGrammar
--import qualified GF.Source.AbsGF as A
import GF.Grammar.CFG
import PGF (mkCId)
import Data.Char
import Data.List
--import System.FilePath
-- AR 18/4/2000 - 31/3/2004
getEBNF :: FilePath -> String -> Err SourceGrammar
getEBNF fpath = fmap (cf2gf fpath . ebnf2cf) . pEBNF
type EBNF = [ERule]
type ERule = (ECat, ERHS)
type ECat = (String,[Int])
type ETok = String
ebnfID = "EBNF" ---- make this parametric!
data ERHS =
ETerm ETok
| ENonTerm ECat
@@ -50,13 +35,14 @@ data ERHS =
| EOpt ERHS
| EEmpty
type CFRHS = [CFItem]
type CFJustRule = (CFCat, CFRHS)
type CFRHS = [CFSymbol]
type CFJustRule = (Cat, CFRHS)
ebnf2cf :: EBNF -> [CFRule]
ebnf2cf ebnf =
[L NoLoc (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
mkCFF i (c, _) = ("Mk" ++ c ++ "_" ++ show i)
[CFRule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)]
where
mkCFF i c = CFObj (mkCId ("Mk" ++ c ++ "_" ++ show i)) []
normEBNF :: EBNF -> [CFJustRule]
normEBNF erules = let
@@ -115,13 +101,13 @@ substERules g (cat,itss) = (cat, map sub itss) where
sub (EIPlus r : ii) = EIPlus (substERules g r) : ii
sub (EIOpt r : ii) = EIOpt (substERules g r) : ii
eitem2cfitem :: EItem -> CFItem
eitem2cfitem :: EItem -> CFSymbol
eitem2cfitem it = case it of
EITerm a -> Right a
EINonTerm cat -> Left (mkCFCatE cat)
EIStar (cat,_) -> Left (mkCFCatE (mkNewECat cat "Star"))
EIPlus (cat,_) -> Left (mkCFCatE (mkNewECat cat "Plus"))
EIOpt (cat,_) -> Left (mkCFCatE (mkNewECat cat "Opt"))
EITerm a -> Terminal a
EINonTerm cat -> NonTerminal (mkCFCatE cat)
EIStar (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Star"))
EIPlus (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Plus"))
EIOpt (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Opt"))
type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items
@@ -157,198 +143,10 @@ mkECat ints = ("C", ints)
prECat (c,[]) = c
prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints)
mkCFCatE :: ECat -> CFCat
mkCFCatE :: ECat -> Cat
mkCFCatE = prECat
updECat _ (c,[]) = (c,[])
updECat ii (c,_) = (c,ii)
mkNewECat (c,ii) str = (c ++ str,ii)
------ parser for EBNF grammars
pEBNF :: String -> Err EBNF
pEBNF = parseResultErr (longestOfMany (pJ pERule))
pERule :: Parser Char ERule
pERule = pECat ... pJ (literals ":=" ||| literals "::=") +.. pERHS 0 ..+ jL ";"
pERHS :: Int -> Parser Char ERHS
pERHS 0 = pTList "|" (pERHS 1) *** foldr1 EAlt
pERHS 1 = longestOfMany (pJ (pERHS 2)) *** foldr ESeq EEmpty
pERHS 2 = pERHS 3 ... pJ pUnaryEOp *** (\ (a,f) -> f a)
pERHS 3 = pQuotedString *** ETerm
||| pECat *** ENonTerm ||| pParenth (pERHS 0)
pUnaryEOp :: Parser Char (ERHS -> ERHS)
pUnaryEOp =
lits "*" <<< EStar ||| lits "+" <<< EPlus ||| lits "?" <<< EOpt ||| succeed id
pECat = pIdent *** (\c -> (c,[]))
----------------------------------------------------------------------
-- Module : Parsers
-- some parser combinators a la Wadler and Hutton.
-- (only used in module "EBNF")
-----------------------------------------------------------------------------
infixr 2 |||, +||
infixr 3 ***
infixr 5 .>.
infixr 5 ...
infixr 5 ....
infixr 5 +..
infixr 5 ..+
infixr 6 |>
infixr 3 <<<
type Parser a b = [a] -> [(b,[a])]
parseResults :: Parser a b -> [a] -> [b]
parseResults p s = [x | (x,r) <- p s, null r]
parseResultErr :: Show a => Parser a b -> [a] -> Err b
parseResultErr p s = case parseResults p s of
[x] -> return x
[] -> case
maximumBy (\x y -> compare (length y) (length x)) (s:[r | (_,r) <- p s]) of
r -> Bad $ "\nno parse; reached" ++++ take 300 (show r)
_ -> Bad "ambiguous"
(...) :: Parser a b -> Parser a c -> Parser a (b,c)
(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t]
(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c
(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t]
(|||) :: Parser a b -> Parser a b -> Parser a b
(p ||| q) s = p s ++ q s
(+||) :: Parser a b -> Parser a b -> Parser a b
p1 +|| p2 = take 1 . (p1 ||| p2)
literal :: (Eq a) => a -> Parser a a
literal x (c:cs) = [(x,cs) | x == c]
literal _ _ = []
(***) :: Parser a b -> (b -> c) -> Parser a c
(p *** f) s = [(f x,r) | (x,r) <- p s]
succeed :: b -> Parser a b
succeed v s = [(v,s)]
fails :: Parser a b
fails s = []
(+..) :: Parser a b -> Parser a c -> Parser a c
p1 +.. p2 = p1 ... p2 *** snd
(..+) :: Parser a b -> Parser a c -> Parser a b
p1 ..+ p2 = p1 ... p2 *** fst
(<<<) :: Parser a b -> c -> Parser a c -- return
p <<< v = p *** (\x -> v)
(|>) :: Parser a b -> (b -> Bool) -> Parser a b
p |> b = p .>. (\x -> if b x then succeed x else fails)
many :: Parser a b -> Parser a [b]
many p = (p ... many p *** uncurry (:)) +|| succeed []
some :: Parser a b -> Parser a [b]
some p = (p ... many p) *** uncurry (:)
longestOfMany :: Parser a b -> Parser a [b]
longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed []
closure :: (b -> Parser a b) -> (b -> Parser a b)
closure p v = p v .>. closure p ||| succeed v
pJunk :: Parser Char String
pJunk = longestOfMany (satisfy (\x -> elem x "\n\t "))
pJ :: Parser Char a -> Parser Char a
pJ p = pJunk +.. p ..+ pJunk
pTList :: String -> Parser Char a -> Parser Char [a]
pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999
pTJList :: String -> String -> Parser Char a -> Parser Char [a]
pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:))
pElem :: [String] -> Parser Char String
pElem l = foldr (+||) fails (map literals l)
(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c)
p1 .... p2 = p1 ... pJunk +.. p2
item :: Parser a a
item (c:cs) = [(c,cs)]
item [] = []
satisfy :: (a -> Bool) -> Parser a a
satisfy b = item |> b
literals :: (Eq a,Show a) => [a] -> Parser a [a]
literals l = case l of
[] -> succeed []
a:l -> literal a ... literals l *** (\ (x,y) -> x:y)
lits :: (Eq a,Show a) => [a] -> Parser a [a]
lits ts = literals ts
jL :: String -> Parser Char String
jL = pJ . lits
pParenth :: Parser Char a -> Parser Char a
pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')'
-- | p,...,p
pCommaList :: Parser Char a -> Parser Char [a]
pCommaList p = pTList "," (pJ p)
-- | the same or nothing
pOptCommaList :: Parser Char a -> Parser Char [a]
pOptCommaList p = pCommaList p ||| succeed []
-- | (p,...,p), poss. empty
pArgList :: Parser Char a -> Parser Char [a]
pArgList p = pParenth (pCommaList p) ||| succeed []
-- | min. 2 args
pArgList2 :: Parser Char a -> Parser Char [a]
pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:)
longestOfSome :: Parser a b -> Parser a [b]
longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y)
pIdent :: Parser Char String
pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:)
where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\''
pLetter, pDigit :: Parser Char Char
pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++
['\192' .. '\255'])) -- no such in Char
pDigit = satisfy isDigit
pLetters :: Parser Char String
pLetters = longestOfSome pLetter
pAlphanum, pAlphaPlusChar :: Parser Char Char
pAlphanum = pDigit ||| pLetter
pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'")
pQuotedString :: Parser Char String
pQuotedString = literal '"' +.. pEndQuoted where
pEndQuoted =
literal '"' *** (const [])
+|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:))
+|| item .>. \ c -> pEndQuoted *** (c:)
pIntc :: Parser Char Int
pIntc = some (satisfy numb) *** read
where numb x = elem x ['0'..'9']

5
src/compiler/GF/Grammar/Lexer.x
View File

@@ -26,7 +26,7 @@ $i = [$l $d _ '] -- identifier character
$u = [.\n] -- universal: any character
@rsyms = -- symbols and non-identifier-like reserved words
\; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/
\; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ | \: \= | \: \: \=
:-
"--" [.]* ; -- Toss single line comments
@@ -83,6 +83,7 @@ data Token
| T_ccurly
| T_underscore
| T_at
| T_cfarrow
| T_PType
| T_Str
| T_Strs
@@ -169,6 +170,8 @@ resWords = Map.fromList
, b "|" T_bar
, b "_" T_underscore
, b "@" T_at
, b "::=" T_cfarrow
, b ":=" T_cfarrow
, b "PType" T_PType
, b "Str" T_Str
, b "Strs" T_Strs

77
src/compiler/GF/Grammar/Parser.y
View File

@@ -7,6 +7,8 @@ module GF.Grammar.Parser
, pModHeader
, pExp
, pTopDef
, pCFRules
, pEBNFRules
) where
import GF.Infra.Ident
@@ -14,17 +16,23 @@ import GF.Infra.Option
import GF.Data.Operations
import GF.Grammar.Predef
import GF.Grammar.Grammar
import GF.Grammar.CFG
import GF.Grammar.EBNF
import GF.Grammar.Macros
import GF.Grammar.Lexer
import GF.Compile.Update (buildAnyTree)
--import Codec.Binary.UTF8.String(decodeString)
--import Data.Char(toLower)
import Data.List(intersperse)
import Data.Char(isAlphaNum)
import PGF(mkCId)
}
%name pModDef ModDef
%name pTopDef TopDef
%partial pModHeader ModHeader
%name pExp Exp
%name pCFRules ListCFRule
%name pEBNFRules ListEBNFRule
-- no lexer declaration
%monad { P } { >>= } { return }
@@ -64,6 +72,7 @@ import GF.Compile.Update (buildAnyTree)
'\\\\' { T_lamlam }
'_' { T_underscore}
'|' { T_bar }
'::=' { T_cfarrow }
'PType' { T_PType }
'Str' { T_Str }
'Strs' { T_Strs }
@@ -602,6 +611,70 @@ ListDDecl
: {- empty -} { [] }
| DDecl ListDDecl { $1 ++ $2 }
ListCFRule :: { [CFRule] }
ListCFRule
: CFRule { $1 }
| CFRule ListCFRule { $1 ++ $2 }
CFRule :: { [CFRule] }
CFRule
: Ident '.' Ident '::=' ListCFSymbol ';' { [CFRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
}
| Ident '::=' ListCFRHS ';' { let { cat = showIdent $1;
mkFun cat its =
case its of {
[] -> cat ++ "_";
_ -> concat $ intersperse "_" (cat : filter (not . null) (map clean its)) -- CLE style
};
clean sym =
case sym of {
Terminal c -> filter isAlphaNum c;
NonTerminal t -> t
}
} in map (\rhs -> CFRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
}
ListCFRHS :: { [[CFSymbol]] }
ListCFRHS
: ListCFSymbol { [$1] }
| ListCFSymbol '|' ListCFRHS { $1 : $3 }
ListCFSymbol :: { [CFSymbol] }
ListCFSymbol
: {- empty -} { [] }
| CFSymbol ListCFSymbol { $1 : $2 }
CFSymbol :: { CFSymbol }
: String { Terminal $1 }
| Ident { NonTerminal (showIdent $1) }
ListEBNFRule :: { [ERule] }
ListEBNFRule
: EBNFRule { [$1] }
| EBNFRule ListEBNFRule { $1 : $2 }
EBNFRule :: { ERule }
: Ident '::=' ERHS0 ';' { ((showIdent $1,[]),$3) }
ERHS0 :: { ERHS }
: ERHS1 { $1 }
| ERHS1 '|' ERHS0 { EAlt $1 $3 }
ERHS1 :: { ERHS }
: ERHS2 { $1 }
| ERHS2 ERHS1 { ESeq $1 $2 }
ERHS2 :: { ERHS }
: ERHS3 '*' { EStar $1 }
| ERHS3 '+' { EPlus $1 }
| ERHS3 '?' { EOpt $1 }
| ERHS3 { $1 }
ERHS3 :: { ERHS }
: String { ETerm $1 }
| Ident { ENonTerm (showIdent $1,[]) }
| '(' ERHS0 ')' { $2 }
Posn :: { Posn }
Posn
: {- empty -} {% getPosn }

2
src/compiler/GF/Speech/CFGToFA.hs
View File

@@ -17,7 +17,7 @@ import qualified Data.Set as Set
--import PGF.CId
import PGF.Data
import GF.Data.Utilities
import GF.Speech.CFG
import GF.Grammar.CFG
--import GF.Speech.PGFToCFG
--import GF.Infra.Ident (Ident)

2
src/compiler/GF/Speech/GSL.hs
View File

@@ -9,7 +9,7 @@
module GF.Speech.GSL (gslPrinter) where
--import GF.Data.Utilities
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.SRG
import GF.Speech.RegExp
import GF.Infra.Option

2
src/compiler/GF/Speech/JSGF.hs
View File

@@ -14,7 +14,7 @@ module GF.Speech.JSGF (jsgfPrinter) where
--import GF.Data.Utilities
import GF.Infra.Option
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.RegExp
import GF.Speech.SISR
import GF.Speech.SRG

2
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -10,7 +10,7 @@ import PGF(showCId)
import PGF.Data as PGF
import PGF.Macros
--import GF.Infra.Ident
import GF.Speech.CFG hiding (Symbol)
import GF.Grammar.CFG hiding (Symbol)
import Data.Array.IArray as Array
--import Data.List

2
src/compiler/GF/Speech/PrRegExp.hs
View File

@@ -7,7 +7,7 @@
module GF.Speech.PrRegExp (regexpPrinter,multiRegexpPrinter) where
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.CFGToFA
import GF.Speech.PGFToCFG
import GF.Speech.RegExp

2
src/compiler/GF/Speech/SISR.hs
View File

@@ -13,7 +13,7 @@ import Data.List
--import GF.Data.Utilities
--import GF.Infra.Ident
import GF.Infra.Option (SISRFormat(..))
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.SRG (SRGNT)
import PGF(showCId)

2
src/compiler/GF/Speech/SLF.hs
View File

@@ -13,7 +13,7 @@ module GF.Speech.SLF (slfPrinter,slfGraphvizPrinter,
slfSubPrinter,slfSubGraphvizPrinter) where
import GF.Data.Utilities
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.FiniteState
--import GF.Speech.CFG
import GF.Speech.CFGToFA

2
src/compiler/GF/Speech/SRG.hs
View File

@@ -21,7 +21,7 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
import GF.Data.Utilities
--import GF.Infra.Ident
import GF.Infra.Option
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.PGFToCFG
--import GF.Data.Relation
--import GF.Speech.FiniteState

2
src/compiler/GF/Speech/SRGS_ABNF.hs
View File

@@ -21,7 +21,7 @@ module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
--import GF.Data.Utilities
import GF.Infra.Option
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.SISR as SISR
import GF.Speech.SRG
import GF.Speech.RegExp

2
src/compiler/GF/Speech/SRGS_XML.hs
View File

@@ -9,7 +9,7 @@ module GF.Speech.SRGS_XML (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where
--import GF.Data.Utilities
import GF.Data.XML
import GF.Infra.Option
import GF.Speech.CFG
import GF.Grammar.CFG
import GF.Speech.RegExp
import GF.Speech.SISR as SISR
import GF.Speech.SRG

26
src/compiler/GFC.hs
View File

@@ -8,10 +8,11 @@ import PGF.Optimize
import PGF.Binary(putSplitAbs)
import GF.Compile
import GF.Compile.Export
import GF.Compile.CFGtoPGF
import GF.Compile.GetGrammar
import GF.Grammar.CFG
import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008
import GF.Infra.Ident(identS,showIdent)
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Data.ErrM
@@ -21,6 +22,7 @@ import Data.Maybe
import Data.Binary(encode,encodeFile)
import Data.Binary.Put(runPut)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy as BSL
import System.FilePath
@@ -61,14 +63,18 @@ compileSourceFiles opts fs =
writeOutputs opts pgf
compileCFFiles :: Options -> [FilePath] -> IOE ()
compileCFFiles opts fs =
do s <- liftIO $ fmap unlines $ mapM readFile fs
let cnc = justModuleName (last fs)
gr <- compileSourceGrammar opts =<< getCF cnc s
unless (flag optStopAfterPhase opts == Compile) $
do pgf <- link opts (identS cnc, (), gr)
writePGF opts pgf
writeOutputs opts pgf
compileCFFiles opts fs = do
rules <- fmap concat $ mapM (getCFRules opts) fs
startCat <- case rules of
(CFRule cat _ _ : _) -> return cat
_ -> fail "empty CFG"
let gf = cf2gf (last fs) (uniqueFuns (mkCFG startCat Set.empty rules))
gr <- compileSourceGrammar opts gf
let cnc = justModuleName (last fs)
unless (flag optStopAfterPhase opts == Compile) $
do pgf <- link opts (identS cnc, (), gr)
writePGF opts pgf
writeOutputs opts pgf
unionPGFFiles :: Options -> [FilePath] -> IOE ()
unionPGFFiles opts fs =