mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-06 01:32:50 -06:00
PGF is now real synchronous PMCFG
This commit is contained in:
krasimir
@@ -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
|
||||
|
||||
@@ -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]
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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]
|
||||
@@ -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]
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user