summaryrefslogtreecommitdiff
path: root/src/compiler/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF')
-rw-r--r--src/compiler/GF/Command/Commands.hs32
-rw-r--r--src/compiler/GF/Compile.hs36
-rw-r--r--src/compiler/GF/Compile/Export.hs6
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs38
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs37
-rw-r--r--src/compiler/GF/Compile/OptimizePGF.hs118
-rw-r--r--src/compiler/GF/Compile/PGFPretty.hs94
-rw-r--r--src/compiler/GF/Compile/PGFtoJS.hs30
-rw-r--r--src/compiler/GF/Compile/PGFtoProlog.hs13
-rw-r--r--src/compiler/GF/Infra/Option.hs16
-rw-r--r--src/compiler/GF/Speech/PGFToCFG.hs16
11 files changed, 84 insertions, 352 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index addf9b94a..f537099f8 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -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 = ([],[])
diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index cef7b235a..f6d346320 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -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
diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs
index 29f35e32a..463a48aa6 100644
--- a/src/compiler/GF/Compile/Export.hs
+++ b/src/compiler/GF/Compile/Export.hs
@@ -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
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index e6e3fdc79..27426203f 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -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]
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index 31c768045..d272404e3 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -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
diff --git a/src/compiler/GF/Compile/OptimizePGF.hs b/src/compiler/GF/Compile/OptimizePGF.hs
deleted file mode 100644
index 4ef8ce5cf..000000000
--- a/src/compiler/GF/Compile/OptimizePGF.hs
+++ /dev/null
@@ -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)
-
diff --git a/src/compiler/GF/Compile/PGFPretty.hs b/src/compiler/GF/Compile/PGFPretty.hs
deleted file mode 100644
index 706081999..000000000
--- a/src/compiler/GF/Compile/PGFPretty.hs
+++ /dev/null
@@ -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] \ No newline at end of file
diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs
index 67d18809a..1f6d083a2 100644
--- a/src/compiler/GF/Compile/PGFtoJS.hs
+++ b/src/compiler/GF/Compile/PGFtoJS.hs
@@ -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]
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 538430747..9effbec70 100644
--- a/src/compiler/GF/Compile/PGFtoProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoProlog.hs
@@ -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
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index dba40cbf3..34cc383dc 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -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),
diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs
index 4ac430704..4332e21b8 100644
--- a/src/compiler/GF/Speech/PGFToCFG.hs
+++ b/src/compiler/GF/Speech/PGFToCFG.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:54:16 +0000