diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Devel/GFC.hs | 2 | ||||
| -rw-r--r-- | src/GF/Devel/GrammarToGFCC.hs | 81 |
2 files changed, 44 insertions, 39 deletions
diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index da5725d3d..f6753e31f 100644 --- a/src/GF/Devel/GFC.hs +++ b/src/GF/Devel/GFC.hs @@ -17,7 +17,7 @@ main = do _ | oElem (iOpt "-make") opts -> do gr <- batchCompile opts fs let name = justModuleName (last fs) - let (abs,gc) = prGrammar2gfcc name gr + let (abs,gc) = prGrammar2gfcc opts name gr let target = abs ++ ".gfcc" writeFile target gc putStrLn $ "wrote file " ++ target diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index a1df8426e..38811f80d 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -12,6 +12,7 @@ import qualified GF.Infra.Option as O import GF.Devel.ModDeps import GF.Infra.Ident +import GF.Infra.Option import GF.Data.Operations import GF.Text.UTF8 @@ -22,31 +23,28 @@ import Debug.Trace ---- -- the main function: generate GFCC from GF. -prGrammar2gfcc :: String -> SourceGrammar -> (String,String) -prGrammar2gfcc cnc gr = (abs, Pr.printTree gc) where - (abs,gc) = mkCanon2gfcc cnc gr +prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String) +prGrammar2gfcc opts cnc gr = (abs, Pr.printTree gc) where + (abs,gc) = mkCanon2gfcc opts cnc gr -mkCanon2gfcc :: String -> SourceGrammar -> (String,C.Grammar) -mkCanon2gfcc cnc gr = - (prIdent abs, (canon2gfcc . reorder abs . utf8Conv . canon2canon abs) gr) +mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,C.Grammar) +mkCanon2gfcc opts cnc gr = + (prIdent abs, (canon2gfcc opts . reorder abs . utf8Conv . canon2canon abs) gr) where abs = err error id $ M.abstractOfConcrete gr (identC cnc) --- This is needed to reorganize the grammar. GFCC has its own back-end optimization. --- But we need to have the canonical order in tables, created by valOpt - -- Generate GFCC from GFCM. -- this assumes a grammar translated by canon2canon -canon2gfcc :: SourceGrammar -> C.Grammar -canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = +canon2gfcc :: Options -> SourceGrammar -> C.Grammar +canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where cs = map (i2i . fst) cms adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) | (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f] cncs = [C.Cnc (i2i lang) (concr m) | (lang,M.ModMod m) <- cms] concr mo = cats mo ++ lindefs mo ++ - optConcrete + (if oElem (iOpt "noopt") opts then id else optConcrete) [C.Lin (i2i f) (mkTerm tr) | (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)] cats mo = [C.Lin (i2ic c) (mkCType ty) | @@ -163,7 +161,7 @@ canon2canon :: Ident -> SourceGrammar -> SourceGrammar canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs where recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules - cl2cl cg = M.MGrammar $ map c2c $ M.modules cg where + cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where c2c (c,m) = case m of M.ModMod mo@(M.Module _ _ _ _ _ js) -> (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js) @@ -176,11 +174,12 @@ canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs whe ty2ty = type2type cg pv pv@(labels,untyps,typs) = paramValues cg tr = trace $ - (unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | + ("labels:" ++++ + unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | ((c,l),i) <- Map.toList labels]) ++ - (unlines [A.prt t +++ "=" +++ show i | + ("untyps:" ++++ unlines [A.prt t +++ "=" +++ show i | (t,i) <- Map.toList untyps]) ++ - (unlines [A.prt t | + ("typs:" ++++ unlines [A.prt t | (t,_) <- Map.toList typs]) @@ -270,12 +269,14 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of QC _ _ -> mkValCase tr R rs -> let + tr' = R [(l, (Nothing,t)) | + (l,(_,t)) <- unlock rs] rs' = [(mkLab i, (Nothing, t2t t)) | (i,(l,(_,t))) <- zip [0..] (unlock rs)] in if (any (isStr . trmAss) rs) then R rs' --- else mkValCase tr - else R [(LIdent "_", (Nothing, mkValCase tr))] + else R [(LIdent "_", (Nothing, mkValCase tr'))] --- else R [(LIdent "_", (Nothing, mkValCase tr)), (LIdent "__",(Nothing,R rs'))] P t l -> r2r tr PI t l i -> EInt $ toInteger i @@ -290,23 +291,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of where t2t = term2term cgr env - r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v - - r2r tr@(P p _) = case getLab tr of - Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,labs) labels - _ -> K ((A.prt tr +++ prtTrace tr "66665")) - - -- this goes recursively into tables (ignored) and records (accumulated) - getLab tr = case tr of - Vr (IA (cat, _)) -> return (identC cat,[]) - Vr (IC s) -> return (identC cat,[]) where - cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser - P p lab2 -> do - (cat,labs) <- getLab p - return (cat,labs++[lab2]) - S p _ -> getLab p - _ -> Bad "getLab" + mkValCase tr = case appSTM (doVar tr) [] of + Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st + _ -> valNum tr doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term doVar tr = case getLab tr of @@ -325,9 +312,26 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of return tr' _ -> GM.composOp doVar tr - mkValCase tr = case appSTM (doVar tr) [] of - Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st - _ -> valNum tr + + + r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v + + r2r tr@(P p _) = case getLab tr of + Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ + Map.lookup (cat,labs) labels + _ -> K ((A.prt tr +++ prtTrace tr "66665")) + + -- this goes recursively into tables (ignored) and records (accumulated) + getLab tr = case tr of + Vr (IA (cat, _)) -> return (identC cat,[]) + Vr (IC s) -> return (identC cat,[]) where + cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser + P p lab2 -> do + (cat,labs) <- getLab p + return (cat,labs++[lab2]) + S p _ -> getLab p + _ -> Bad "getLab" + mkCase ((ty,vs),(x,p)) tr = S (V ty [mkBranch x v tr | v <- vs]) p @@ -351,11 +355,12 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of _ -> FV $ map valNum ts isStr tr = case tr of App _ _ -> False + QC _ _ -> False EInt _ -> False R rs -> any (isStr . trmAss) rs FV ts -> any isStr ts S t _ -> isStr t - Empty -> True + Empty -> True T _ cs -> any isStr [v | (_, v) <- cs] V _ ts -> any isStr ts P t r -> case getLab tr of |