GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

1 files changed, 175 insertions, 0 deletions

diff --git a/src-3.0/GF/Conversion/GFCtoSimple.hs b/src-3.0/GF/Conversion/GFCtoSimple.hs
new file mode 100644
index 000000000..b6a34a8ce
--- /dev/null
+++ b/src-3.0/GF/Conversion/GFCtoSimple.hs
@@ -0,0 +1,175 @@
+---------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/07 11:24:51 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.15 $
+--
+-- Converting GFC to SimpleGFC
+--
+-- the conversion might fail if the GFC grammar has dependent or higher-order types,
+-- or if the grammar contains bound pattern variables
+-- (use -optimize=values/share/none when importing)
+--
+-- TODO: lift all functions to the 'Err' monad
+-----------------------------------------------------------------------------
+
+module GF.Conversion.GFCtoSimple
+    (convertGrammar) where
+
+import qualified GF.Canon.AbsGFC as A
+import qualified GF.Infra.Ident as I
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC 
+import GF.Formalism.Utilities
+import GF.Conversion.Types
+
+import GF.UseGrammar.Linear (expandLinTables)
+import GF.Canon.GFC (CanonGrammar)
+import GF.Canon.MkGFC (grammar2canon)
+import GF.Canon.Subexpressions (unSubelimCanon)
+import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat)
+import qualified GF.Canon.CMacros as CMacros (defLinType)
+import GF.Data.Operations (err, errVal)
+--import qualified Modules as M
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+----------------------------------------------------------------------
+
+type Env = (CanonGrammar, I.Ident)
+
+convertGrammar :: Env -> SGrammar
+convertGrammar (g,i) = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $
+		        tracePrt "GFCtoSimple - simpleGFC rules" (prt . length) $
+		         [ convertAbsFun gram fun typing |
+			  A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
+			  A.AbsDFun fun typing _ <- defs ]
+    where A.Gr modules = grammar2canon (fst gram)
+          gram = (unSubelimCanon g,i)
+
+convertAbsFun :: Env -> I.Ident -> A.Exp -> SRule
+convertAbsFun gram fun typing = -- trace2 "GFCtoSimple - converting function" (prt fun) $
+                                Rule abs cnc
+    where abs = convertAbstract [] fun typing
+	  cnc = convertConcrete gram abs
+
+----------------------------------------------------------------------
+-- abstract definitions
+
+convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name
+convertAbstract env fun (A.EProd x a b) 
+    = convertAbstract (convertAbsType x' [] a : env) fun b
+    where x' = if x==I.identC "h_" then anyVar else x
+convertAbstract env fun a 
+    = Abs (convertAbsType anyVar [] a) (reverse env) name
+    where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ]
+
+convertAbsType :: Var -> [FOType SCat] -> A.Exp -> SDecl
+convertAbsType x args (A.EProd _ a b) = convertAbsType x (convertType [] a : args) b
+convertAbsType x args a = Decl x (reverse args ::--> convertType [] a)
+
+convertType :: [TTerm] -> A.Exp -> FOType SCat
+convertType args (A.EApp a b) = convertType (convertExp [] b : args) a
+convertType args (A.EAtom at) = convertCat at ::@ reverse args
+convertType args (A.EProd _ _ b) = convertType args b ---- AR 7/10 workaround
+convertType args exp          = error $ "GFCtoSimple.convertType: " ++ prt exp
+
+{- Exp from GF/Canon/GFC.cf:
+EApp.   Exp1 ::= Exp1 Exp2 ;
+EProd.  Exp  ::= "(" Ident ":" Exp ")" "->" Exp ;
+EAbs.   Exp  ::= "\\" Ident "->" Exp ;
+EAtom.  Exp2 ::= Atom ;
+EData.  Exp2 ::= "data" ;
+-}
+
+convertExp :: [TTerm] -> A.Exp -> TTerm
+convertExp args (A.EAtom at) = convertAtom args at
+convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
+convertExp args exp          = error $ "GFCtoSimple.convertExp: " ++ prt exp
+
+convertAtom :: [TTerm] -> A.Atom -> TTerm
+convertAtom args (A.AC con) = con :@ reverse args
+-- A.AD: is this correct???
+convertAtom args (A.AD con) = con :@ args
+convertAtom []   (A.AV var) = TVar var
+convertAtom args atom       = error $ "GFCtoSimple.convertAtom: " ++ prt args ++ " " ++ show atom
+
+convertCat :: A.Atom -> SCat
+convertCat (A.AC (A.CIQ _ cat)) = cat
+convertCat atom                 = error $ "GFCtoSimple.convertCat: " ++ show atom
+
+----------------------------------------------------------------------
+-- concrete definitions
+
+convertConcrete :: Env -> Abstract SDecl Name -> Concrete SLinType (Maybe STerm)
+convertConcrete gram (Abs decl args name) = Cnc ltyp largs term
+    where term = fmap (convertTerm gram . expandTerm gram) $ lookupLin gram $ name2fun name
+	  ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args)
+
+expandTerm :: Env -> A.Term -> A.Term
+expandTerm gram term = -- tracePrt "expanded term" prt $
+		       err error id $ expandLinTables (fst gram) $
+		       -- tracePrt "initial term" prt $ 
+		       term
+
+convertCType :: Env -> A.CType -> SLinType
+convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
+convertCType gram (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt)
+convertCType gram ct@(A.Cn con)   = ConT $ map (convertTerm gram) $ groundTerms gram ct
+convertCType gram (A.TStr)        = StrT
+convertCType gram (A.TInts n)     = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor"
+
+convertTerm :: Env -> A.Term -> STerm
+convertTerm gram (A.Arg arg)       = convertArgVar arg
+convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms
+-- convertTerm gram (A.LI var)        = Var var
+convertTerm gram (A.R rec)         = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ]
+convertTerm gram (A.P term lbl)    = convertTerm gram term +. lbl
+convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
+					  (pat, term) <- zip (groundTerms gram ctype) terms ]
+convertTerm gram (A.T ctype tbl)   = Tbl [ (convertPatt pat, convertTerm gram term) |
+					   A.Cas pats term <- tbl, pat <- pats ]
+convertTerm gram (A.S term sel)    = convertTerm gram term :! convertTerm gram sel
+convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
+convertTerm gram (A.FV terms)      = variants (map (convertTerm gram) terms)
+convertTerm gram (A.E)             = Empty
+convertTerm gram (A.K (A.KS tok))  = Token tok
+-- 'pre' tokens are converted to variants (over-generating):
+convertTerm gram (A.K (A.KP strs vars))
+                                   = variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ]
+    where conc [] = Empty
+	  conc ts = foldr1 (?++) $ map Token ts
+convertTerm gram (A.I con)         = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor"
+convertTerm gram (A.EInt int)      = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor"
+
+convertArgVar :: A.ArgVar -> STerm
+convertArgVar (A.A cat nr)           = Arg (fromInteger nr) cat emptyPath
+convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath
+
+convertPatt (A.PC con pats) = con :^ map convertPatt pats
+-- convertPatt (A.PV x)        = Var x
+-- convertPatt (A.PW)          = Wildcard
+convertPatt (A.PR rec)      = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
+convertPatt (A.PI n)        = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor"
+convertPatt p               = error $ "GFCtoSimple.convertPatt: cannot handle " ++ show p
+
+----------------------------------------------------------------------
+
+lookupLin :: Env -> Fun -> Maybe A.Term
+lookupLin gram fun = err fail Just $
+		     Look.lookupLin (fst gram) (A.CIQ (snd gram) fun)
+
+lookupCType :: Env -> SDecl -> A.CType
+lookupCType env decl
+    = errVal CMacros.defLinType $ 
+      Look.lookupLincat (fst env) (A.CIQ (snd env) (decl2cat decl))
+
+groundTerms :: Env -> A.CType -> [A.Term]
+groundTerms gram ctype = err error id $
+			 Look.allParamValues (fst gram) ctype
+