GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-14 21:52:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

in verbose mode print the rule names when compiling PMCFG

Browse Source
This commit is contained in:
krasimir
2010-02-06 18:24:15 +00:00
parent 168d459c49
commit 2544ea8c8a
1 changed files with 10 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -40,8 +40,8 @@ convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_
let env0 = emptyGrammarEnv cnc_defs cat_defs params let env0 = emptyGrammarEnv cnc_defs cat_defs params
when (flag optProf opts) $ do when (flag optProf opts) $ do
profileGrammar lang cnc_defs env0 pfrules profileGrammar lang cnc_defs env0 pfrules
let env1 = expandHOAS abs_defs cnc_defs cat_defs lin_defs env0 env1 <- expandHOAS opts abs_defs cnc_defs cat_defs lin_defs env0
env2 = List.foldl' (convertRule cnc_defs) env1 pfrules env2 <- foldM (convertRule opts cnc_defs) env1 pfrules
return $ getParserInfo flags printnames env2 return $ getParserInfo flags printnames env2
where where
cat_defs = Map.insert cidVar (S []) lincats cat_defs = Map.insert cidVar (S []) lincats
@@ -103,8 +103,8 @@ brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
count = length xs count = length xs
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
convertRule :: TermMap -> GrammarEnv -> ProtoFRule -> GrammarEnv convertRule :: Options -> TermMap -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
convertRule cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) = convertRule opts cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) = do
let pres = protoFCat cnc_defs res ctype let pres = protoFCat cnc_defs res ctype
pargs = zipWith (protoFCat cnc_defs) args ctypes pargs = zipWith (protoFCat cnc_defs) args ctypes
@@ -114,7 +114,8 @@ convertRule cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) =
grammarEnv grammarEnv
(go' b1 [] []) (go' b1 [] [])
(pres,pargs) ) grammarEnv1 (pres,pargs) ) grammarEnv1
in grammarEnv2 when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId fun)
return $! grammarEnv2
where where
addRule lins (newCat', newArgs') env0 = addRule lins (newCat', newArgs') env0 =
let [newCat] = getFCats env0 newCat' let [newCat] = getFCats env0 newCat'
@@ -356,8 +357,8 @@ emptyGrammarEnv cnc_defs lincats params =
getLabels ls (FV _) = [] getLabels ls (FV _) = []
getLabels _ t = error (show t) getLabels _ t = error (show t)
expandHOAS abs_defs cnc_defs lincats lindefs env = expandHOAS opts 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) foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats)
where where
hoTypes :: [(Int,CId)] hoTypes :: [(Int,CId)]
hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- Map.toList abs_defs hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- Map.toList abs_defs
@@ -392,8 +393,8 @@ expandHOAS abs_defs cnc_defs lincats lindefs env =
-- add one PMCFG function for each high-order category: _V : Var -> Cat -- add one PMCFG function for each high-order category: _V : Var -> Cat
add_varFun env cat = add_varFun env cat =
case Map.lookup cat lindefs of case Map.lookup cat lindefs of
Nothing -> env Nothing -> return env
Just lindef -> convertRule cnc_defs env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef) Just lindef -> convertRule opts cnc_defs env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef)
where where
arg = arg =
case Map.lookup cidVar lincats of case Map.lookup cidVar lincats of