"Committed_by_peb"

src/GF/Conversion/GFC.hs

@@ -0,0 +1,43 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:48 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- All conversions from GFC 
+-----------------------------------------------------------------------------
+
+module GF.Conversion.GFC
+    (module GF.Conversion.GFC,
+     SimpleGrammar, MGrammar, CGrammar) where
+
+import GFC (CanonGrammar)
+import Ident (Ident)
+import GF.Formalism.SimpleGFC (SimpleGrammar)
+import GF.Conversion.Types (CGrammar, MGrammar)
+
+import qualified GF.Conversion.GFCtoSimple as G2S
+import qualified GF.Conversion.SimpleToFinite as S2Fin
+import qualified GF.Conversion.SimpleToMCFG as S2M
+import qualified GF.Conversion.MCFGtoCFG as M2C
+
+gfc2simple :: (CanonGrammar, Ident) -> SimpleGrammar
+gfc2simple = G2S.convertGrammar
+
+simple2finite :: SimpleGrammar -> SimpleGrammar
+simple2finite = S2Fin.convertGrammar
+
+simple2mcfg_nondet :: SimpleGrammar -> MGrammar
+simple2mcfg_nondet = S2M.convertGrammarNondet
+
+simple2mcfg_strict :: SimpleGrammar -> MGrammar
+simple2mcfg_strict = S2M.convertGrammarStrict
+
+mcfg2cfg :: MGrammar -> CGrammar
+mcfg2cfg = M2C.convertGrammar
+
+

src/GF/Conversion/GFCtoSimple.hs

