diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs index 280094023..1262505a1 100644 --- a/src/GF/Canon/CanonToGFCC.hs +++ b/src/GF/Canon/CanonToGFCC.hs @@ -19,8 +19,12 @@ import GF.Canon.AbsGFC import qualified GF.Canon.GFC as GFC import qualified GF.Canon.Look as Look import qualified GF.Canon.Subexpressions as Sub -import qualified GF.Canon.GFCC.AbsGFCC as C -import qualified GF.Canon.GFCC.PrintGFCC as Pr + +import qualified GF.GFCC.Macros as CM +import qualified GF.GFCC.AbsGFCC as C +import qualified GF.GFCC.DataGFCC as D +import GF.GFCC.OptimizeGFCC + import GF.Canon.GFC import GF.Canon.Share import qualified GF.Grammar.Abstract as A @@ -42,56 +46,71 @@ import Debug.Trace ---- -- the main function: generate GFCC from GFCM. prCanon2gfcc :: CanonGrammar -> String -prCanon2gfcc = Pr.printTree . mkCanon2gfcc +prCanon2gfcc = D.printGFCC . mkCanon2gfcc -- this variant makes utf8 conversion; used in back ends -mkCanon2gfcc :: CanonGrammar -> C.Grammar -mkCanon2gfcc = canon2gfcc . reorder . utf8Conv . canon2canon . normalize +mkCanon2gfcc :: CanonGrammar -> D.GFCC +mkCanon2gfcc = +-- canon2gfcc . reorder abs . utf8Conv . canon2canon abs + optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize -- this variant makes no utf8 conversion; used in ShellState -mkCanon2gfccNoUTF8 :: CanonGrammar -> C.Grammar -mkCanon2gfccNoUTF8 = canon2gfcc . reorder . canon2canon . normalize +mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC +mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize --- This is needed to reorganize the grammar. GFCC has its own back-end optimization. +-- 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 normalize :: CanonGrammar -> CanonGrammar normalize = share . unoptimizeCanon . Sub.unSubelimCanon where share = M.MGrammar . map (shareModule valOpt) . M.modules --- allOpt -- Generate GFCC from GFCM. --- this assumes a grammar translated by canon2canon +-- this assumes a grammar normalized and transformed by canon2canon -canon2gfcc :: CanonGrammar -> C.Grammar +canon2gfcc :: CanonGrammar -> D.GFCC canon2gfcc 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,GFC.AbsFun 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 - [C.Lin (i2i f) (mkTerm tr) | - (f,GFC.CncFun _ _ tr _) <- tree2list (M.jments mo)] - cats mo = [C.Lin (i2ic c) (mkCType ty) | - (c,GFC.CncCat ty _ _) <- tree2list (M.jments mo)] - lindefs mo = [C.Lin (i2id c) (mkTerm tr) | - (c,GFC.CncCat _ tr _) <- tree2list (M.jments mo)] + D.GFCC an cns abs cncs + where + an = (i2i a) + cns = map (i2i . fst) cms + abs = D.Abstr aflags funs cats catfuns + aflags = Map.fromAscList [] ---- flags + lfuns = [(f', (mkType ty,CM.primNotion)) | ---- defs + (f,GFC.AbsFun ty _) <- tree2list (M.jments abm), let f' = i2i f] + funs = Map.fromAscList lfuns + lcats = [(i2i c,[]) | ---- context + (c,GFC.AbsCat _ _) <- tree2list (M.jments abm)] + cats = Map.fromAscList lcats + catfuns = Map.fromAscList + [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] + + cncs = Map.fromList [mkConcr (i2i lang) mo | (lang,M.ModMod mo) <- cms] + mkConcr lang mo = (lang,D.Concr flags lins opers lincats lindefs printnames) + where + flags = Map.fromAscList [] ---- flags + opers = Map.fromAscList [] -- opers will be created as optimization + lins = Map.fromAscList + [(i2i f, mkTerm tr) | (f,GFC.CncFun _ _ tr _) <- tree2list (M.jments mo)] + lincats = Map.fromAscList + [(i2i c, mkCType ty) | (c,GFC.CncCat ty _ _) <- tree2list (M.jments mo)] + lindefs = Map.fromAscList + [(i2i c, mkTerm tr) | (c,GFC.CncCat _ tr _) <- tree2list (M.jments mo)] + printnames = Map.fromAscList [] ---- printnames i2i :: Ident -> C.CId i2i (IC c) = C.CId c -i2ic (IC c) = C.CId ("__" ++ c) -- for lincat of category symbols -i2id (IC c) = C.CId ("_d" ++ c) -- for lindef of category symbols mkType :: A.Type -> C.Type mkType t = case GM.catSkeleton t of - Ok (cs,c) -> C.Typ (map (i2i . snd) cs) (i2i $ snd c) + Ok (cs,c) -> CM.cftype (map (i2i . snd) cs) (i2i $ snd c) mkCType :: CType -> C.Term mkCType t = case t of TInts i -> C.C $ fromInteger i -- record parameter alias - created in gfc preprocessing RecType [Lbg (L (IC "_")) i, Lbg (L (IC "__")) t] -> C.RP (mkCType i) (mkCType t) - RecType rs -> C.R [mkCType t | Lbg _ t <- rs] + RecType rs -> C.R [mkCType t | Lbg _ t <- rs] Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt TStr -> C.S [] where @@ -109,9 +128,6 @@ mkTerm tr = case tr of R rs -> C.R [mkTerm t | Ass _ t <- rs] P t l -> C.P (mkTerm t) (C.C (mkLab l)) - LI x -> C.BV $ i2i x - T _ [Cas [PV x] t] -> C.L (i2i x) (mkTerm t) - T _ cs -> error $ "improper optimization for gfcc in" +++ A.prt tr V _ cs -> C.R [mkTerm t | t <- cs] S t p -> C.P (mkTerm t) (mkTerm p) @@ -401,102 +417,3 @@ unlockTyp = filter notlock where prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n --- back-end optimization: --- suffix analysis followed by common subexpression elimination - -optConcrete :: [C.CncDef] -> [C.CncDef] -optConcrete defs = subex - [C.Lin f (optTerm t) | C.Lin f t <- defs] - --- analyse word form lists into prefix + suffixes --- suffix sets can later be shared by subex elim - -optTerm :: C.Term -> C.Term -optTerm tr = case tr of - C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts] - C.R ts -> C.R $ map optTerm ts - C.P t v -> C.P (optTerm t) v - C.L x t -> C.L x (optTerm t) - _ -> 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 - C.K (C.KS _) -> True - _ -> False - mkSuff ("":ws) = C.R (map (C.K . C.KS) ws) - mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws)) - - --- common subexpression elimination; see ./Subexpression.hs for the idea - -subex :: [C.CncDef] -> [C.CncDef] -subex js = errVal js $ do - (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0) - return $ addSubexpConsts tree js - -type TermList = Map.Map C.Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef] -addSubexpConsts tree lins = - let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g) - [C.Lin (fid id) trm | (trm,(_,id)) <- list] - in map mkOne $ opers ++ lins - where - mkOne (C.Lin f trm) = (C.Lin f (recomp f trm)) - recomp f t = case Map.lookup t tree of - Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself - _ -> case t of - C.R ts -> C.R $ map (recomp f) ts - C.S ts -> C.S $ map (recomp f) ts - C.W s t -> C.W s (recomp f t) - C.P t p -> C.P (recomp f t) (recomp f p) - C.RP t p -> C.RP (recomp f t) (recomp f p) - C.L x t -> C.L x (recomp f t) - _ -> t - fid n = C.CId $ "_" ++ show n - list = Map.toList tree - -getSubtermsMod :: [C.CncDef] -> TermM TermList -getSubtermsMod js = do - mapM (getInfo collectSubterms) js - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getInfo get (C.Lin f trm) = do - get trm - return () - -collectSubterms :: C.Term -> TermM () -collectSubterms t = case t of - C.R ts -> do - mapM collectSubterms ts - add t - C.RP u v -> do - collectSubterms v - add t - C.S ts -> do - mapM collectSubterms ts - add t - C.W s u -> do - collectSubterms u - add t - C.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) - diff --git a/src/GF/Canon/CanonToJS.hs b/src/GF/Canon/CanonToJS.hs index 6280b870e..47d900c9d 100644 --- a/src/GF/Canon/CanonToJS.hs +++ b/src/GF/Canon/CanonToJS.hs @@ -5,13 +5,16 @@ import GF.Canon.CanonToGFCC import GF.Canon.Look import GF.Data.ErrM import GF.Infra.Option -import qualified GF.Canon.GFCC.AbsGFCC as C +import qualified GF.GFCC.Macros as M +import qualified GF.GFCC.DataGFCC as D +import qualified GF.GFCC.AbsGFCC as C import qualified GF.JavaScript.AbsJS as JS import qualified GF.JavaScript.PrintJS as JS import Control.Monad (mplus) import Data.Maybe (fromMaybe) +import qualified Data.Map as Map prCanon2js :: Options -> CanonGrammar -> String prCanon2js opts gr = gfcc2js start $ mkCanon2gfcc gr @@ -20,29 +23,37 @@ prCanon2js opts gr = gfcc2js start $ mkCanon2gfcc gr `mplus` getOptVal grOpts gStartCat) grOpts = errVal noOptions $ lookupOptionsCan gr -gfcc2js :: String -> C.Grammar -> String -gfcc2js start (C.Grm (C.Hdr n _) as cs) = - JS.printTree $ JS.Program $ abstract2js start n as ++ concatMap (concrete2js n) cs +gfcc2js :: String -> D.GFCC -> String +gfcc2js start gfcc = + JS.printTree $ JS.Program $ abstract2js start n as ++ + concatMap (concrete2js n) cs + where + n = D.absname gfcc + as = D.abstract gfcc + cs = Map.assocs (D.concretes gfcc) -abstract2js :: String -> C.CId -> C.Abstract -> [JS.Element] -abstract2js start (C.CId n) (C.Abs ds) = +abstract2js :: String -> C.CId -> D.Abstr -> [JS.Element] +abstract2js start (C.CId n) ds = [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]] - ++ concatMap (absdef2js a) ds + ++ concatMap (absdef2js a) (Map.assocs (D.funs ds)) where a = JS.Ident n -absdef2js :: JS.Ident -> C.AbsDef -> [JS.Element] -absdef2js a (C.Fun (C.CId f) (C.Typ args (C.CId cat)) _) = +absdef2js :: JS.Ident -> (C.CId,(C.Type,C.Exp)) -> [JS.Element] +absdef2js a (C.CId f,(typ,_)) = + let (args,C.CId cat) = M.catSkeleton typ in [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType")) [JS.EStr f, JS.EArray [JS.EStr x | C.CId x <- args], JS.EStr cat]] -concrete2js :: C.CId -> C.Concrete -> [JS.Element] -concrete2js (C.CId a) (C.Cnc (C.CId c) ds) = +concrete2js :: C.CId -> (C.CId,D.Concr) -> [JS.Element] +concrete2js (C.CId a) (C.CId c, cnc) = [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]] ++ concatMap (cncdef2js l) ds - where l = JS.Ident c + where + l = JS.Ident c + ds = Map.assocs $ D.lins cnc -cncdef2js :: JS.Ident -> C.CncDef -> [JS.Element] -cncdef2js l (C.Lin (C.CId f) t) = +cncdef2js :: JS.Ident -> (C.CId,C.Term) -> [JS.Element] +cncdef2js l (C.CId f, t) = [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]] term2js :: JS.Ident -> C.Term -> JS.Expr diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index 9746c011e..afc3d61f9 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -17,8 +17,8 @@ module GF.Compile.ShellState where import GF.Data.Operations import GF.Canon.GFC import GF.Canon.AbsGFC -import GF.Canon.GFCC.AbsGFCC(CId(CId)) -import GF.Canon.GFCC.DataGFCC(mkGFCC) +import GF.GFCC.AbsGFCC(CId(CId)) +--import GF.GFCC.DataGFCC(mkGFCC) import GF.Canon.CanonToGFCC as C2GFCC import GF.Grammar.Macros import GF.Grammar.MMacros @@ -264,7 +264,7 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do let fromGFC = snd . snd . Cnv.convertGFC opts (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs fcfgs0 = [(IC id,g) | (CId id,g) <- - FCnv.convertGrammar (mkGFCC (C2GFCC.mkCanon2gfccNoUTF8 cgr))] + FCnv.convertGrammar (C2GFCC.mkCanon2gfccNoUTF8 cgr)] fcfgs = [(c,g) | c <- concrs, Just g <- [lookup c fcfgs0]] pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs diff --git a/src/GF/Conversion/SimpleToFCFG.hs b/src/GF/Conversion/SimpleToFCFG.hs index b70a15786..8b0337dd1 100644 --- a/src/GF/Conversion/SimpleToFCFG.hs +++ b/src/GF/Conversion/SimpleToFCFG.hs @@ -21,8 +21,10 @@ import Control.Monad import GF.Formalism.Utilities import GF.Formalism.FCFG -import GF.Canon.GFCC.AbsGFCC -import GF.Canon.GFCC.DataGFCC + +import GF.GFCC.Macros hiding (prt) +import GF.GFCC.DataGFCC +import GF.GFCC.AbsGFCC import GF.Data.BacktrackM import GF.Data.SortedList @@ -38,21 +40,24 @@ import Data.Maybe -- main conversion function convertGrammar :: GFCC -> [(CId,FGrammar)] -convertGrammar gfcc = [(cncname,convert abs_defs conc) | - cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)] +convertGrammar gfcc = [(cncname,convert abs_defs conc cats) | + cncname <- cncnames gfcc, + cnc <- Map.lookup cncname (concretes gfcc), + let conc = Map.union (opers cnc) (lins cnc), -- "union big+small most efficient" + let cats = lincats cnc] where abs_defs = Map.assocs (funs (abstract gfcc)) - convert :: [(CId,Type)] -> TermMap -> FGrammar - convert abs_defs cnc_defs = getFRules (loop frulesEnv) + convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar + convert abs_defs cnc_defs cat_defs = getFRules (loop frulesEnv) where srules = [ (XRule id args res (map findLinType args) (findLinType res) term) | - (id, Typ args res) <- abs_defs, + (id, (ty,_)) <- abs_defs, let (args,res) = catSkeleton ty, term <- Map.lookup id cnc_defs] - findLinType (CId id) = fromJust (Map.lookup (CId ("__"++id)) cnc_defs) + findLinType id = fromJust (Map.lookup id cat_defs) (srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules where @@ -128,9 +133,6 @@ convertTerm cnc_defs selector (V nr) ((lbl_path,lin) : lins) = convertArg convertTerm cnc_defs selector (C nr) ((lbl_path,lin) : lins) = convertCon selector nr lbl_path lin lins convertTerm cnc_defs selector (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 record lbl_path lin lins -----convertTerm cnc_defs selector (P term (R ts)) lins = ----- convertTerm cnc_defs selector (foldl P term ts) lins ---- ?? AR 2/10/2007 - convertTerm cnc_defs selector (P term sel) lins = do nr <- evalTerm cnc_defs [] sel convertTerm cnc_defs (TuplePrj nr selector) term lins convertTerm cnc_defs selector (FV vars) lins = do term <- member vars @@ -169,7 +171,7 @@ convertArg (ConSel indices) nr path lbl_path lin lins = do convertArg StrSel nr path lbl_path lin lins = do projectHead lbl_path xnr <- projectArg nr path - return ((lbl_path, Cat (path, nr, xnr) : lin) : lins) + return ((lbl_path, GF.Formalism.Utilities.Cat (path, nr, xnr) : lin) : lins) convertCon (ConSel indices) index lbl_path lin lins = do guard (index `elem` indices) diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index eb3046b18..0d8df98a1 100644 --- a/src/GF/Devel/GFC.hs +++ b/src/GF/Devel/GFC.hs @@ -2,7 +2,7 @@ module Main where import GF.Devel.Compile import GF.Devel.GrammarToGFCC -import GF.Devel.OptimizeGFCC +import GF.GFCC.OptimizeGFCC import GF.GFCC.CheckGFCC import GF.GFCC.DataGFCC import GF.Devel.UseIO diff --git a/src/GF/Formalism/FCFG.hs b/src/GF/Formalism/FCFG.hs index 5b8edc434..f8e3b6509 100644 --- a/src/GF/Formalism/FCFG.hs +++ b/src/GF/Formalism/FCFG.hs @@ -39,7 +39,7 @@ import Data.List (groupBy) import Data.Array import GF.Formalism.Utilities -import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC +import qualified GF.GFCC.AbsGFCC as AbsGFCC import GF.Infra.PrintClass diff --git a/src/GF/Devel/OptimizeGFCC.hs b/src/GF/GFCC/OptimizeGFCC.hs similarity index 98% rename from src/GF/Devel/OptimizeGFCC.hs rename to src/GF/GFCC/OptimizeGFCC.hs index 78d03911f..68ee66c42 100644 --- a/src/GF/Devel/OptimizeGFCC.hs +++ b/src/GF/GFCC/OptimizeGFCC.hs @@ -1,4 +1,4 @@ -module GF.Devel.OptimizeGFCC where +module GF.GFCC.OptimizeGFCC where import GF.GFCC.AbsGFCC import GF.GFCC.DataGFCC diff --git a/src/GF/Parsing/FCFG.hs b/src/GF/Parsing/FCFG.hs index 7784285e1..cf7f0d986 100644 --- a/src/GF/Parsing/FCFG.hs +++ b/src/GF/Parsing/FCFG.hs @@ -21,8 +21,9 @@ import GF.Formalism.Utilities import qualified GF.Parsing.FCFG.Active as Active import GF.Parsing.FCFG.PInfo -import GF.Canon.GFCC.AbsGFCC -import GF.Canon.GFCC.ErrM +import GF.GFCC.AbsGFCC +import GF.GFCC.Macros +import GF.GFCC.ErrM ---------------------------------------------------------------------- @@ -74,12 +75,12 @@ cnv_forests2 (FFloat x) = FFloat x -- parse trees to GFCC terms tree2term :: SyntaxTree CId -> Exp -tree2term (TNode f ts) = Tr (AC f) (map tree2term ts) +tree2term (TNode f ts) = tree (AC f) (map tree2term ts) -tree2term (TString s) = Tr (AS s) [] -tree2term (TInt n) = Tr (AI n) [] -tree2term (TFloat f) = Tr (AF f) [] -tree2term (TMeta) = Tr AM [] +tree2term (TString s) = tree (AS s) [] +tree2term (TInt n) = tree (AI n) [] +tree2term (TFloat f) = tree (AF f) [] +tree2term (TMeta) = exp0 ---------------------------------------------------------------------- -- conversion and unification of forests diff --git a/src/GF/Parsing/GFC.hs b/src/GF/Parsing/GFC.hs index 8d9257ebc..e84a2ec90 100644 --- a/src/GF/Parsing/GFC.hs +++ b/src/GF/Parsing/GFC.hs @@ -24,8 +24,8 @@ import GF.Data.Operations (Err(..)) import qualified GF.Grammar.Grammar as Grammar import qualified GF.Grammar.Macros as Macros import qualified GF.Canon.AbsGFC as AbsGFC -import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC -import qualified GF.Canon.GFCC.ErrM as ErrM +import qualified GF.GFCC.AbsGFCC as AbsGFCC +import qualified GF.GFCC.ErrM as ErrM import qualified GF.Infra.Ident as Ident import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok) @@ -169,14 +169,15 @@ tree2term abs (TFloat f) = Macros.float2term f tree2term abs (TMeta) = Macros.mkMeta 0 exp2term :: Ident.Ident -> AbsGFCC.Exp -> Grammar.Term -exp2term abs (AbsGFCC.Tr a es) = Macros.mkApp (atom2term abs a) (map (exp2term abs) es) +exp2term abs (AbsGFCC.DTr _ a es) = ---- TODO: bindings + Macros.mkApp (atom2term abs a) (map (exp2term abs) es) atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term atom2term abs (AbsGFCC.AC (AbsGFCC.CId f)) = Macros.qq (abs,Ident.IC f) atom2term abs (AbsGFCC.AS s) = Macros.string2term s atom2term abs (AbsGFCC.AI n) = Macros.int2term n atom2term abs (AbsGFCC.AF f) = Macros.float2term f -atom2term abs AbsGFCC.AM = Macros.mkMeta 0 +atom2term abs (AbsGFCC.AM i) = Macros.mkMeta (fromInteger i) ---------------------------------------------------------------------- -- conversion and unification of forests diff --git a/src/GF/Speech/GrammarToVoiceXML.hs b/src/GF/Speech/GrammarToVoiceXML.hs index 5415c8184..f84033e9c 100644 --- a/src/GF/Speech/GrammarToVoiceXML.hs +++ b/src/GF/Speech/GrammarToVoiceXML.hs @@ -11,9 +11,9 @@ module GF.Speech.GrammarToVoiceXML (grammar2vxml) where import GF.Canon.CanonToGFCC (mkCanon2gfcc) -import qualified GF.Canon.GFCC.AbsGFCC as C -import GF.Canon.GFCC.DataGFCC (GFCC(..), Abstr(..), mkGFCC, lookMap) - +import qualified GF.GFCC.AbsGFCC as C +import GF.GFCC.DataGFCC (GFCC(..), Abstr(..), mkGFCC) +import GF.GFCC.Macros import qualified GF.Canon.GFC as GFC import GF.Canon.AbsGFC (Term) import GF.Canon.PrintGFC (printTree) @@ -65,14 +65,14 @@ prid :: VIdent -> String prid (C.CId x) = x vSkeleton :: GFC.CanonGrammar -> (VIdent,VSkeleton) -vSkeleton = gfccSkeleton . mkGFCC . mkCanon2gfcc +vSkeleton = gfccSkeleton . mkCanon2gfcc gfccSkeleton :: GFCC -> (VIdent,VSkeleton) gfccSkeleton gfcc = (absname gfcc, ts) where a = abstract gfcc - ts = [(c,[(f,ft f) | f <- fs]) | (c,fs) <- Map.toList (cats a)] + ts = [(c,[(f,ft f) | f <- fs]) | (c,fs) <- Map.toList (catfuns a)] ft f = case lookMap (error $ prid f) f (funs a) of - C.Typ args _ -> args + (ty,_) -> fst $ GF.GFCC.Macros.catSkeleton ty -- -- * Questions to ask diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs index bca42d4fe..bcd61f428 100644 --- a/src/GF/Speech/TransformCFG.hs +++ b/src/GF/Speech/TransformCFG.hs @@ -17,8 +17,9 @@ module GF.Speech.TransformCFG where import GF.Canon.CanonToGFCC (mkCanon2gfcc) -import qualified GF.Canon.GFCC.AbsGFCC as C -import GF.Canon.GFCC.DataGFCC (GFCC, mkGFCC, lookType) +import qualified GF.GFCC.AbsGFCC as C +import GF.GFCC.Macros (lookType,catSkeleton) +import GF.GFCC.DataGFCC (GFCC) import GF.Conversion.Types import GF.CF.PPrCF (prCFCat) import GF.Data.Utilities @@ -70,7 +71,7 @@ cfgToCFRules s = nameToTerm (Name IW [Unify [n]]) = CFRes n nameToTerm (Name f@(IC c) prs) = CFObj f (zipWith profileToTerm args prs) - where C.Typ args _ = lookType gfcc (C.CId c) + where (args,_) = catSkeleton $ lookType gfcc (C.CId c) nameToTerm n = error $ "cfgToCFRules.nameToTerm" ++ show n profileToTerm (C.CId t) (Unify []) = CFMeta t profileToTerm _ (Unify xs) = CFRes (last xs) -- FIXME: unify @@ -84,7 +85,7 @@ getStartCatCF :: Options -> StateGrammar -> String getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s" stateGFCC :: StateGrammar -> GFCC -stateGFCC = mkGFCC . mkCanon2gfcc . stateGrammarST +stateGFCC = mkCanon2gfcc . stateGrammarST -- * Grammar filtering diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index c1b9caa19..aad580a63 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -35,8 +35,8 @@ import qualified GF.Grammar.Grammar as G import qualified GF.Canon.AbsGFC as A import qualified GF.Canon.GFC as C import qualified GF.Canon.CanonToGFCC as GFCC -import qualified GF.Canon.GFCC.GFCCToHaskell as CCH -import qualified GF.Canon.GFCC.DataGFCC as DataGFCC +import qualified GF.Devel.GFCCtoHaskell as CCH +import qualified GF.GFCC.DataGFCC as DataGFCC import qualified GF.Canon.CanonToJS as JS (prCanon2js) import qualified GF.Source.AbsGF as GF import qualified GF.Grammar.MMacros as MM @@ -274,7 +274,7 @@ customGrammarPrinter = ,(strCI "bnf", \_ -> prBNF False) ,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST) ,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST) - ,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell . DataGFCC.mkGFCC . + ,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell . GFCC.mkCanon2gfcc . stateGrammarST) ,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST) ,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST)