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

PGF is now real synchronous PMCFG

Browse Source
This commit is contained in:
krasimir
2010-01-17 21:35:36 +00:00
parent 362f333ebd
commit a039808141
23 changed files with 296 additions and 599 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src/compiler/GF/Command/Commands.hs
View File

@@ -19,6 +19,7 @@ import PGF.VisualizeTree
import PGF.Macros
import PGF.Data ----
import PGF.Morphology
import PGF.Printer
import GF.Compile.Export
import GF.Infra.Option (noOptions, readOutputFormat, Encoding(..))
import GF.Infra.UseIO
@@ -752,22 +753,17 @@ allCommands cod env@(pgf, mos) = Map.fromList [
exec = \opts arg -> do
case arg of
[EFun id] -> case Map.lookup id (funs (abstract pgf)) of
Just (ty,_,eqs) -> return $ fromString $
render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs
then empty
else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts
in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just hyps -> do return $ fromString $
render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL ppHypo [] hyps)) $$
if null (functionsToCat pgf id)
then empty
else space $$
text "fun" <+> vcat [ppCId fid <+> colon <+> ppType 0 [] ty
| (fid,ty) <- functionsToCat pgf id])
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
Just fd -> return $ fromString $
render (ppFun id fd)
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just hyps -> do return $ fromString $
render (ppCat id hyps $$
if null (functionsToCat pgf id)
then empty
else space $$
vcat [ppFun fid (ty,0,[]) | (fid,ty) <- functionsToCat pgf id])
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
[e] -> case inferExpr pgf e of
Left tcErr -> error $ render (ppTcError tcErr)
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
@@ -782,8 +778,8 @@ allCommands cod env@(pgf, mos) = Map.fromList [
enc = encodeUnicode cod
par opts s = case optOpenTypes opts of
[] -> concat [parse pgf lang (optType opts) s | lang <- optLangs opts, canParse pgf lang]
open_typs -> concat [parseWithRecovery pgf lang (optType opts) open_typs s | lang <- optLangs opts, canParse pgf lang]
[] -> concat [parse pgf lang (optType opts) s | lang <- optLangs opts]
open_typs -> concat [parseWithRecovery pgf lang (optType opts) open_typs s | lang <- optLangs opts]
void = ([],[])

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

@@ -6,7 +6,6 @@ import GF.Compile.Rename
import GF.Compile.CheckGrammar
import GF.Compile.Optimize
import GF.Compile.SubExOpt
import GF.Compile.OptimizePGF
import GF.Compile.GrammarToPGF
import GF.Compile.ReadFiles
import GF.Compile.Update
@@ -54,31 +53,16 @@ compileToPGF opts fs =
link :: Options -> String -> SourceGrammar -> IOE PGF
link opts cnc gr = do
let isv = (verbAtLeast opts Normal)
gc1 <- putPointE Normal opts "linking ... " $
let (abs,gc0) = mkCanon2gfcc opts cnc gr
in case checkPGF gc0 of
Ok (gc,b) -> do
case (isv,b) of
(True, True) -> ioeIO $ putStrLn "OK"
(False,True) -> return ()
_ -> ioeIO $ putStrLn $ "Corrupted PGF"
return gc
Bad s -> fail s
ioeIO $ buildParser opts $ optimize opts gc1
optimize :: Options -> PGF -> PGF
optimize opts = cse . suf
where os = flag optOptimizations opts
cse = if OptCSE `Set.member` os then cseOptimize else id
suf = if OptStem `Set.member` os then suffixOptimize else id
buildParser :: Options -> PGF -> IO PGF
buildParser opts =
case flag optBuildParser opts of
BuildParser -> addParsers opts
DontBuildParser -> return
BuildParserOnDemand -> return . mapConcretes (\cnc -> cnc { cflags = Map.insert (mkCId "parser") "ondemand" (cflags cnc) })
let isv = (verbAtLeast opts Normal)
putPointE Normal opts "linking ... " $ do
gc0 <- ioeIO (mkCanon2pgf opts cnc gr)
case checkPGF gc0 of
Ok (gc,b) -> do case (isv,b) of
(True, True) -> ioeIO $ putStrLn "OK"
(False,True) -> return ()
_ -> ioeIO $ putStrLn $ "Corrupted PGF"
return gc
Bad s -> fail s
batchCompile :: Options -> [FilePath] -> IOE SourceGrammar
batchCompile opts files = do

6
src/compiler/GF/Compile/Export.hs
View File

@@ -2,10 +2,10 @@ module GF.Compile.Export where
import PGF.CId
import PGF.Data (PGF(..))
import PGF.Printer
import GF.Compile.PGFtoHaskell
import GF.Compile.PGFtoProlog
import GF.Compile.PGFtoJS
import GF.Compile.PGFPretty
import GF.Infra.Option
import GF.Speech.CFG
import GF.Speech.PGFToCFG
@@ -20,6 +20,7 @@ import GF.Speech.PrRegExp
import Data.Maybe
import System.FilePath
import Text.PrettyPrint
-- top-level access to code generation
@@ -29,8 +30,7 @@ exportPGF :: Options
-> [(FilePath,String)] -- ^ List of recommended file names and contents.
exportPGF opts fmt pgf =
case fmt of
FmtPGFPretty -> multi "txt" prPGFPretty
FmtPMCFGPretty -> single "pmcfg" prPMCFGPretty
FmtPGFPretty -> multi "txt" (render . ppPGF)
FmtJavaScript -> multi "js" pgf2js
FmtHaskell -> multi "hs" (grammar2haskell opts name)
FmtProlog -> multi "pl" grammar2prolog

38
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -35,24 +35,20 @@ import Control.Exception
-- main conversion function
convertConcrete :: Options -> Abstr -> CId -> Concr -> IO ParserInfo
convertConcrete opts abs lang cnc = do
--convertConcrete :: Options -> Abstr -> CId -> Concr -> IO Concr
convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_defs = do
let env0 = emptyGrammarEnv cnc_defs cat_defs params
when (flag optProf opts) $ do
profileGrammar lang cnc_defs env0 pfrules
let env1 = expandHOAS abs_defs cnc_defs cat_defs lin_defs env0
env2 = List.foldl' (convertRule cnc_defs) env1 pfrules
return $ getParserInfo env2
return $ getParserInfo flags printnames env2
where
abs_defs = Map.assocs (funs abs)
cnc_defs = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
cat_defs = Map.insert cidVar (S []) (lincats cnc)
params = paramlincats cnc
lin_defs = lindefs cnc
cat_defs = Map.insert cidVar (S []) lincats
pfrules = [
(PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) |
(id, (ty,_,_)) <- abs_defs, let (args,res) = typeSkeleton ty,
(id, (ty,_,_)) <- Map.toList abs_defs, let (args,res) = typeSkeleton ty,
term <- maybeToList (Map.lookup id cnc_defs)]
findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
@@ -364,7 +360,7 @@ expandHOAS abs_defs cnc_defs lincats lindefs env =
foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats)
where
hoTypes :: [(Int,CId)]
hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- abs_defs
hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- Map.toList abs_defs
, (n,c) <- fst (typeSkeleton ty), n > 0]
-- add a range of PMCFG categories for each GF high-order category
@@ -438,16 +434,18 @@ addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fc
Nothing -> let !fcat = last_id+1
in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat)
getParserInfo :: GrammarEnv -> ParserInfo
getParserInfo (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
ParserInfo { functions = mkArray funSet
, sequences = mkArray seqSet
, productions = IntMap.union prodSet coercions
, pproductions = IntMap.empty
, lproductions = Map.empty
, startCats = maybe Map.empty (Map.map (\(start,end,_,lbls) -> (start,end,lbls))) (IntMap.lookup 0 catSet)
, totalCats = last_id+1
}
getParserInfo :: Map.Map CId String -> Map.Map CId String -> GrammarEnv -> Concr
getParserInfo flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
Concr { cflags = flags
, printnames = printnames
, functions = mkArray funSet
, sequences = mkArray seqSet
, productions = IntMap.union prodSet coercions
, pproductions = IntMap.empty
, lproductions = Map.empty
, startCats = maybe Map.empty (Map.map (\(start,end,_,lbls) -> (start,end,lbls))) (IntMap.lookup 0 catSet)
, totalCats = last_id+1
}
where
mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]