@@ -0,0 +1,135 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:48 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Converting GFC to SimpleGFC
+--
+-- the conversion might fail if the GFC grammar has dependent or higher-order types
+-----------------------------------------------------------------------------
+
+module GF.Conversion.GFCtoSimple 
+    (convertGrammar) where
+
+import qualified AbsGFC as A
+import qualified Ident as I
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC 
+
+import GFC (CanonGrammar)
+import MkGFC (grammar2canon)
+import qualified Look (lookupLin, allParamValues, lookupLincat)
+import qualified CMacros (defLinType)
+import Operations (err, errVal)
+--import qualified Modules as M
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+----------------------------------------------------------------------
+
+type Env = (CanonGrammar, I.Ident)
+
+convertGrammar :: Env -> SimpleGrammar
+convertGrammar gram = trace2 "converting language" (show (snd gram)) $
+		      tracePrt "#simpleGFC rules" (show . length) $
+		      [ convertAbsFun gram fun typing |
+			A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
+			A.AbsDFun fun typing _ <- defs ]
+    where A.Gr modules = grammar2canon (fst gram)
+
+convertAbsFun :: Env -> I.Ident -> A.Exp -> SimpleRule
+convertAbsFun gram fun typing = Rule abs cnc
+    where abs = convertAbstract [] fun typing
+	  cnc = convertConcrete gram abs
+
+----------------------------------------------------------------------
+-- abstract definitions
+
+convertAbstract :: [Decl] -> Name -> A.Exp -> Abstract Decl Name
+convertAbstract env fun (A.EProd x a b) 
+    = convertAbstract ((x' ::: convertType [] a) : env) fun b
+    where x' = if x==I.identC "h_" then anyVar else x
+convertAbstract env fun a = Abs (anyVar ::: convertType [] a) (reverse env) fun
+
+convertType :: [Atom] -> A.Exp -> Type
+convertType args (A.EApp a (A.EAtom at)) = convertType (convertAtom at : args) a
+convertType args (A.EAtom at) = convertCat at :@ args
+
+convertAtom :: A.Atom -> Atom
+convertAtom (A.AC con) = ACon con
+convertAtom (A.AV var) = AVar var
+
+convertCat :: A.Atom -> Cat
+convertCat (A.AC (A.CIQ _ cat)) = cat
+convertCat at = error $ "convertCat: " ++ show at
+
+----------------------------------------------------------------------
+-- concrete definitions
+
+convertConcrete :: Env -> Abstract Decl Name -> Concrete LinType (Maybe Term)
+convertConcrete gram (Abs decl args fun) = Cnc ltyp largs term
+    where term = fmap (convertTerm gram) $ lookupLin gram fun 
+	  ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args)
+
+convertCType :: Env -> A.CType -> LinType
+convertCType gram (A.RecType rec) 
+    = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
+convertCType gram (A.Table ptype vtype) 
+    = TblT (convertCType gram ptype) (convertCType gram vtype)
+convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct
+convertCType gram (A.TStr) = StrT
+convertCType gram (A.TInts n) = error "convertCType: cannot handle 'TInts' constructor"
+
+convertTerm :: Env -> A.Term -> Term
+convertTerm gram (A.Arg arg) = convertArgVar arg
+convertTerm gram (A.Con 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)
+-- 'pre' tokens are converted to variants (over-generating):
+convertTerm gram (A.K (A.KP [s] vs))
+    = Variants $ Token s : [ Token v | A.Var [v] _ <- vs ]
+convertTerm gram (A.K (A.KP _ _)) = error "convertTerm: don't know how to handle string lists in 'pre' tokens"
+convertTerm gram (A.K (A.KS tok)) = Token tok
+convertTerm gram (A.E) = Empty
+convertTerm gram (A.I con) = error "convertTerm: cannot handle 'I' constructor"
+convertTerm gram (A.EInt int) = error "convertTerm: cannot handle 'EInt' constructor"
+
+convertArgVar :: A.ArgVar -> Term
+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 "convertPatt: cannot handle 'PI' constructor"
+
+----------------------------------------------------------------------
+
+lookupLin :: Env -> Name -> Maybe A.Term
+lookupLin gram fun = err fail Just $
+		     Look.lookupLin (fst gram) (A.CIQ (snd gram) fun)
+
+lookupCType :: Env -> Decl -> 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
+

src/GF/Conversion/MCFGtoCFG.hs

@@ -0,0 +1,49 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:48 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Converting MCFG grammars to (possibly overgenerating) CFG
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.MCFGtoCFG
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Monad
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Formalism.CFG
+import GF.Conversion.Types
+
+convertGrammar :: MGrammar -> CGrammar
+convertGrammar gram = tracePrt "#context-free rules" (prt.length) $
+		      concatMap convertRule gram
+
+convertRule :: MRule -> [CRule]
+convertRule (Rule (Abs cat args name) (Cnc _ _ record)) 
+    = [ CFRule (CCat cat lbl) rhs (CName name profile) |
+	Lin lbl lin <- record,
+	let rhs = map (mapSymbol convertArg id) lin,
+	let profile = map (argPlaces lin) [0 .. length args-1]
+      ]
+
+convertArg :: (MCat, MLabel, Int) -> CCat
+convertArg (cat, lbl, _) = CCat cat lbl
+
+argPlaces :: [Symbol (cat, lbl, Int) tok] -> Int -> [Int]
+argPlaces lin nr  = [ place | (nr', place) <- zip linArgs [0..], nr == nr' ]
+    where linArgs = [ nr' | (_, _, nr') <- filterCats lin ]
+
+
+
+

src/GF/Conversion/SimpleToFinite.hs

@@ -0,0 +1,134 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:48 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Calculating the finiteness of each type in a grammar
+-----------------------------------------------------------------------------
+
+module GF.Conversion.SimpleToFinite 
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+
+import GF.Data.SortedList
+import GF.Data.Assoc
+import GF.Data.BacktrackM
+import GF.Data.Utilities (lookupList)
+
+import Ident (Ident(..))
+
+type CnvMonad a = BacktrackM () a
+
+convertGrammar :: SimpleGrammar -> SimpleGrammar
+convertGrammar rules = tracePrt "#finite simpleGFC rules" (prt . length) $
+		       solutions cnvMonad ()
+    where split = calcSplitable rules
+	  cnvMonad = member rules >>= convertRule split
+
+convertRule :: Splitable -> SimpleRule -> CnvMonad SimpleRule
+convertRule split (Rule abs cnc) 
+    = do newAbs <- convertAbstract split abs
+	 return $ Rule newAbs cnc
+
+convertAbstract :: Splitable -> Abstract Decl Name -> CnvMonad (Abstract Decl Name)
+convertAbstract split (Abs (_ ::: typ) decls fun)
+    = case splitableFun split fun of
+        Just newCat -> return $ Abs (anyVar ::: (newCat :@ [])) decls fun
+	Nothing -> expandTyping split fun [] typ decls []
+
+
+expandTyping :: Splitable -> Name -> [(Var, Cat)] -> Type -> [Decl] -> [Decl] 
+	     -> CnvMonad (Abstract Decl Name)
+expandTyping split fun env (cat :@ atoms) [] decls 
+    = return $ Abs decl (reverse decls) fun
+    where decl = anyVar ::: substAtoms split env cat atoms []
+expandTyping split fun env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone
+    = do (xcat', env') <- calcNewEnv
+         let decl = x ::: substAtoms split env xcat' xatoms []
+	 expandTyping split fun env' typ declsToDo (decl : declsDone)
+    where calcNewEnv = case splitableCat split xcat of
+		         Just newCats -> do newCat <- member newCats
+					    return (newCat, (x,newCat) : env)
+			 Nothing -> return (xcat, env)
+
+substAtoms :: Splitable -> [(Var, Cat)] -> Cat -> [Atom] -> [Atom] -> Type
+substAtoms split env cat [] atoms = cat :@ reverse atoms
+substAtoms split env cat (atom:atomsToDo) atomsDone
+    = case atomLookup split env atom of
+        Just newCat -> substAtoms split env (mergeArg cat newCat) atomsToDo atomsDone
+	Nothing -> substAtoms split env cat atomsToDo (atom : atomsDone)
+
+atomLookup split env (AVar x) = lookup x env 
+atomLookup split env (ACon con) = splitableFun split (constr2name con)
+      
+
+----------------------------------------------------------------------
+-- splitable categories (finite, no dependencies)
+-- they should also be used as some dependency
+
+type Splitable = (Assoc Cat [Cat], Assoc Name Cat)
+
+splitableCat :: Splitable -> Cat -> Maybe [Cat]
+splitableCat = lookupAssoc . fst 
+
+splitableFun :: Splitable -> Name -> Maybe Cat
+splitableFun = lookupAssoc . snd
+
+calcSplitable :: [SimpleRule] -> Splitable
+calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
+    where splitableCat2Funs = groupPairs $ nubsort 
+			      [ (cat, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ]
+
+	  splitableFun2Cat = nubsort
+			     [ (fun, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ]
+
+          -- cat-fun pairs that are splitable
+	  splitableCatFuns = [ (cat, fun) |
+			       Rule (Abs (_ ::: (cat :@ [])) [] fun) _ <- rules,
+			       splitableCats ?= cat ]
+
+          -- all cats that are splitable
+          splitableCats = listSet $
+			  tracePrt "finite categories to split" prt $
+			  (nondepCats <**> depCats) <\\> resultCats
+
+          -- all result cats for some pure function
+	  resultCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ _)) decls _) _ <- rules,
+				 not (null decls) ]
+
+          -- all cats in constants without dependencies
+          nondepCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ [])) [] _) _ <- rules ]
+
+          -- all cats occurring as some dependency of another cat
+	  depCats = nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
+			      cat <- varCats [] (decls ++ [decl]) ]
+
+	  varCats _ [] = []
+	  varCats env ((x ::: (xcat :@ atoms)) : decls)
+	      = varCats ((x,xcat) : env) decls ++
+		[ cat | AVar y <- atoms, cat <- lookupList y env ]
+
+
+----------------------------------------------------------------------
+-- utilities
+-- mergeing categories
+
+mergeCats :: String -> String -> String -> Cat -> Cat -> Cat
+mergeCats before middle after (IC cat) (IC arg) 
+    = IC (before ++ cat ++ middle ++ arg ++ after)
+
+mergeFun, mergeArg :: Cat -> Cat -> Cat
+mergeFun = mergeCats "{" ":" "}"
+mergeArg = mergeCats "" "" ""
+
+

