diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index 389afc5a7..43ce04166 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/src/GF/Canon/GFCC/DataGFCC.hs @@ -35,6 +35,10 @@ lookLin :: GFCC -> CId -> CId -> Term lookLin mcfg lang fun = lookMap TM fun $ lookMap undefined lang $ concretes mcfg +-- | Look up the type of a function. +lookType :: GFCC -> CId -> Type +lookType gfcc f = lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc)) + linearize :: GFCC -> CId -> Exp -> String linearize mcfg lang = realize . linExp mcfg lang diff --git a/src/GF/Speech/SISR.hs b/src/GF/Speech/SISR.hs index 71d5612ef..b74b44076 100644 --- a/src/GF/Speech/SISR.hs +++ b/src/GF/Speech/SISR.hs @@ -68,7 +68,7 @@ profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term] f (CFRes i) = JS.EIndex (JS.EVar children) (JS.EInt (fromIntegral i)) f (CFVar v) = JS.EVar (var v) f (CFConst s) = JS.EStr s - f CFMeta = tree "?" [] + f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr typ)] fmtOut SISROld = JS.EVar (JS.Ident "$") @@ -82,5 +82,7 @@ field x y = JS.EMember x (JS.Ident y) ass = JS.EAssign -tree n xs = JS.EObj $ [JS.Prop (JS.Ident "name") (JS.EStr n)] - ++ [JS.Prop (JS.Ident ("arg"++show i)) x | (i,x) <- zip [0..] xs] \ No newline at end of file +tree n xs = obj $ [("name", JS.EStr n)] ++ [("arg"++show i, x) | (i,x) <- zip [0..] xs] + +obj ps = JS.EObj [JS.Prop (JS.Ident x) y | (x,y) <- ps] + diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs index 3a167eeef..ed1730a3d 100644 --- a/src/GF/Speech/TransformCFG.hs +++ b/src/GF/Speech/TransformCFG.hs @@ -23,6 +23,9 @@ module GF.Speech.TransformCFG {- (CFRule_, CFRules, removeLeftRecursion, removeEmptyCats, removeIdenticalRules) -} where +import GF.Canon.CanonToGFCC (mkCanon2gfcc) +import qualified GF.Canon.GFCC.AbsGFCC as C +import GF.Canon.GFCC.DataGFCC (GFCC, mkGFCC, lookType) import GF.Conversion.Types import GF.CF.PPrCF (prCFCat) import GF.Data.Utilities @@ -33,7 +36,7 @@ import GF.Infra.Ident import GF.Infra.Option import GF.Infra.Print import GF.Speech.Relation -import GF.Compile.ShellState (StateGrammar, stateCFG, startCatStateOpts) +import GF.Compile.ShellState (StateGrammar, stateCFG, stateGrammarST, startCatStateOpts) import Control.Monad import Control.Monad.State (State, get, put, evalState) @@ -56,7 +59,7 @@ data CFTerm | CFRes Int | CFVar Int | CFConst String - | CFMeta + | CFMeta String deriving (Eq,Show) type Cat_ = String @@ -72,10 +75,13 @@ cfgToCFRules s = where cfg = stateCFG s symb = mapSymbol catToString id catToString = prt - nameToTerm (Name f prs) = CFObj f (map profileToTerm prs) - profileToTerm (Unify []) = CFMeta - profileToTerm (Unify xs) = CFRes (last xs) -- FIXME: unify - profileToTerm (Constant f) = maybe CFMeta (\x -> CFObj x []) (forestName f) + gfcc = stateGFCC s + nameToTerm (Name f prs) = CFObj f (zipWith profileToTerm args prs) + where C.Typ args _ = lookType gfcc (i2i f) + i2i (IC c) = C.CId c + profileToTerm (C.CId t) (Unify []) = CFMeta t + profileToTerm _ (Unify xs) = CFRes (last xs) -- FIXME: unify + profileToTerm (C.CId t) (Constant f) = maybe (CFMeta t) (\x -> CFObj x []) (forestName f) getStartCat :: Options -> StateGrammar -> String getStartCat opts sgr = prCFCat (startCatStateOpts opts sgr) @@ -83,6 +89,8 @@ getStartCat opts sgr = prCFCat (startCatStateOpts opts sgr) getStartCatCF :: Options -> StateGrammar -> String getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s" +stateGFCC :: StateGrammar -> GFCC +stateGFCC = mkGFCC . mkCanon2gfcc . stateGrammarST -- | Remove productions which use categories which have no productions removeEmptyCats :: CFRules -> CFRules