37
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -1,11 +1,12 @@
{-# LANGUAGE PatternGuards #-}
module GF.Compile.GrammarToPGF (mkCanon2gfcc,addParsers) where
module GF.Compile.GrammarToPGF (mkCanon2pgf) where
import GF.Compile.Export
import GF.Compile.GeneratePMCFG
import PGF.CId
import PGF.Macros(updateProductionIndices)
import PGF.Check(checkLin)
import qualified PGF.Macros as CM
import qualified PGF.Data as C
import qualified PGF.Data as D
@@ -36,28 +37,22 @@ traceD s t = t
-- the main function: generate PGF from GF.
mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF)
mkCanon2gfcc opts cnc gr =
(showIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr)
mkCanon2pgf :: Options -> String -> SourceGrammar -> IO D.PGF
mkCanon2pgf opts cnc gr = (canon2pgf opts pars . reorder abs . canon2canon opts abs) gr
where
abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc)
pars = mkParamLincat gr
-- Adds parsers for all concretes
addParsers :: Options -> D.PGF -> IO D.PGF
addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toList (D.concretes pgf)]
return $ updateProductionIndices $ pgf { D.concretes = Map.fromList cncs }
where
conv lang cnc = do pinfo <- convertConcrete opts (D.abstract pgf) lang cnc
return (lang,cnc { D.parser = Just pinfo })
-- Generate PGF from GFCM.
-- this assumes a grammar translated by canon2canon
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
(if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $
D.PGF an cns gflags abs cncs
canon2pgf :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> IO D.PGF
canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
if dump opts DumpCanon
then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr))))
else return ()
cncs <- sequence [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
return (D.PGF an cns gflags abs (Map.fromList cncs))
where
-- abstract
an = (i2i a)
@@ -82,13 +77,15 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
catfuns = Map.fromList
[(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
mkConcr lang0 lang mo =
(lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
mkConcr lang0 lang mo = do
lins' <- case mapM (checkLin (funs,lins,lincats) lang) (Map.toList lins) of
Ok x -> return x
Bad msg -> fail msg
cnc <- convertConcrete opts lang flags printnames funs (Map.fromList (map fst lins')) lincats params lindefs
return (lang, cnc)
where
js = tree2list (M.jments mo)
flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags mo)]
opers = Map.fromAscList [] -- opers will be created as optimization
utf = id -- trace (show lang0 +++ show flags) $
-- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8
-- then id else id

118
src/compiler/GF/Compile/OptimizePGF.hs
View File

@@ -1,118 +0,0 @@
module GF.Compile.OptimizePGF where
import PGF.CId
import PGF.Data
import PGF.Macros
import GF.Data.Operations
import Data.List
import qualified Data.Map as Map
-- back-end optimization:
-- suffix analysis followed by common subexpression elimination
optPGF :: PGF -> PGF
optPGF = cseOptimize . suffixOptimize
suffixOptimize :: PGF -> PGF
suffixOptimize = mapConcretes opt
where
opt cnc = cnc {
lins = Map.map optTerm (lins cnc),
lindefs = Map.map optTerm (lindefs cnc)
}
cseOptimize :: PGF -> PGF
cseOptimize = mapConcretes subex
-- analyse word form lists into prefix + suffixes
-- suffix sets can later be shared by subex elim
optTerm :: Term -> Term
optTerm tr = case tr of
R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts]
R ts -> R $ map optTerm ts
P t v -> P (optTerm t) v
_ -> tr
where
optToks ss = prf : suffs where
prf = pref (head ss) (tail ss)
suffs = map (drop (length prf)) ss
pref cand ss = case ss of
s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
_ -> cand
isK t = case t of
K (KS _) -> True
_ -> False
mkSuff ("":ws) = R (map (K . KS) ws)
mkSuff (p:ws) = W p (R (map (K . KS) ws))
-- common subexpression elimination
---subex :: [(CId,Term)] -> [(CId,Term)]
subex :: Concr -> Concr
subex cnc = err error id $ do
(tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0)
return $ addSubexpConsts tree cnc
type TermList = Map.Map Term (Int,Int) -- number of occs, id
type TermM a = STM (TermList,Int) a
addSubexpConsts :: TermList -> Concr -> Concr
addSubexpConsts tree cnc = cnc {
opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops],
lins = rec lins,
lindefs = rec lindefs
}
where
ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree]
mkOne (f,trm) = (f, recomp f trm)
recomp f t = case Map.lookup t tree of
Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself
_ -> case t of
R ts -> R $ map (recomp f) ts
S ts -> S $ map (recomp f) ts
W s t -> W s (recomp f t)
P t p -> P (recomp f t) (recomp f p)
_ -> t
fid n = mkCId $ "_" ++ show n
rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]
getSubtermsMod :: Concr -> TermM TermList
getSubtermsMod cnc = do
mapM getSubterms (Map.assocs (lins cnc))
mapM getSubterms (Map.assocs (lindefs cnc))
(tree0,_) <- readSTM
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getSubterms (f,trm) = collectSubterms trm >> return ()
collectSubterms :: Term -> TermM ()
collectSubterms t = case t of
R ts -> do
mapM collectSubterms ts
add t
S ts -> do
mapM collectSubterms ts
add t
W s u -> do
collectSubterms u
add t
P p u -> do
collectSubterms p
collectSubterms u
add t
_ -> return ()
where
add t = do
(ts,i) <- readSTM
let
((count,id),next) = case Map.lookup t ts of
Just (nu,id) -> ((nu+1,id), i)
_ -> ((1, i ), i+1)
writeSTM (Map.insert t (count,id) ts, next)