src/GF/Conversion/SimpleToMCFG.hs

@@ -0,0 +1,26 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:48 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- All different conversions from SimpleGFC to MCFG
+-----------------------------------------------------------------------------
+
+module GF.Conversion.SimpleToMCFG where
+
+import GF.Formalism.SimpleGFC 
+import GF.Conversion.Types
+
+import qualified GF.Conversion.SimpleToMCFG.Strict as Strict
+import qualified GF.Conversion.SimpleToMCFG.Nondet as Nondet
+import qualified GF.Conversion.SimpleToMCFG.Coercions as Coerce
+
+convertGrammarNondet, convertGrammarStrict :: SimpleGrammar -> MGrammar
+convertGrammarNondet = Coerce.addCoercions . Nondet.convertGrammar
+convertGrammarStrict = Strict.convertGrammar
+

src/GF/Conversion/SimpleToMCFG/Coercions.hs

@@ -0,0 +1,62 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:49 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Adding coercion functions to a MCFG if necessary.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToMCFG.Coercions
+    (addCoercions) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Conversion.Types 
+import GF.Data.SortedList
+import List (groupBy)
+
+----------------------------------------------------------------------
+
+addCoercions :: MGrammar -> MGrammar
+addCoercions rules = coercions ++ rules
+    where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | 
+					Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
+	  allHeadSet = nubsort allHeads
+	  allArgSet  = union   allArgs <\\> map fst allHeadSet
+	  coercions = tracePrt "#MCFG coercions" (prt . length) $
+		      concat $
+		      tracePrt "#MCFG coercions per category" (prtList . map length) $
+		      combineCoercions 
+		        (groupBy sameCatFst allHeadSet) 
+			(groupBy sameCat    allArgSet)
+	  sameCatFst a b = sameCat (fst a) (fst b)
+
+
+combineCoercions [] _ = []
+combineCoercions _ [] = []
+combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) 
+    = case compare (mcat2cat $ fst $ head heads) (mcat2cat $ head args) of
+        LT -> combineCoercions allHeads  allArgs'
+	GT -> combineCoercions allHeads' allArgs
+	EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
+
+
+makeCoercion heads args
+    = [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins)  |
+	(head@(MCat _ headCns), lbls) <- heads, 
+	let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
+	arg@(MCat _ argCns) <- args,
+	argCns `subset` headCns ]
+
+
+

