GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

Some performance optimizations

Browse Source
This commit is contained in:
kr.angelov
2006-06-21 13:40:59 +00:00
parent fe0903a2e1
commit abe5b1f50f
1 changed files with 17 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
src/GF/Conversion/SimpleToFCFG.hs
View File

@@ -43,22 +43,21 @@ import Data.Array
convertGrammar :: SGrammar -> FGrammar convertGrammar :: SGrammar -> FGrammar
convertGrammar srules = getFRules (loop frulesEnv) convertGrammar srules = getFRules (loop frulesEnv)
where where
(srulesMap,frulesEnv) = foldl helper (Map.empty,emptyFRulesEnv) srules (srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules
where where
helper (srulesMap,frulesEnv) rule@(Rule (Abs decl _ _) (Cnc ctype _ _)) = helper (srulesMap,frulesEnv) rule@(Rule (Abs decl _ _) (Cnc ctype _ _)) =
( Map.insertWith (++) (decl2cat decl) [rule] srulesMap let srulesMap' = Map.insertWith (++) (decl2cat decl) [rule] srulesMap
, foldBM (\selector _ env -> convertRule selector rule env) frulesEnv' = List.foldl' (\env selector -> convertRule selector rule env)
frulesEnv frulesEnv
(mkSingletonSelector ctype) (mkSingletonSelectors ctype)
() in srulesMap' `seq` frulesEnv' `seq` (srulesMap',frulesEnv')
)
loop frulesEnv =
loop frulesEnv =
let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv
in case todo of in case todo of
[] -> frulesEnv' [] -> frulesEnv'
_ -> loop $! foldl (\env (srules,selector) -> _ -> loop $! List.foldl' (\env (srules,selector) ->
foldl (\env srule -> convertRule selector srule env) env srules) frulesEnv' todo List.foldl' (\env srule -> convertRule selector srule env) env srules) frulesEnv' todo
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -355,23 +354,21 @@ data STermSelector
| ConSel [STerm] | ConSel [STerm]
| StrSel | StrSel
mkSingletonSelectors :: SLinType -> [STermSelector]
mkSingletonSelector :: SLinType -> BacktrackM () STermSelector mkSingletonSelectors ctype =
mkSingletonSelector ctype = do
let (rcss,tcss) = loop emptyPath ([],[]) ctype let (rcss,tcss) = loop emptyPath ([],[]) ctype
rcs <- member rcss in [mkSelector [rcs] tcss | rcs <- rcss]
return (mkSelector [rcs] tcss)
where where
loop path st (RecT record) = foldl (\st (lbl,ctype) -> loop (path ++. lbl ) st ctype) st record loop path st (RecT record) = List.foldl' (\st (lbl,ctype) -> loop (path ++. lbl ) st ctype) st record
loop path st (TblT terms ctype) = foldl (\st term -> loop (path ++! term) st ctype) st terms loop path st (TblT terms ctype) = List.foldl' (\st term -> loop (path ++! term) st ctype) st terms
loop path (rcss,tcss) (ConT terms) = (rcss, map ((,) path) terms : tcss) loop path (rcss,tcss) (ConT terms) = (rcss, map ((,) path) terms : tcss)
loop path (rcss,tcss) (StrT) = (path : rcss, tcss) loop path (rcss,tcss) (StrT) = (path : rcss, tcss)
mkSelector :: [SPath] -> [[(SPath,STerm)]] -> STermSelector mkSelector :: [SPath] -> [[(SPath,STerm)]] -> STermSelector
mkSelector rcs tcss = mkSelector rcs tcss =
foldl addRestriction (case xs of List.foldl' addRestriction (case xs of
(path:xs) -> foldl addProjection (path2selector StrSel path) xs) ys (path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys
where where
xs = [ reverse path | Path path <- rcs] xs = [ reverse path | Path path <- rcs]
ys = [(reverse path,term) | tcs <- tcss, (Path path,term) <- tcs] ys = [(reverse path,term) | tcs <- tcss, (Path path,term) <- tcs]