94
src/compiler/GF/Compile/PGFPretty.hs
View File

@@ -1,94 +0,0 @@
-- | Print a part of a PGF grammar on the human-readable format used in
-- the paper "PGF: A Portable Run-Time Format for Type-Theoretical Grammars".
module GF.Compile.PGFPretty (prPGFPretty, prPMCFGPretty) where
import PGF.CId
import PGF.Data
import PGF.Macros
import PGF.PMCFG
import GF.Data.Operations
import Data.Map (Map)
import qualified Data.Map as Map
import Text.PrettyPrint.HughesPJ
prPGFPretty :: PGF -> String
prPGFPretty pgf = render $ prAbs (abstract pgf) $$ prAll (prCnc (abstract pgf)) (concretes pgf)
prPMCFGPretty :: PGF -> CId -> String
prPMCFGPretty pgf lang = render $
case lookParser pgf lang of
Nothing -> empty
Just pinfo -> text "language" <+> ppCId lang $$ ppPMCFG pinfo
prAbs :: Abstr -> Doc
prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a)
prCat :: CId -> [Hypo] -> Doc
prCat c h | isLiteralCat c = empty
| otherwise = text "cat" <+> ppCId c
prFun :: CId -> (Type,Int,[Equation]) -> Doc
prFun f (t,_,_) = text "fun" <+> ppCId f <+> text ":" <+> prType t
prType :: Type -> Doc
prType t = parens (hsep (punctuate (text ",") (map ppCId cs))) <+> text "->" <+> ppCId c
where (cs,c) = catSkeleton t
-- FIXME: show concrete name
-- FIXME: inline opers first
prCnc :: Abstr -> CId -> Concr -> Doc
prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c))
where
prLinCat :: CId -> Term -> Doc
prLinCat c t | isLiteralCat c = empty
| otherwise = text "lincat" <+> ppCId c <+> text "=" <+> pr 0 t
where
pr p (R ts) = prec p 1 (hsep (punctuate (text " *") (map (pr 1) ts)))
pr _ (S []) = text "Str"
pr _ (C n) = text "Int_" <> text (show (n+1))
prLin :: CId -> Term -> Doc
prLin f t = text "lin" <+> ppCId f <+> text "=" <+> pr 0 t
where
pr :: Int -> Term -> Doc
pr p (R ts) = text "<" <+> hsep (punctuate (text ",") (map (pr 0) ts)) <+> text ">"
pr p (P t1 t2) = prec p 3 (pr 3 t1 <> text "!" <> pr 3 t2)
pr p (S ts) = prec p 2 (hsep (punctuate (text " ++") (map (pr 2) ts)))
pr p (K (KS t)) = doubleQuotes (text t)
pr p (K _) = empty
pr p (V i) = text ("argv_" ++ show (i+1))
pr p (C i) = text (show (i+1))
pr p (FV ts) = prec p 1 (hsep (punctuate (text " |") (map (pr 1) ts)))
pr _ t = error $ "PGFPretty.prLin " ++ show t
linCat :: Concr -> CId -> Term
linCat cnc c = Map.findWithDefault (error $ "lincat: " ++ showCId c) c (lincats cnc)
prec :: Int -> Int -> Doc -> Doc
prec p m | p >= m = parens
| otherwise = id
expand :: Concr -> Concr
expand cnc = cnc { lins = Map.map (f "") (lins cnc) }
where
-- FIXME: handle KP
f :: String -> Term -> Term
f w (R ts) = R (map (f w) ts)
f w (P t1 t2) = P (f w t1) (f w t2)
f w (S []) = S (if null w then [] else [K (KS w)])
f w (S (t:ts)) = S (f w t : map (f "") ts)
f w (FV ts) = FV (map (f w) ts)
f w (W s t) = f (w++s) t
f w (K (KS t)) = K (KS (w++t))
f w (F o) = f w (Map.findWithDefault (error $ "Bad oper: " ++ showCId o) o (opers cnc))
f w t = t
-- Utilities
prAll :: (a -> b -> Doc) -> Map a b -> Doc
prAll p m = vcat [ p k v | (k,v) <- Map.toList m]

30
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -29,7 +29,7 @@ pgf2js pgf =
start = showCId $ M.lookStartCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start as
js_concrete = JS.EObj $ map (concrete2js n) cs
js_concrete = JS.EObj $ map concrete2js cs
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
@@ -39,18 +39,21 @@ absdef2js (f,(typ,_,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
concrete2js :: String -> (CId,Concr) -> JS.Property
concrete2js n (c, cnc) =
JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (showCId c)) ds) ++ litslins))] ++
maybe [] parser2js (parser cnc)))
concrete2js :: (CId,Concr) -> JS.Property
concrete2js (c,cnc) =
JS.Prop l (new "GFConcrete" [mapToJSObj JS.EStr $ cflags cnc,
JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)],
JS.EArray $ (map ffun2js (Array.elems (functions cnc))),
JS.EArray $ (map seq2js (Array.elems (sequences cnc))),
JS.EObj $ map cats (Map.assocs (startCats cnc)),
JS.EInt (totalCats cnc)])
where
flags = mapToJSObj JS.EStr $ cflags cnc
l = JS.IdentPropName (JS.Ident (showCId c))
ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc]
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
cats (c,(start,end,_)) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
cncdef2js :: String -> String -> (CId,Term) -> JS.Property
cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
@@ -88,17 +91,6 @@ argIdent n = JS.Ident ("x" ++ show n)
children :: JS.Ident
children = JS.Ident "cs"
-- Parser
parser2js :: ParserInfo -> [JS.Expr]
parser2js p = [new "Parser" [JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions p)],
JS.EArray $ (map ffun2js (Array.elems (functions p))),
JS.EArray $ (map seq2js (Array.elems (sequences p))),
JS.EObj $ map cats (Map.assocs (startCats p)),
JS.EInt (totalCats p)]]
where
cats (c,(start,end,_)) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
frule2js :: Production -> JS.Expr
frule2js (FApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)]
frule2js (FCoerce arg) = new "Coerce" [JS.EInt arg]