src/GF/Conversion/SimpleToMCFG/Nondet.hs

@@ -0,0 +1,203 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:49 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
+-- Afterwards, the grammar has to be extended with coercion functions,
+-- from the module 'GF.Conversion.SimpleToMCFG.Coercions'
+--
+-- the resulting grammars might be /very large/
+--
+-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToMCFG.Nondet 
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Monad
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG 
+import GF.Formalism.MCFG 
+import GF.Formalism.SimpleGFC 
+import GF.Conversion.Types
+
+import GF.Data.BacktrackM
+
+
+------------------------------------------------------------
+-- type declarations
+
+type CnvMonad a = BacktrackM Env a
+
+type Env    = (MCat, [MCat], LinRec, [LinType])
+type LinRec = [Lin Cat MLabel Token]
+
+
+----------------------------------------------------------------------
+-- main conversion function
+
+convertGrammar :: SimpleGrammar -> MGrammar 
+convertGrammar rules = tracePrt "Nondet conversion: #MCFG rules" (prt . length) $
+		       solutions conversion undefined
+    where conversion = member rules >>= convertRule
+
+convertRule :: SimpleRule -> CnvMonad MRule
+convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
+    = do let cat : args = map decl2cat (decl : decls)
+	 writeState (initialMCat cat, map initialMCat args, [], ctypes)
+	 rterm <- simplifyTerm term
+	 reduceTerm ctype emptyPath rterm
+	 (newCat, newArgs, linRec, _) <- readState
+	 let newLinRec = map (instantiateArgs newArgs) linRec
+	     catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
+	 return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) 
+convertRule _ = failure
+
+
+----------------------------------------------------------------------
+-- term simplification
+
+simplifyTerm :: Term -> CnvMonad Term
+simplifyTerm (term :! sel)      
+    = do sterm <- simplifyTerm term
+	 ssel <- simplifyTerm sel
+	 case sterm of
+	   Tbl table  -> do (pat, val) <- member table
+			    pat =?= ssel
+			    return val
+	   _ -> do sel' <- expandTerm ssel
+		   return (sterm +! sel')
+simplifyTerm (con :^ terms)    = liftM (con :^) $ mapM simplifyTerm terms
+simplifyTerm (Rec record)      = liftM Rec      $ mapM simplifyAssign record
+simplifyTerm (term :. lbl)     = liftM (+. lbl) $      simplifyTerm term
+simplifyTerm (Tbl table)       = liftM Tbl      $ mapM simplifyCase table
+simplifyTerm (Variants terms)  = liftM Variants $ mapM simplifyTerm terms
+simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
+simplifyTerm term              = return term
+-- error constructors:
+--   (I CIdent) - from resource
+--   (LI Ident) - pattern variable
+--   (EInt Integer) - integer
+
+simplifyAssign :: (Label, Term) -> CnvMonad (Label, Term)
+simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term
+
+simplifyCase :: (Term, Term) -> CnvMonad (Term, Term)
+simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term)
+
+
+------------------------------------------------------------
+-- reducing simplified terms, collecting MCF rules
+
+reduceTerm :: LinType -> Path -> Term -> CnvMonad ()
+reduceTerm ctype path (Variants terms) 
+    = member terms >>= reduceTerm ctype path
+reduceTerm (StrT)     path term = updateLin (path, term)
+reduceTerm (ConT _ _) path term = do pat <- expandTerm term
+				     updateHead (path, pat)
+reduceTerm (RecT rtype) path term
+    = sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) |
+		  (lbl, ctype) <- rtype ]
+reduceTerm (TblT ptype vtype) path table 
+    = sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) |
+		  pat <- enumeratePatterns ptype ]
+
+
+------------------------------------------------------------
+-- expanding a term to ground terms
+
+expandTerm :: Term -> CnvMonad Term
+expandTerm arg@(Arg nr _ path) 
+    = do ctypes <- readArgCTypes
+	 pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
+	 pat =?= arg
+	 return pat
+expandTerm (con :^ terms)   = liftM (con :^) $ mapM expandTerm terms
+expandTerm (Rec record)     = liftM  Rec     $ mapM expandAssign record
+expandTerm (Variants terms) = member terms >>= expandTerm  
+expandTerm term = error $ "expandTerm: " ++ prt term
+
+expandAssign :: (Label, Term) -> CnvMonad (Label, Term)
+expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
+
+
+------------------------------------------------------------
+-- unification of patterns and selection terms
+
+(=?=) :: Term -> Term -> CnvMonad ()
+Wildcard      =?= _               = return ()
+Rec precord   =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
+						(lbl, pat) <- precord ]
+pat           =?= Arg nr _ path   = updateArg nr (path, pat)
+(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms)
+				       sequence_ $ zipWith (=?=) pats terms
+Rec precord   =?= Rec record      = sequence_ [ maybe mzero (pat =?=) mterm |
+						(lbl, pat) <- precord,
+						let mterm = lookup lbl record ]
+pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term
+
+
+------------------------------------------------------------
+-- updating the MCF rule
+
+readArgCTypes :: CnvMonad [LinType]
+readArgCTypes = do (_, _, _, env) <- readState
+		   return env
+
+updateArg :: Int -> Constraint -> CnvMonad ()
+updateArg arg cn
+    = do (head, args, lins, env) <- readState 
+	 args' <- updateNth (addToMCat cn) arg args
+	 writeState (head, args', lins, env)
+
+updateHead :: Constraint -> CnvMonad ()
+updateHead cn
+    = do (head, args, lins, env) <- readState
+	 head' <- addToMCat cn head
+	 writeState (head', args, lins, env)
+
+updateLin :: Constraint -> CnvMonad ()
+updateLin (path, term) 
+    = do let newLins = term2lins term
+	 (head, args, lins, env) <- readState
+	 let lins' = lins ++ map (Lin path) newLins
+	 writeState (head, args, lins', env)
+
+term2lins :: Term -> [[Symbol (Cat, Path, Int) Token]]
+term2lins (Arg nr cat path) = return [Cat (cat, path, nr)]
+term2lins (Token str)       = return [Tok str]
+term2lins (t1 :++ t2)       = liftM2 (++) (term2lins t1) (term2lins t2)
+term2lins (Empty)           = return []
+term2lins (Variants terms)  = terms >>= term2lins
+term2lins term = error $ "term2lins: " ++ show term
+
+addToMCat :: Constraint -> MCat -> CnvMonad MCat
+addToMCat cn (MCat cat cns) = liftM (MCat cat) $ addConstraint cn cns
+
+addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint]
+addConstraint cn0 (cn : cns)
+    | fst cn0 >  fst cn = liftM (cn:) (addConstraint cn0 cns)
+    | fst cn0 == fst cn = guard (snd cn0 == snd cn) >>
+			  return (cn : cns)
+addConstraint cn0 cns   = return (cn0 : cns)
+
+
+----------------------------------------------------------------------
+-- utilities 
+
+updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
+updateNth update 0 (a : as) = liftM (:as) (update a)
+updateNth update n (a : as) = liftM (a:)  (updateNth update (n-1) as)
+
+

src/GF/Conversion/SimpleToMCFG/Strict.hs

@@ -0,0 +1,128 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:49 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Converting SimpleGFC grammars to MCFG grammars, deterministic.
+--
+-- the resulting grammars might be /very large/
+--
+-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToMCFG.Strict where -- (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Monad
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG 
+import GF.Formalism.MCFG 
+import GF.Formalism.SimpleGFC 
+import GF.Conversion.Types
+
+import GF.Data.BacktrackM
+import GF.Data.SortedList
+
+----------------------------------------------------------------------
+-- main conversion function
+
+type CnvMonad a = BacktrackM () a
+
+convertGrammar :: SimpleGrammar -> MGrammar 
+convertGrammar rules = tracePrt "Strict conversion: #MCFG rules" (prt . length) $
+		       solutions conversion undefined
+    where conversion = member rules >>= convertRule
+
+convertRule :: SimpleRule -> CnvMonad MRule
+convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
+    = do let cat : args  = map decl2cat (decl : decls)
+	     args_ctypes = zip3 [0..] args ctypes
+	 instArgs <- mapM enumerateArg args_ctypes
+	 let instTerm = substitutePaths instArgs term
+	 newCat <- extractMCat cat ctype instTerm
+	 newArgs <- mapM (extractArg instArgs) args_ctypes
+	 let linRec = strPaths ctype instTerm >>= extractLin newArgs
+	 let newLinRec = map (instantiateArgs newArgs) linRec
+	     catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
+	 return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) 
+convertRule _ = failure
+
+----------------------------------------------------------------------
+-- category extraction
+
+extractArg :: [Term] -> (Int, Cat, LinType) -> CnvMonad MCat
+extractArg args (nr, cat, ctype) = extractMCat cat ctype (args !! nr)
+
+extractMCat :: Cat -> LinType -> Term -> CnvMonad MCat
+extractMCat cat ctype term = member $ map (MCat cat) $ parPaths ctype term
+
+enumerateArg :: (Int, Cat, LinType) -> CnvMonad Term
+enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype
+
+----------------------------------------------------------------------
+-- Substitute each instantiated parameter path for its instantiation
+
+substitutePaths :: [Term] -> Term -> Term
+substitutePaths arguments = subst 
+    where subst (Arg nr _ path)  = termFollowPath path (arguments !! nr)
+	  subst (con :^ terms)   = con :^ map subst terms
+	  subst (Rec record)     = Rec [ (lbl, subst term) | (lbl, term) <- record ]
+	  subst (term :. lbl)    = subst term +. lbl
+	  subst (Tbl table)      = Tbl [ (pat, subst term) | 
+				      (pat, term) <- table ]
+	  subst (term :! select) = subst term +! subst select
+	  subst (term :++ term') = subst term ?++ subst term'
+	  subst (Variants terms) = Variants $ map subst terms
+	  subst term = term
+
+----------------------------------------------------------------------
+-- term paths extaction
+
+termPaths :: LinType -> Term -> [(Path, (LinType, Term))]
+termPaths ctype (Variants terms) = terms >>= termPaths ctype
+termPaths (RecT rtype) (Rec record) 
+    = [ (path ++. lbl, value) |
+	(lbl, term) <- record,
+	let Just ctype = lookup lbl rtype,
+	(path, value) <- termPaths ctype term ]
+termPaths (TblT _ ctype) (Tbl table)
+    = [ (path ++! pat, value) |
+	(pat, term) <- table,
+	(path, value) <- termPaths ctype term ]
+termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ]
+
+{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt):
+{a=a1; b=b1}  | {a=a2; b=b2}   ==>  {a=a1|a2; b=b1|b2}
+[p=>p1;q=>q1] | [p=>p2;q=>q2]  ==>  [p=>p1|p2;q=>q1|q2]
+-}
+
+parPaths :: LinType -> Term -> [[(Path, Term)]]
+parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $
+		      nubsort [ (path, value) | 
+				(path, (ConT _ _, value)) <- termPaths ctype term ]
+
+strPaths :: LinType -> Term -> [(Path, Term)]
+strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ]
+    where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ]
+
+----------------------------------------------------------------------
+-- linearization extraction
+
+extractLin :: [MCat] -> (Path, Term) -> [Lin MCat MLabel Token]
+extractLin args (path, term) = map (Lin path) (convertLin term)
+    where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2)
+	  convertLin (Empty) = [[]]
+	  convertLin (Token tok) = [[Tok tok]]
+	  convertLin (Variants terms) = concatMap convertLin terms
+	  convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]]
+	  convertLin t = error $ "convertLin: " ++ prt t ++ "  " ++ prt (args, path)
+

