summaryrefslogtreecommitdiff
path: root/src/GF/Conversion
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Conversion')
-rw-r--r--src/GF/Conversion/GFC.hs43
-rw-r--r--src/GF/Conversion/GFCtoSimple.hs135
-rw-r--r--src/GF/Conversion/MCFGtoCFG.hs49
-rw-r--r--src/GF/Conversion/SimpleToFinite.hs134
-rw-r--r--src/GF/Conversion/SimpleToMCFG.hs26
-rw-r--r--src/GF/Conversion/SimpleToMCFG/Coercions.hs62
-rw-r--r--src/GF/Conversion/SimpleToMCFG/Nondet.hs203
-rw-r--r--src/GF/Conversion/SimpleToMCFG/Strict.hs128
-rw-r--r--src/GF/Conversion/Types.hs79
9 files changed, 859 insertions, 0 deletions
diff --git a/src/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs
new file mode 100644
index 000000000..6a4adc253
--- /dev/null
+++ b/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
+
+
diff --git a/src/GF/Conversion/GFCtoSimple.hs b/src/GF/Conversion/GFCtoSimple.hs
new file mode 100644
index 000000000..1764f1644
--- /dev/null
+++ b/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
+
diff --git a/src/GF/Conversion/MCFGtoCFG.hs b/src/GF/Conversion/MCFGtoCFG.hs
new file mode 100644
index 000000000..c12bb6b53
--- /dev/null
+++ b/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 ]
+
+
+
+
diff --git a/src/GF/Conversion/SimpleToFinite.hs b/src/GF/Conversion/SimpleToFinite.hs
new file mode 100644
index 000000000..4abc22356
--- /dev/null
+++ b/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 "" "" ""
+
+
diff --git a/src/GF/Conversion/SimpleToMCFG.hs b/src/GF/Conversion/SimpleToMCFG.hs
new file mode 100644
index 000000000..5e299c8a0
--- /dev/null
+++ b/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
+
diff --git a/src/GF/Conversion/SimpleToMCFG/Coercions.hs b/src/GF/Conversion/SimpleToMCFG/Coercions.hs
new file mode 100644
index 000000000..c1dc5b07c
--- /dev/null
+++ b/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 ]
+
+
+
diff --git a/src/GF/Conversion/SimpleToMCFG/Nondet.hs b/src/GF/Conversion/SimpleToMCFG/Nondet.hs
new file mode 100644
index 000000000..b98b368ff
--- /dev/null
+++ b/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)
+
+
diff --git a/src/GF/Conversion/SimpleToMCFG/Strict.hs b/src/GF/Conversion/SimpleToMCFG/Strict.hs
new file mode 100644
index 000000000..17c2293ec
--- /dev/null
+++ b/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)
+
diff --git a/src/GF/Conversion/Types.hs b/src/GF/Conversion/Types.hs
new file mode 100644
index 000000000..d6b43bd58
--- /dev/null
+++ b/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
+
+
+
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 15:04:38 +0000