13
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -88,20 +88,11 @@ plFundef (fun, (_,_,eqs)) = [plFact "def" [plp fun, plp fundef']]
-- concrete syntax
plConcrete :: (CId, Concr) -> [String]
plConcrete (cncname, Concr cflags lins opers lincats lindefs
_printnames _paramlincats _parser) =
plConcrete (cncname, cnc) =
["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%",
"%% concrete module: " ++ plp cncname] ++
clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax"
(map (mod . plpFact2 "cncflag") (Map.assocs cflags)) ++
clauseHeader "%% lincat(?Cat, ?Linearization type)"
(map (mod . plpFact2 "lincat") (Map.assocs lincats)) ++
clauseHeader "%% lindef(?Cat, ?Linearization default)"
(map (mod . plpFact2 "lindef") (Map.assocs lindefs)) ++
clauseHeader "%% lin(?Fun, ?Linearization)"
(map (mod . plpFact2 "lin") (Map.assocs lins)) ++
clauseHeader "%% oper(?Oper, ?Linearization)"
(map (mod . plpFact2 "oper") (Map.assocs opers))
(map (mod . plpFact2 "cncflag") (Map.assocs (cflags cnc)))
where mod clause = plp cncname ++ ": " ++ clause

16
src/compiler/GF/Infra/Option.hs
View File

@@ -5,7 +5,7 @@ module GF.Infra.Option
Flags(..),
Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Printer(..), Recomp(..), BuildParser(..),
Dump(..), Printer(..), Recomp(..),
-- * Option parsing
parseOptions, parseModuleOptions, fixRelativeLibPaths,
-- * Option pretty-printing
@@ -81,7 +81,6 @@ data Encoding = UTF_8 | ISO_8859_1 | CP_1250 | CP_1251 | CP_1252
deriving (Eq,Ord)
data OutputFormat = FmtPGFPretty
| FmtPMCFGPretty
| FmtJavaScript
| FmtHaskell
| FmtProlog
@@ -137,9 +136,6 @@ data Printer = PrinterStrip -- ^ Remove name qualifiers.
data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
deriving (Show,Eq,Ord)
data BuildParser = BuildParser | DontBuildParser | BuildParserOnDemand
deriving (Show,Eq,Ord)
data Flags = Flags {
optMode :: Mode,
optStopAfterPhase :: Phase,
@@ -172,7 +168,6 @@ data Flags = Flags {
optSpeechLanguage :: Maybe String,
optLexer :: Maybe String,
optUnlexer :: Maybe String,
optBuildParser :: BuildParser,
optWarnings :: [Warning],
optDump :: [Dump]
}
@@ -218,7 +213,6 @@ optionsPGF :: Options -> [(String,String)]
optionsPGF opts =
maybe [] (\x -> [("language",x)]) (flag optSpeechLanguage opts)
++ maybe [] (\x -> [("startcat",x)]) (flag optStartCat opts)
++ (if flag optBuildParser opts == BuildParserOnDemand then [("parser","ondemand")] else [])
-- Option manipulation
@@ -274,7 +268,6 @@ defaultFlags = Flags {
optSpeechLanguage = Nothing,
optLexer = Nothing,
optUnlexer = Nothing,
optBuildParser = BuildParser,
optWarnings = [],
optDump = []
}
@@ -351,7 +344,6 @@ optDescr =
Option [] ["coding"] (ReqArg coding "ENCODING")
("Character encoding of the source grammar, ENCODING = "
++ concat (intersperse " | " (map fst encodings)) ++ "."),
Option [] ["parser"] (ReqArg buildParser "VALUE") "Build parser (default on). VALUE = on | off | ondemand",
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
@@ -410,11 +402,6 @@ optDescr =
coding x = case lookup x encodings of
Just c -> set $ \o -> o { optEncoding = c }
Nothing -> fail $ "Unknown character encoding: " ++ x
buildParser x = do v <- case x of
"on" -> return BuildParser
"off" -> return DontBuildParser
"ondemand" -> return BuildParserOnDemand
set $ \o -> o { optBuildParser = v }
startcat x = set $ \o -> o { optStartCat = Just x }
language x = set $ \o -> o { optSpeechLanguage = Just x }
lexer x = set $ \o -> o { optLexer = Just x }
@@ -441,7 +428,6 @@ optDescr =
outputFormats :: [(String,OutputFormat)]
outputFormats =
[("pgf_pretty", FmtPGFPretty),
("pmcfg_pretty", FmtPMCFGPretty),
("js", FmtJavaScript),
("haskell", FmtHaskell),
("prolog", FmtProlog),

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

@@ -34,15 +34,15 @@ pgfToCFG :: PGF
-> CFG
pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap fruleToCFRule rules)
where
pinfo = fromMaybe (error "pgfToCFG: No parser.") (lookParser pgf lang)
cnc = lookConcr pgf lang
rules :: [(FCat,Production)]
rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.pproductions pinfo)
rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.pproductions cnc)
, prod <- Set.toList set]
fcatCats :: Map FCat Cat
fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
| (c,(s,e,lbls)) <- Map.toList (startCats pinfo),
| (c,(s,e,lbls)) <- Map.toList (startCats cnc),
(fc,i) <- zip (range (s,e)) [1..]]
fcatCat :: FCat -> Cat
@@ -58,9 +58,9 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
topdownRules cat = f cat []
where
f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (pproductions pinfo))
f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (pproductions cnc))
g (FApply funid args) rules = (functions pinfo ! funid,args) : rules
g (FApply funid args) rules = (functions cnc ! funid,args) : rules
g (FCoerce cat) rules = f cat rules
@@ -69,7 +69,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
startRules :: [CFRule]
startRules = [CFRule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
| (c,(s,e,lbls)) <- Map.toList (startCats pinfo),
| (c,(s,e,lbls)) <- Map.toList (startCats cnc),
fc <- range (s,e), not (isLiteralFCat fc),
r <- [0..catLinArity fc-1]]
@@ -77,10 +77,10 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
fruleToCFRule (c,FApply funid args) =
[CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
| (l,seqid) <- Array.assocs rhs
, let row = sequences pinfo ! seqid
, let row = sequences cnc ! seqid
, not (containsLiterals row)]
where
FFun f rhs = functions pinfo ! funid
FFun f rhs = functions cnc ! funid
mkRhs :: Array FPointPos FSymbol -> [CFSymbol]
mkRhs = concatMap fsymbolToSymbol . Array.elems