src/GF/Conversion/Types.hs

@@ -0,0 +1,79 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:49 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- All possible instantiations of different grammar formats used in conversion from GFC
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.Types where
+
+import qualified Ident
+import qualified Grammar (Term)
+import qualified Macros
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.MCFG
+import GF.Formalism.CFG
+import GF.Infra.Print
+
+----------------------------------------------------------------------
+-- * MCFG
+
+type MGrammar = MCFGrammar MCat Name MLabel Token
+type MRule    = MCFRule    MCat Name MLabel Token
+data MCat     = MCat Cat [Constraint] deriving (Eq, Ord, Show)
+type MLabel   = Path
+
+type Constraint = (Path, Term)
+
+initialMCat :: Cat -> MCat
+initialMCat cat = MCat cat []
+
+mcat2cat :: MCat -> Cat
+mcat2cat (MCat cat _) = cat
+
+sameCat :: MCat -> MCat -> Bool
+sameCat mc1 mc2 = mcat2cat mc1 == mcat2cat mc2
+
+coercionName :: Name
+coercionName = Ident.wildIdent
+
+isCoercion :: Name -> Bool
+isCoercion = Ident.isWildIdent
+
+----------------------------------------------------------------------
+-- * CFG
+
+type CGrammar = CFGrammar CCat CName Token
+type CRule    = CFRule    CCat CName Token
+
+data CCat     = CCat      MCat MLabel
+		deriving (Eq, Ord, Show)
+data CName    = CName     Name Profile
+		deriving (Eq, Ord, Show)
+type Profile   = [[Int]]
+
+----------------------------------------------------------------------
+-- * pretty-printing
+
+instance Print MCat where
+    prt (MCat cat constrs) = prt cat ++ "{" ++ 
+			     concat [ prt path ++ "=" ++ prt term ++ ";" |
+				      (path, term) <- constrs ] ++ "}"
+
+instance Print CCat where
+    prt (CCat cat label) = prt cat ++ prt label
+
+instance Print CName where
+    prt (CName fun args) = prt fun ++ prt args
+
+
+