forked from GitHub/gf-core
since now we don't do common subexpression elimination for PGF we could simplify the PMCFG generation
This commit is contained in:
krasimir
@@ -37,11 +37,11 @@ import Control.Exception
|
||||
|
||||
--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
|
||||
let env0 = emptyGrammarEnv cat_defs params
|
||||
when (flag optProf opts) $ do
|
||||
profileGrammar lang cnc_defs env0 pfrules
|
||||
env1 <- expandHOAS opts abs_defs cnc_defs cat_defs lin_defs env0
|
||||
env2 <- foldM (convertRule opts cnc_defs) env1 pfrules
|
||||
profileGrammar lang env0 pfrules
|
||||
env1 <- expandHOAS opts abs_defs cat_defs lin_defs env0
|
||||
env2 <- foldM (convertRule opts) env1 pfrules
|
||||
return $ getParserInfo flags printnames env2
|
||||
where
|
||||
cat_defs = Map.insert cidVar (S []) lincats
|
||||
@@ -53,7 +53,7 @@ convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_
|
||||
|
||||
findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
|
||||
|
||||
profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do
|
||||
profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do
|
||||
hPutStrLn stderr ""
|
||||
hPutStrLn stderr ("Language: " ++ show lang)
|
||||
hPutStrLn stderr ""
|
||||
@@ -73,7 +73,7 @@ profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet pro
|
||||
hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1))
|
||||
|
||||
profileRule (PFRule fun args res ctypes ctype term) = do
|
||||
let pargs = zipWith (protoFCat cnc_defs) args ctypes
|
||||
let pargs = zipWith protoFCat args ctypes
|
||||
hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs]))
|
||||
|
||||
lformat :: Show a => Int -> a -> String
|
||||
@@ -103,12 +103,12 @@ brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
|
||||
count = length xs
|
||||
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
|
||||
|
||||
convertRule :: Options -> TermMap -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
|
||||
convertRule opts cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) = do
|
||||
let pres = protoFCat cnc_defs res ctype
|
||||
pargs = zipWith (protoFCat cnc_defs) args ctypes
|
||||
convertRule :: Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
|
||||
convertRule opts grammarEnv (PFRule fun args res ctypes ctype term) = do
|
||||
let pres = protoFCat res ctype
|
||||
pargs = zipWith protoFCat args ctypes
|
||||
|
||||
b = runBranchM (convertTerm cnc_defs [] ctype term) (pargs,[])
|
||||
b = runBranchM (convertTerm [] ctype term) (pargs,[])
|
||||
(grammarEnv1,b1) = addSequences' grammarEnv b
|
||||
grammarEnv2 = brk (\grammarEnv -> foldBM addRule
|
||||
grammarEnv
|
||||
@@ -185,8 +185,8 @@ data ProtoFRule = PFRule CId {- function -}
|
||||
type TermMap = Map.Map CId Term
|
||||
|
||||
|
||||
protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat
|
||||
protoFCat cnc_defs (n,cat) ctype =
|
||||
protoFCat :: (Int,CId) -> Term -> ProtoFCat
|
||||
protoFCat (n,cat) ctype =
|
||||
let (rcs,tcs) = loop [] [] [] ctype'
|
||||
in PFCat n cat rcs tcs
|
||||
where
|
||||
@@ -199,9 +199,6 @@ protoFCat cnc_defs (n,cat) ctype =
|
||||
loop path rcs tcs (R record) = List.foldr (\(index,term) (rcs,tcs) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record)
|
||||
loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs)
|
||||
loop path rcs tcs (S _) = (path:rcs, tcs)
|
||||
loop path rcs tcs (F id) = case Map.lookup id cnc_defs of
|
||||
Just term -> loop path rcs tcs term
|
||||
Nothing -> error ("unknown identifier: "++show id)
|
||||
|
||||
data Branch a
|
||||
= Case Int FPath [Branch a]
|
||||
@@ -254,29 +251,23 @@ optimizeLin lin@(SymKS _ : _) =
|
||||
optimizeLin (sym : lin) = sym : optimizeLin lin
|
||||
|
||||
|
||||
convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [Symbol])
|
||||
convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel)
|
||||
convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel)
|
||||
convertTerm cnc_defs sel ctype (R record) = convertRec cnc_defs sel ctype record
|
||||
convertTerm cnc_defs sel ctype (P term p) = do nr <- evalTerm cnc_defs [] p
|
||||
convertTerm cnc_defs (nr:sel) ctype term
|
||||
convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars
|
||||
convertTerm cnc_defs sel ctype term
|
||||
convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts
|
||||
return (Str (concat [s | Str s <- vs]))
|
||||
convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [SymKS [t]])
|
||||
convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [SymKP s v])
|
||||
convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of
|
||||
Just term -> convertTerm cnc_defs sel ctype term
|
||||
Nothing -> error ("unknown id " ++ showCId id)
|
||||
convertTerm cnc_defs sel ctype (W s t) = do
|
||||
convertTerm :: FPath -> Term -> Term -> CnvMonad (Value [Symbol])
|
||||
convertTerm sel ctype (V nr) = convertArg ctype nr (reverse sel)
|
||||
convertTerm sel ctype (C nr) = convertCon ctype nr (reverse sel)
|
||||
convertTerm sel ctype (R record) = convertRec sel ctype record
|
||||
convertTerm sel ctype (P term p) = do nr <- evalTerm [] p
|
||||
convertTerm (nr:sel) ctype term
|
||||
convertTerm sel ctype (FV vars) = do term <- variants vars
|
||||
convertTerm sel ctype term
|
||||
convertTerm sel ctype (S ts) = do vs <- mapM (convertTerm sel ctype) ts
|
||||
return (Str (concat [s | Str s <- vs]))
|
||||
convertTerm sel ctype (K (KS t)) = return (Str [SymKS [t]])
|
||||
convertTerm sel ctype (K (KP s v))=return (Str [SymKP s v])
|
||||
convertTerm sel ctype (W s t) = do
|
||||
ss <- case t of
|
||||
R ss -> return ss
|
||||
F f -> case Map.lookup f cnc_defs of
|
||||
Just (R ss) -> return ss
|
||||
_ -> error ("unknown id " ++ showCId f)
|
||||
convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss]
|
||||
convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")")
|
||||
convertRec sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss]
|
||||
convertTerm sel ctype x = error ("convertTerm ("++show x++")")
|
||||
|
||||
convertArg :: Term -> Int -> FPath -> CnvMonad (Value [Symbol])
|
||||
convertArg (R ctypes) nr path = do
|
||||
@@ -299,27 +290,24 @@ convertArg (S _) nr path = do
|
||||
convertCon (C max) index [] = return (Con index)
|
||||
convertCon x _ _ = fail $ "SimpleToFCFG.convertCon: " ++ show x
|
||||
|
||||
convertRec cnc_defs [] (R ctypes) record = do
|
||||
mkRecord (zipWith (convertTerm cnc_defs []) ctypes record)
|
||||
convertRec cnc_defs (index:sub_sel) ctype record =
|
||||
convertTerm cnc_defs sub_sel ctype (record !! index)
|
||||
convertRec [] (R ctypes) record = do
|
||||
mkRecord (zipWith (convertTerm []) ctypes record)
|
||||
convertRec (index:sub_sel) ctype record =
|
||||
convertTerm sub_sel ctype (record !! index)
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- eval a term to ground terms
|
||||
|
||||
evalTerm :: TermMap -> FPath -> Term -> CnvMonad LIndex
|
||||
evalTerm cnc_defs path (V nr) = choices nr (reverse path)
|
||||
evalTerm cnc_defs path (C nr) = return nr
|
||||
evalTerm cnc_defs path (R record) = case path of
|
||||
(index:path) -> evalTerm cnc_defs path (record !! index)
|
||||
evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
|
||||
evalTerm cnc_defs (index:path) term
|
||||
evalTerm cnc_defs path (FV terms) = variants terms >>= evalTerm cnc_defs path
|
||||
evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of
|
||||
Just term -> evalTerm cnc_defs path term
|
||||
Nothing -> error ("unknown id " ++ showCId id)
|
||||
evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
|
||||
evalTerm :: FPath -> Term -> CnvMonad LIndex
|
||||
evalTerm path (V nr) = choices nr (reverse path)
|
||||
evalTerm path (C nr) = return nr
|
||||
evalTerm path (R record) = case path of
|
||||
(index:path) -> evalTerm path (record !! index)
|
||||
evalTerm path (P term sel) = do index <- evalTerm [] sel
|
||||
evalTerm (index:path) term
|
||||
evalTerm path (FV terms) = variants terms >>= evalTerm path
|
||||
evalTerm path x = error ("evalTerm ("++show x++")")
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@@ -331,7 +319,7 @@ type SeqSet = Map.Map Sequence SeqId
|
||||
type FunSet = Map.Map CncFun FunId
|
||||
type CoerceSet= Map.Map [FId] FId
|
||||
|
||||
emptyGrammarEnv cnc_defs lincats params =
|
||||
emptyGrammarEnv lincats params =
|
||||
let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
|
||||
in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty
|
||||
where
|
||||
@@ -347,9 +335,6 @@ emptyGrammarEnv cnc_defs lincats params =
|
||||
getMultipliers m ms (R record) = foldr (\t (m,ms) -> getMultipliers m ms t) (m,ms) record
|
||||
getMultipliers m ms (S _) = (m,ms)
|
||||
getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms)
|
||||
getMultipliers m ms (F id) = case Map.lookup id cnc_defs of
|
||||
Just term -> getMultipliers m ms term
|
||||
Nothing -> error ("unknown identifier: "++showCId id)
|
||||
|
||||
getLabels ls (R record) = concat [getLabels (l:ls) t | P (K (KS l)) t <- record]
|
||||
getLabels ls (S [FV ps,t]) = concat [getLabels (l:ls) t | K (KS l) <- ps]
|
||||
@@ -357,7 +342,7 @@ emptyGrammarEnv cnc_defs lincats params =
|
||||
getLabels ls (FV _) = []
|
||||
getLabels _ t = error (show t)
|
||||
|
||||
expandHOAS opts abs_defs cnc_defs lincats lindefs env =
|
||||
expandHOAS opts abs_defs lincats lindefs env =
|
||||
foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats)
|
||||
where
|
||||
hoTypes :: [(Int,CId)]
|
||||
@@ -388,13 +373,13 @@ expandHOAS opts abs_defs cnc_defs lincats lindefs env =
|
||||
where
|
||||
(arg,res) = case Map.lookup cat lincats of
|
||||
Nothing -> error $ "No lincat for " ++ showCId cat
|
||||
Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype)
|
||||
Just ctype -> (protoFCat (0,cat) ctype, protoFCat (n,cat) ctype)
|
||||
|
||||
-- add one PMCFG function for each high-order category: _V : Var -> Cat
|
||||
add_varFun env cat =
|
||||
case Map.lookup cat lindefs of
|
||||
Nothing -> return env
|
||||
Just lindef -> convertRule opts cnc_defs env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef)
|
||||
Just lindef -> convertRule opts env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef)
|
||||
where
|
||||
arg =
|
||||
case Map.lookup cidVar lincats of
|
||||
|
||||
@@ -57,30 +57,6 @@ concrete2js (c,cnc) =
|
||||
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
|
||||
cats (c,CncCat 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)])
|
||||
|
||||
term2js :: String -> String -> Term -> JS.Expr
|
||||
term2js n l t = f t
|
||||
where
|
||||
f t =
|
||||
case t of
|
||||
R xs -> new "Arr" (map f xs)
|
||||
P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
|
||||
S xs -> mkSeq (map f xs)
|
||||
K t -> tokn2js t
|
||||
V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
|
||||
C i -> new "Int" [JS.EInt i]
|
||||
F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (showCId f), JS.EVar children]
|
||||
FV xs -> new "Variants" (map f xs)
|
||||
W str x -> new "Suffix" [JS.EStr str, f x]
|
||||
TM _ -> new "Meta" []
|
||||
|
||||
tokn2js :: Tokn -> JS.Expr
|
||||
tokn2js (KS s) = mkStr s
|
||||
tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME
|
||||
|
||||
mkStr :: String -> JS.Expr
|
||||
mkStr s = new "Str" [JS.EStr s]
|
||||
|
||||
|
||||
@@ -116,32 +116,6 @@ instance PLPrint Patt where
|
||||
instance PLPrint Equation where
|
||||
plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
|
||||
|
||||
instance PLPrint Term where
|
||||
plp (S terms) = plTerm "s" [plp terms]
|
||||
plp (C n) = plTerm "c" [show n]
|
||||
plp (K tokn) = plTerm "k" [plp tokn]
|
||||
plp (FV trms) = plTerm "fv" [plp trms]
|
||||
plp (P t1 t2) = plTerm "p" [plp t1, plp t2]
|
||||
plp (W s trm) = plTerm "w" [plp s, plp trm]
|
||||
plp (R terms) = plTerm "r" [plp terms]
|
||||
plp (F oper) = plTerm "f" [plp oper]
|
||||
plp (V n) = plTerm "v" [show n]
|
||||
plp (TM str) = plTerm "tm" [plp str]
|
||||
|
||||
{-- more prolog-like syntax for PGF terms, but also more difficult to handle:
|
||||
instance PLPrint Term where
|
||||
plp (S terms) = plp terms
|
||||
plp (C n) = show n
|
||||
plp (K token) = plp token
|
||||
plp (FV terms) = prCurlyList (map plp terms)
|
||||
plp (P t1 t2) = plOper "/" (plp t1) (plp t2)
|
||||
plp (W s trm) = plOper "+" (plp s) (plp trm)
|
||||
plp (R terms) = plTerm "r" (map plp terms)
|
||||
plp (F oper) = plTerm "f" [plp oper]
|
||||
plp (V n) = plTerm "arg" [show n]
|
||||
plp (TM str) = plTerm "meta" [plp str]
|
||||
--}
|
||||
|
||||
instance PLPrint CId where
|
||||
plp cid | isLogicalVariable str ||
|
||||
cid == wildCId = plVar str
|
||||
|
||||
@@ -72,34 +72,6 @@ instance Binary Alternative where
|
||||
put (Alt v x) = put (v,x)
|
||||
get = liftM2 Alt get get
|
||||
|
||||
instance Binary Term where
|
||||
put (R es) = putWord8 0 >> put es
|
||||
put (S es) = putWord8 1 >> put es
|
||||
put (FV es) = putWord8 2 >> put es
|
||||
put (P e v) = putWord8 3 >> put (e,v)
|
||||
put (W e v) = putWord8 4 >> put (e,v)
|
||||
put (C i ) = putWord8 5 >> put i
|
||||
put (TM i ) = putWord8 6 >> put i
|
||||
put (F f) = putWord8 7 >> put f
|
||||
put (V i) = putWord8 8 >> put i
|
||||
put (K (KS s)) = putWord8 9 >> put s
|
||||
put (K (KP d vs)) = putWord8 10 >> put (d,vs)
|
||||
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM R get
|
||||
1 -> liftM S get
|
||||
2 -> liftM FV get
|
||||
3 -> liftM2 P get get
|
||||
4 -> liftM2 W get get
|
||||
5 -> liftM C get
|
||||
6 -> liftM TM get
|
||||
7 -> liftM F get
|
||||
8 -> liftM V get
|
||||
9 -> liftM (K . KS) get
|
||||
10 -> liftM2 (\d vs -> K (KP d vs)) get get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Expr where
|
||||
put (EAbs b x exp) = putWord8 0 >> put (b,x,exp)
|
||||
put (EApp e1 e2) = putWord8 1 >> put (e1,e2)
|
||||
|
||||
@@ -137,14 +137,6 @@ lintype pgf lang fun = case typeSkeleton (lookFun pgf fun) of
|
||||
vlinc (i,c) = case linc c of
|
||||
R ts -> R (ts ++ replicate i str)
|
||||
|
||||
inline :: PGFSig -> CId -> Term -> Term
|
||||
inline pgf lang t = case t of
|
||||
F c -> inl $ look c
|
||||
_ -> composSafeOp inl t
|
||||
where
|
||||
inl = inline pgf lang
|
||||
look = lookLin pgf lang
|
||||
|
||||
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
|
||||
composOp f trm = case trm of
|
||||
R ts -> liftM R $ mapM f ts
|
||||
|
||||
@@ -75,7 +75,6 @@ data Term =
|
||||
| K Tokn
|
||||
| V Int
|
||||
| C Int
|
||||
| F CId
|
||||
| FV [Term]
|
||||
| W String Term
|
||||
| TM String
|
||||
|
||||
Reference in New Issue
Block a user