From 81165cf09dd738b52b12f8f89d03b06777e2d3c5 Mon Sep 17 00:00:00 2001 From: peb Date: Tue, 12 Apr 2005 09:49:44 +0000 Subject: [PATCH] "Committed_by_peb" --- src/GF/Conversion/GFC.hs | 17 +- src/GF/Conversion/GFCtoSimple.hs | 35 +-- src/GF/Conversion/MCFGtoCFG.hs | 11 +- src/GF/Conversion/SimpleToFinite.hs | 44 +-- src/GF/Conversion/SimpleToMCFG.hs | 6 +- src/GF/Conversion/SimpleToMCFG/Coercions.hs | 6 +- src/GF/Conversion/SimpleToMCFG/Nondet.hs | 30 +- src/GF/Conversion/SimpleToMCFG/Strict.hs | 24 +- src/GF/Conversion/Types.hs | 127 +++++++-- src/GF/Data/Assoc.hs | 6 +- src/GF/Formalism/SimpleGFC.hs | 117 ++++---- src/GF/Formalism/Symbol.hs | 46 --- src/GF/Parsing/CFGrammar.hs | 153 ---------- src/GF/Parsing/ConvertFiniteGFC.hs | 272 ------------------ src/GF/Parsing/ConvertGFCtoMCFG.hs | 34 --- src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs | 71 ----- src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs | 280 ------------------- src/GF/Parsing/ConvertGFCtoMCFG/Old.hs | 277 ------------------ src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs | 195 ------------- src/GF/Parsing/ConvertGrammar.hs | 44 --- src/GF/Parsing/ConvertMCFGtoCFG.hs | 52 ---- src/GF/Parsing/GFC.hs | 40 +-- src/GF/Parsing/GeneralChart.hs | 86 ------ src/GF/Parsing/GrammarTypes.hs | 146 ---------- src/GF/Parsing/IncrementalChart.hs | 50 ---- src/GF/Parsing/MCFGrammar.hs | 206 -------------- src/GF/Parsing/ParseCF.hs | 82 ------ src/GF/Parsing/ParseCFG.hs | 43 --- src/GF/Parsing/ParseCFG/General.hs | 84 ------ src/GF/Parsing/ParseCFG/Incremental.hs | 143 ---------- src/GF/Parsing/ParseGFC.hs | 177 ------------ src/GF/Parsing/ParseMCFG.hs | 37 --- src/GF/Parsing/ParseMCFG/Basic.hs | 156 ----------- src/GF/Parsing/Utilities.hs | 188 ------------- src/GF/UseGrammar/Custom.hs | 46 +-- 35 files changed, 285 insertions(+), 3046 deletions(-) delete mode 100644 src/GF/Formalism/Symbol.hs delete mode 100644 src/GF/Parsing/CFGrammar.hs delete mode 100644 src/GF/Parsing/ConvertFiniteGFC.hs delete mode 100644 src/GF/Parsing/ConvertGFCtoMCFG.hs delete mode 100644 src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs delete mode 100644 src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs delete mode 100644 src/GF/Parsing/ConvertGFCtoMCFG/Old.hs delete mode 100644 src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs delete mode 100644 src/GF/Parsing/ConvertGrammar.hs delete mode 100644 src/GF/Parsing/ConvertMCFGtoCFG.hs delete mode 100644 src/GF/Parsing/GeneralChart.hs delete mode 100644 src/GF/Parsing/GrammarTypes.hs delete mode 100644 src/GF/Parsing/IncrementalChart.hs delete mode 100644 src/GF/Parsing/MCFGrammar.hs delete mode 100644 src/GF/Parsing/ParseCF.hs delete mode 100644 src/GF/Parsing/ParseCFG.hs delete mode 100644 src/GF/Parsing/ParseCFG/General.hs delete mode 100644 src/GF/Parsing/ParseCFG/Incremental.hs delete mode 100644 src/GF/Parsing/ParseGFC.hs delete mode 100644 src/GF/Parsing/ParseMCFG.hs delete mode 100644 src/GF/Parsing/ParseMCFG/Basic.hs delete mode 100644 src/GF/Parsing/Utilities.hs diff --git a/src/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs index 6a4adc253..5b5c4491e 100644 --- a/src/GF/Conversion/GFC.hs +++ b/src/GF/Conversion/GFC.hs @@ -4,37 +4,36 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:48 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- All conversions from GFC ----------------------------------------------------------------------------- module GF.Conversion.GFC (module GF.Conversion.GFC, - SimpleGrammar, MGrammar, CGrammar) where + SGrammar, MGrammar, CGrammar) where import GFC (CanonGrammar) import Ident (Ident) -import GF.Formalism.SimpleGFC (SimpleGrammar) -import GF.Conversion.Types (CGrammar, MGrammar) +import GF.Conversion.Types (CGrammar, MGrammar, SGrammar) 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 :: (CanonGrammar, Ident) -> SGrammar gfc2simple = G2S.convertGrammar -simple2finite :: SimpleGrammar -> SimpleGrammar +simple2finite :: SGrammar -> SGrammar simple2finite = S2Fin.convertGrammar -simple2mcfg_nondet :: SimpleGrammar -> MGrammar +simple2mcfg_nondet :: SGrammar -> MGrammar simple2mcfg_nondet = S2M.convertGrammarNondet -simple2mcfg_strict :: SimpleGrammar -> MGrammar +simple2mcfg_strict :: SGrammar -> MGrammar simple2mcfg_strict = S2M.convertGrammarStrict mcfg2cfg :: MGrammar -> CGrammar diff --git a/src/GF/Conversion/GFCtoSimple.hs b/src/GF/Conversion/GFCtoSimple.hs index 1764f1644..5e4313b1b 100644 --- a/src/GF/Conversion/GFCtoSimple.hs +++ b/src/GF/Conversion/GFCtoSimple.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:48 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Converting GFC to SimpleGFC -- @@ -20,6 +20,7 @@ import qualified AbsGFC as A import qualified Ident as I import GF.Formalism.GCFG import GF.Formalism.SimpleGFC +import GF.Conversion.Types import GFC (CanonGrammar) import MkGFC (grammar2canon) @@ -35,7 +36,7 @@ import GF.Infra.Print type Env = (CanonGrammar, I.Ident) -convertGrammar :: Env -> SimpleGrammar +convertGrammar :: Env -> SGrammar convertGrammar gram = trace2 "converting language" (show (snd gram)) $ tracePrt "#simpleGFC rules" (show . length) $ [ convertAbsFun gram fun typing | @@ -43,7 +44,7 @@ convertGrammar gram = trace2 "converting language" (show (snd gram)) $ A.AbsDFun fun typing _ <- defs ] where A.Gr modules = grammar2canon (fst gram) -convertAbsFun :: Env -> I.Ident -> A.Exp -> SimpleRule +convertAbsFun :: Env -> I.Ident -> A.Exp -> SRule convertAbsFun gram fun typing = Rule abs cnc where abs = convertAbstract [] fun typing cnc = convertConcrete gram abs @@ -51,13 +52,15 @@ convertAbsFun gram fun typing = Rule abs cnc ---------------------------------------------------------------------- -- abstract definitions -convertAbstract :: [Decl] -> Name -> A.Exp -> Abstract Decl Name +convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl 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 +convertAbstract env fun a + = Abs (anyVar ::: convertType [] a) (reverse env) name + where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ] -convertType :: [Atom] -> A.Exp -> Type +convertType :: [Atom] -> A.Exp -> SType convertType args (A.EApp a (A.EAtom at)) = convertType (convertAtom at : args) a convertType args (A.EAtom at) = convertCat at :@ args @@ -65,19 +68,19 @@ convertAtom :: A.Atom -> Atom convertAtom (A.AC con) = ACon con convertAtom (A.AV var) = AVar var -convertCat :: A.Atom -> Cat +convertCat :: A.Atom -> SCat 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 +convertConcrete :: Env -> Abstract SDecl Name -> Concrete SLinType (Maybe STerm) +convertConcrete gram (Abs decl args name) = Cnc ltyp largs term + where term = fmap (convertTerm gram) $ lookupLin gram $ name2fun name ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args) -convertCType :: Env -> A.CType -> LinType +convertCType :: Env -> A.CType -> SLinType convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ] convertCType gram (A.Table ptype vtype) @@ -86,7 +89,7 @@ convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerm convertCType gram (A.TStr) = StrT convertCType gram (A.TInts n) = error "convertCType: cannot handle 'TInts' constructor" -convertTerm :: Env -> A.Term -> Term +convertTerm :: Env -> A.Term -> STerm 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 @@ -108,7 +111,7 @@ 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.ArgVar -> STerm convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath @@ -120,11 +123,11 @@ convertPatt (A.PI n) = error "convertPatt: cannot handle 'PI' constructor" ---------------------------------------------------------------------- -lookupLin :: Env -> Name -> Maybe A.Term +lookupLin :: Env -> Fun -> 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 -> SDecl -> A.CType lookupCType env decl = errVal CMacros.defLinType $ Look.lookupLincat (fst env) (A.CIQ (snd env) (decl2cat decl)) diff --git a/src/GF/Conversion/MCFGtoCFG.hs b/src/GF/Conversion/MCFGtoCFG.hs index c12bb6b53..2b86b633a 100644 --- a/src/GF/Conversion/MCFGtoCFG.hs +++ b/src/GF/Conversion/MCFGtoCFG.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:48 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Converting MCFG grammars to (possibly overgenerating) CFG ----------------------------------------------------------------------------- @@ -30,11 +30,12 @@ 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) | +convertRule (Rule (Abs cat args (Name fun mprofile)) (Cnc _ _ record)) + = [ CFRule (CCat cat lbl) rhs (Name fun profile) | Lin lbl lin <- record, let rhs = map (mapSymbol convertArg id) lin, - let profile = map (argPlaces lin) [0 .. length args-1] + let cprofile = map (Unify . argPlaces lin) [0 .. length args-1], + let profile = mprofile `composeProfiles` cprofile ] convertArg :: (MCat, MLabel, Int) -> CCat diff --git a/src/GF/Conversion/SimpleToFinite.hs b/src/GF/Conversion/SimpleToFinite.hs index 4abc22356..cc180a7e1 100644 --- a/src/GF/Conversion/SimpleToFinite.hs +++ b/src/GF/Conversion/SimpleToFinite.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:48 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Calculating the finiteness of each type in a grammar ----------------------------------------------------------------------------- @@ -19,6 +19,7 @@ import GF.Infra.Print import GF.Formalism.GCFG import GF.Formalism.SimpleGFC +import GF.Conversion.Types import GF.Data.SortedList import GF.Data.Assoc @@ -29,26 +30,27 @@ import Ident (Ident(..)) type CnvMonad a = BacktrackM () a -convertGrammar :: SimpleGrammar -> SimpleGrammar +convertGrammar :: SGrammar -> SGrammar 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 :: Splitable -> SRule -> CnvMonad SRule 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 [] +convertAbstract :: Splitable -> Abstract SDecl Name + -> CnvMonad (Abstract SDecl Name) +convertAbstract split (Abs (_ ::: typ) decls name) + = case splitableFun split (name2fun name) of + Just newCat -> return $ Abs (anyVar ::: (newCat :@ [])) decls name + Nothing -> expandTyping split name [] typ decls [] -expandTyping :: Splitable -> Name -> [(Var, Cat)] -> Type -> [Decl] -> [Decl] - -> CnvMonad (Abstract Decl Name) +expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SType -> [SDecl] -> [SDecl] + -> CnvMonad (Abstract SDecl Name) expandTyping split fun env (cat :@ atoms) [] decls = return $ Abs decl (reverse decls) fun where decl = anyVar ::: substAtoms split env cat atoms [] @@ -61,7 +63,7 @@ expandTyping split fun env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone return (newCat, (x,newCat) : env) Nothing -> return (xcat, env) -substAtoms :: Splitable -> [(Var, Cat)] -> Cat -> [Atom] -> [Atom] -> Type +substAtoms :: Splitable -> [(Var, SCat)] -> SCat -> [Atom] -> [Atom] -> SType substAtoms split env cat [] atoms = cat :@ reverse atoms substAtoms split env cat (atom:atomsToDo) atomsDone = case atomLookup split env atom of @@ -69,22 +71,22 @@ substAtoms split env cat (atom: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) +atomLookup split env (ACon con) = splitableFun split (constr2fun con) ---------------------------------------------------------------------- -- splitable categories (finite, no dependencies) -- they should also be used as some dependency -type Splitable = (Assoc Cat [Cat], Assoc Name Cat) +type Splitable = (Assoc SCat [SCat], Assoc Fun SCat) -splitableCat :: Splitable -> Cat -> Maybe [Cat] +splitableCat :: Splitable -> SCat -> Maybe [SCat] splitableCat = lookupAssoc . fst -splitableFun :: Splitable -> Name -> Maybe Cat +splitableFun :: Splitable -> Fun -> Maybe SCat splitableFun = lookupAssoc . snd -calcSplitable :: [SimpleRule] -> Splitable +calcSplitable :: [SRule] -> Splitable calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat) where splitableCat2Funs = groupPairs $ nubsort [ (cat, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ] @@ -93,8 +95,8 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat) [ (fun, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ] -- cat-fun pairs that are splitable - splitableCatFuns = [ (cat, fun) | - Rule (Abs (_ ::: (cat :@ [])) [] fun) _ <- rules, + splitableCatFuns = [ (cat, name2fun name) | + Rule (Abs (_ ::: (cat :@ [])) [] name) _ <- rules, splitableCats ?= cat ] -- all cats that are splitable @@ -123,11 +125,11 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat) -- utilities -- mergeing categories -mergeCats :: String -> String -> String -> Cat -> Cat -> Cat +mergeCats :: String -> String -> String -> SCat -> SCat -> SCat mergeCats before middle after (IC cat) (IC arg) = IC (before ++ cat ++ middle ++ arg ++ after) -mergeFun, mergeArg :: Cat -> Cat -> Cat +mergeFun, mergeArg :: SCat -> SCat -> SCat mergeFun = mergeCats "{" ":" "}" mergeArg = mergeCats "" "" "" diff --git a/src/GF/Conversion/SimpleToMCFG.hs b/src/GF/Conversion/SimpleToMCFG.hs index 5e299c8a0..2b829a52e 100644 --- a/src/GF/Conversion/SimpleToMCFG.hs +++ b/src/GF/Conversion/SimpleToMCFG.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:48 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- All different conversions from SimpleGFC to MCFG ----------------------------------------------------------------------------- @@ -20,7 +20,7 @@ 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, convertGrammarStrict :: SGrammar -> 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 index c1dc5b07c..a57953061 100644 --- a/src/GF/Conversion/SimpleToMCFG/Coercions.hs +++ b/src/GF/Conversion/SimpleToMCFG/Coercions.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Adding coercion functions to a MCFG if necessary. ----------------------------------------------------------------------------- @@ -45,7 +45,7 @@ addCoercions rules = coercions ++ rules combineCoercions [] _ = [] combineCoercions _ [] = [] combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) - = case compare (mcat2cat $ fst $ head heads) (mcat2cat $ head args) of + = case compare (mcat2scat $ fst $ head heads) (mcat2scat $ head args) of LT -> combineCoercions allHeads allArgs' GT -> combineCoercions allHeads' allArgs EQ -> makeCoercion heads args : combineCoercions allHeads allArgs diff --git a/src/GF/Conversion/SimpleToMCFG/Nondet.hs b/src/GF/Conversion/SimpleToMCFG/Nondet.hs index b98b368ff..83e5fec96 100644 --- a/src/GF/Conversion/SimpleToMCFG/Nondet.hs +++ b/src/GF/Conversion/SimpleToMCFG/Nondet.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. -- Afterwards, the grammar has to be extended with coercion functions, @@ -40,19 +40,19 @@ import GF.Data.BacktrackM type CnvMonad a = BacktrackM Env a -type Env = (MCat, [MCat], LinRec, [LinType]) -type LinRec = [Lin Cat MLabel Token] +type Env = (MCat, [MCat], LinRec, [SLinType]) +type LinRec = [Lin SCat MLabel Token] ---------------------------------------------------------------------- -- main conversion function -convertGrammar :: SimpleGrammar -> MGrammar +convertGrammar :: SGrammar -> MGrammar convertGrammar rules = tracePrt "Nondet conversion: #MCFG rules" (prt . length) $ solutions conversion undefined where conversion = member rules >>= convertRule -convertRule :: SimpleRule -> CnvMonad MRule +convertRule :: SRule -> 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) @@ -68,7 +68,7 @@ convertRule _ = failure ---------------------------------------------------------------------- -- term simplification -simplifyTerm :: Term -> CnvMonad Term +simplifyTerm :: STerm -> CnvMonad STerm simplifyTerm (term :! sel) = do sterm <- simplifyTerm term ssel <- simplifyTerm sel @@ -90,17 +90,17 @@ simplifyTerm term = return term -- (LI Ident) - pattern variable -- (EInt Integer) - integer -simplifyAssign :: (Label, Term) -> CnvMonad (Label, Term) +simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm) simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term -simplifyCase :: (Term, Term) -> CnvMonad (Term, Term) +simplifyCase :: (STerm, STerm) -> CnvMonad (STerm, STerm) simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) ------------------------------------------------------------ -- reducing simplified terms, collecting MCF rules -reduceTerm :: LinType -> Path -> Term -> CnvMonad () +reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad () reduceTerm ctype path (Variants terms) = member terms >>= reduceTerm ctype path reduceTerm (StrT) path term = updateLin (path, term) @@ -117,7 +117,7 @@ reduceTerm (TblT ptype vtype) path table ------------------------------------------------------------ -- expanding a term to ground terms -expandTerm :: Term -> CnvMonad Term +expandTerm :: STerm -> CnvMonad STerm expandTerm arg@(Arg nr _ path) = do ctypes <- readArgCTypes pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr @@ -128,14 +128,14 @@ 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 :: (Label, STerm) -> CnvMonad (Label, STerm) expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term ------------------------------------------------------------ -- unification of patterns and selection terms -(=?=) :: Term -> Term -> CnvMonad () +(=?=) :: STerm -> STerm -> CnvMonad () Wildcard =?= _ = return () Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | (lbl, pat) <- precord ] @@ -151,7 +151,7 @@ pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term ------------------------------------------------------------ -- updating the MCF rule -readArgCTypes :: CnvMonad [LinType] +readArgCTypes :: CnvMonad [SLinType] readArgCTypes = do (_, _, _, env) <- readState return env @@ -174,7 +174,7 @@ updateLin (path, term) let lins' = lins ++ map (Lin path) newLins writeState (head, args, lins', env) -term2lins :: Term -> [[Symbol (Cat, Path, Int) Token]] +term2lins :: STerm -> [[Symbol (SCat, SPath, 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) diff --git a/src/GF/Conversion/SimpleToMCFG/Strict.hs b/src/GF/Conversion/SimpleToMCFG/Strict.hs index 17c2293ec..e1fd3ecfa 100644 --- a/src/GF/Conversion/SimpleToMCFG/Strict.hs +++ b/src/GF/Conversion/SimpleToMCFG/Strict.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Date: 2005/04/12 10:49:45 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Converting SimpleGFC grammars to MCFG grammars, deterministic. -- @@ -37,12 +37,12 @@ import GF.Data.SortedList type CnvMonad a = BacktrackM () a -convertGrammar :: SimpleGrammar -> MGrammar +convertGrammar :: SGrammar -> MGrammar convertGrammar rules = tracePrt "Strict conversion: #MCFG rules" (prt . length) $ solutions conversion undefined where conversion = member rules >>= convertRule -convertRule :: SimpleRule -> CnvMonad MRule +convertRule :: SRule -> 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 @@ -59,19 +59,19 @@ convertRule _ = failure ---------------------------------------------------------------------- -- category extraction -extractArg :: [Term] -> (Int, Cat, LinType) -> CnvMonad MCat +extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad MCat extractArg args (nr, cat, ctype) = extractMCat cat ctype (args !! nr) -extractMCat :: Cat -> LinType -> Term -> CnvMonad MCat +extractMCat :: SCat -> SLinType -> STerm -> CnvMonad MCat extractMCat cat ctype term = member $ map (MCat cat) $ parPaths ctype term -enumerateArg :: (Int, Cat, LinType) -> CnvMonad Term +enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm 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 :: [STerm] -> STerm -> STerm substitutePaths arguments = subst where subst (Arg nr _ path) = termFollowPath path (arguments !! nr) subst (con :^ terms) = con :^ map subst terms @@ -87,7 +87,7 @@ substitutePaths arguments = subst ---------------------------------------------------------------------- -- term paths extaction -termPaths :: LinType -> Term -> [(Path, (LinType, Term))] +termPaths :: SLinType -> STerm -> [(SPath, (SLinType, STerm))] termPaths ctype (Variants terms) = terms >>= termPaths ctype termPaths (RecT rtype) (Rec record) = [ (path ++. lbl, value) | @@ -105,19 +105,19 @@ termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ] [p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] -} -parPaths :: LinType -> Term -> [[(Path, Term)]] +parPaths :: SLinType -> STerm -> [[(SPath, STerm)]] parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $ nubsort [ (path, value) | (path, (ConT _ _, value)) <- termPaths ctype term ] -strPaths :: LinType -> Term -> [(Path, Term)] +strPaths :: SLinType -> STerm -> [(SPath, STerm)] 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 :: [MCat] -> (SPath, STerm) -> [Lin MCat MLabel Token] extractLin args (path, term) = map (Lin path) (convertLin term) where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2) convertLin (Empty) = [[]] diff --git a/src/GF/Conversion/Types.hs b/src/GF/Conversion/Types.hs index d6b43bd58..672a57012 100644 --- a/src/GF/Conversion/Types.hs +++ b/src/GF/Conversion/Types.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- All possible instantiations of different grammar formats used in conversion from GFC ----------------------------------------------------------------------------- @@ -14,52 +14,133 @@ module GF.Conversion.Types where -import qualified Ident +import qualified Ident (Ident, wildIdent, isWildIdent) +import qualified AbsGFC (CIdent(..)) 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.Formalism.Utilities import GF.Infra.Print +import GF.Data.Assoc + +import Monad (foldM) + +---------------------------------------------------------------------- +-- * basic (leaf) types + +-- ** input tokens + +type Token = String + +-- ** function names + +type Fun = Ident.Ident +data Name = Name Fun [Profile (SyntaxForest Fun)] + deriving (Eq, Ord, Show) + +name2fun :: Name -> Fun +name2fun (Name fun _) = fun + +-- | A profile is a simple representation of a function on a number of arguments. +-- We only use lists of profiles +data Profile a = Unify [Int] -- ^ The Int's are the argument positions. + -- 'Unify []' will become a metavariable, + -- 'Unify [a,b]' means that the arguments are equal, + | Epsilon a + deriving (Eq, Ord, Show) + +-- | profile application; we need some way of unifying a list of arguments +applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a] +applyProfile unify profile args = map apply profile + where apply (Unify xs) = unify $ map (args !!) xs + apply (Epsilon a) = a + +-- | monadic profile application +applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a] +applyProfileM unify profile args = mapM apply profile + where apply (Unify xs) = unify $ map (args !!) xs + apply (Epsilon a) = return a + +-- | profile composition: +-- +-- > applyProfile u z (ps `composeProfiles` qs) args +-- > == +-- > applyProfile u z ps (applyProfile u z qs args) +-- +-- compare with function composition +-- +-- > (p . q) arg +-- > == +-- > p (q arg) +-- +-- Note that composing an 'Epsilon' with two or more arguments returns an error +-- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need. +composeProfiles :: [Profile a] -> [Profile a] -> [Profile a] +composeProfiles ps qs = map compose ps + where compose (Unify [x]) = qs !! x + compose (Unify xs) = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ] + compose epsilon = epsilon + + + +---------------------------------------------------------------------- +-- * Simple GFC + +type SCat = Ident.Ident + +constr2fun :: Constr -> Fun +constr2fun (AbsGFC.CIQ _ fun) = fun + +-- ** grammar types + +type SGrammar = SimpleGrammar SCat Name Token +type SRule = SimpleRule SCat Name Token + +type SPath = Path SCat Token +type STerm = Term SCat Token +type SLinType = LinType SCat Token +type SDecl = Decl SCat +type SType = Type SCat ---------------------------------------------------------------------- -- * 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 +data MCat = MCat SCat [Constraint] deriving (Eq, Ord, Show) +type MLabel = SPath -type Constraint = (Path, Term) +type Constraint = (SPath, STerm) -initialMCat :: Cat -> MCat +-- ** type coercions etc + +initialMCat :: SCat -> MCat initialMCat cat = MCat cat [] -mcat2cat :: MCat -> Cat -mcat2cat (MCat cat _) = cat +mcat2scat :: MCat -> SCat +mcat2scat (MCat cat _) = cat sameCat :: MCat -> MCat -> Bool -sameCat mc1 mc2 = mcat2cat mc1 == mcat2cat mc2 +sameCat mc1 mc2 = mcat2scat mc1 == mcat2scat mc2 coercionName :: Name -coercionName = Ident.wildIdent +coercionName = Name Ident.wildIdent [Unify [0]] isCoercion :: Name -> Bool -isCoercion = Ident.isWildIdent +isCoercion (Name fun [Unify [0]]) = Ident.isWildIdent fun +isCoercion _ = False ---------------------------------------------------------------------- -- * CFG -type CGrammar = CFGrammar CCat CName Token -type CRule = CFRule CCat CName Token +type CGrammar = CFGrammar CCat Name Token +type CRule = CFRule CCat Name Token data CCat = CCat MCat MLabel deriving (Eq, Ord, Show) -data CName = CName Name Profile - deriving (Eq, Ord, Show) -type Profile = [[Int]] ---------------------------------------------------------------------- -- * pretty-printing @@ -72,8 +153,12 @@ instance Print MCat where instance Print CCat where prt (CCat cat label) = prt cat ++ prt label -instance Print CName where - prt (CName fun args) = prt fun ++ prt args - +instance Print Name where + prt (Name fun profile) = prt fun ++ prt profile + +instance Print a => Print (Profile a) where + prt (Unify []) = "?" + prt (Unify args) = prtSep "=" args + prt (Epsilon a) = prt a diff --git a/src/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs index c783ef744..64ec3bac9 100644 --- a/src/GF/Data/Assoc.hs +++ b/src/GF/Data/Assoc.hs @@ -5,9 +5,9 @@ -- Stability : Stable -- Portability : Haskell 98 -- --- > CVS $Date: 2005/03/29 11:17:54 $ +-- > CVS $Date: 2005/04/12 10:49:45 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ +-- > CVS $Revision: 1.3 $ -- -- Association lists, or finite maps, -- including sets as maps with result type @()@. @@ -81,7 +81,7 @@ lookupWith :: Ord a => b -> Assoc a b -> a -> b ------------------------------------------------------------ data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b) - deriving (Eq, Show) + deriving (Eq, Ord, Show) emptyAssoc = ANil emptySet = emptyAssoc diff --git a/src/GF/Formalism/SimpleGFC.hs b/src/GF/Formalism/SimpleGFC.hs index 78837a975..4091b9fdd 100644 --- a/src/GF/Formalism/SimpleGFC.hs +++ b/src/GF/Formalism/SimpleGFC.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:50 $ +-- > CVS $Date: 2005/04/12 10:49:45 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Simplistic GFC format ----------------------------------------------------------------------------- @@ -23,18 +23,10 @@ import GF.Infra.Print -- * basic (leaf) types -type Name = Ident.Ident -type Cat = Ident.Ident type Constr = AbsGFC.CIdent type Var = Ident.Ident -type Token = String type Label = AbsGFC.Label --- ** type coercions etc - -constr2name :: Constr -> Name -constr2name (AbsGFC.CIQ _ name) = name - anyVar :: Var anyVar = Ident.wildIdent @@ -42,79 +34,80 @@ anyVar = Ident.wildIdent -- * simple GFC -type SimpleGrammar = Grammar Decl Name LinType (Maybe Term) -type SimpleRule = Rule Decl Name LinType (Maybe Term) +type SimpleGrammar c n t = Grammar (Decl c) n (LinType c t) (Maybe (Term c t)) +type SimpleRule c n t = Rule (Decl c) n (LinType c t) (Maybe (Term c t)) -- ** dependent type declarations -data Decl = Var ::: Type - deriving (Eq, Ord, Show) -data Type = Cat :@ [Atom] - deriving (Eq, Ord, Show) -data Atom = ACon Constr - | AVar Var - deriving (Eq, Ord, Show) +data Decl c = Var ::: Type c + deriving (Eq, Ord, Show) +data Type c = c :@ [Atom] + deriving (Eq, Ord, Show) +data Atom = ACon Constr + | AVar Var + deriving (Eq, Ord, Show) -decl2cat :: Decl -> Cat +decl2cat :: Decl c -> c decl2cat (_ ::: (cat :@ _)) = cat -- ** linearization types and terms -data LinType = RecT [(Label, LinType)] - | TblT LinType LinType - | ConT Constr [Term] - | StrT - deriving (Eq, Ord, Show) +data LinType c t = RecT [(Label, LinType c t)] + | TblT (LinType c t) (LinType c t) + | ConT Constr [Term c t] + | StrT + deriving (Eq, Ord, Show) -isBaseType :: LinType -> Bool +isBaseType :: LinType c t -> Bool isBaseType (ConT _ _) = True isBaseType (StrT) = True isBaseType _ = False -data Term = Arg Int Cat Path -- ^ argument variable, the 'Path' is a path - -- pointing into the term - | Constr :^ [Term] -- ^ constructor - | Rec [(Label, Term)] -- ^ record - | Term :. Label -- ^ record projection - | Tbl [(Term, Term)] -- ^ table of patterns\/terms - | Term :! Term -- ^ table selection - | Variants [Term] -- ^ variants - | Term :++ Term -- ^ concatenation - | Token Token -- ^ single token - | Empty -- ^ empty string - | Wildcard -- ^ wildcard pattern variable - | Var Var -- ^ bound pattern variable +data Term c t + = Arg Int c (Path c t) -- ^ argument variable, the 'Path' is a path + -- pointing into the term + | Constr :^ [Term c t] -- ^ constructor + | Rec [(Label, Term c t)] -- ^ record + | Term c t :. Label -- ^ record projection + | Tbl [(Term c t, Term c t)] -- ^ table of patterns\/terms + | Term c t :! Term c t -- ^ table selection + | Variants [Term c t] -- ^ variants + | Term c t :++ Term c t -- ^ concatenation + | Token t -- ^ single token + | Empty -- ^ empty string + | Wildcard -- ^ wildcard pattern variable + | Var Var -- ^ bound pattern variable - -- Res CIdent -- resource identifier - -- Int Integer -- integer + -- Res CIdent -- ^ resource identifier + -- Int Integer -- ^ integer deriving (Eq, Ord, Show) -- ** calculations on terms -(+.) :: Term -> Label -> Term +(+.) :: Term c t -> Label -> Term c t Variants terms +. lbl = variants $ map (+. lbl) terms Rec record +. lbl = maybe err id $ lookup lbl record - where err = error $ "(+.), label not in record: " ++ show (Rec record) ++ " +. " ++ show lbl + where err = error $ "(+.): label not in record" Arg arg cat path +. lbl = Arg arg cat (path ++. lbl) term +. lbl = term :. lbl -(+!) :: Term -> Term -> Term +(+!) :: (Eq c, Eq t) => Term c t -> Term c t -> Term c t Variants terms +! pat = variants $ map (+! pat) terms term +! Variants pats = variants $ map (term +!) pats term +! arg@(Arg _ _ _) = term :! arg Tbl table +! pat = maybe err id $ lookup pat table - where err = error $ "(+!), pattern not in table: " ++ show (Tbl table) ++ " +! " ++ show pat + where err = error $ "(+!): pattern not in table" Arg arg cat path +! pat = Arg arg cat (path ++! pat) term +! pat = term :! pat -(?++) :: Term -> Term -> Term +(?++) :: Term c t -> Term c t -> Term c t Variants terms ?++ term = variants $ map (?++ term) terms term ?++ Variants terms = variants $ map (term ?++) terms Empty ?++ term = term term ?++ Empty = term term1 ?++ term2 = term1 :++ term2 -variants :: [Term] -> Term +variants :: [Term c t] -> Term c t variants terms0 = case concatMap flatten terms0 of [term] -> term terms -> Variants terms @@ -123,7 +116,7 @@ variants terms0 = case concatMap flatten terms0 of -- ** enumerations -enumerateTerms :: Maybe Term -> LinType -> [Term] +enumerateTerms :: (Eq c, Eq t) => Maybe (Term c t) -> LinType c t -> [Term c t] enumerateTerms arg (StrT) = maybe err return arg where err = error "enumeratePatterns: parameter type should not be string" enumerateTerms arg (ConT _ terms) = terms @@ -134,41 +127,41 @@ enumerateTerms arg (TblT ptype ctype) = liftM Tbl $ mapM enumCase $ enumeratePatterns ptype where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype -enumeratePatterns :: LinType -> [Term] +enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t] enumeratePatterns = enumerateTerms Nothing ---------------------------------------------------------------------- -- * paths of record projections and table selections -newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show) +newtype Path c t = Path [Either Label (Term c t)] deriving (Eq, Ord, Show) -emptyPath :: Path +emptyPath :: Path c t emptyPath = Path [] -- ** calculations on paths -(++.) :: Path -> Label -> Path +(++.) :: Path c t -> Label -> Path c t Path path ++. lbl = Path (Left lbl : path) -(++!) :: Path -> Term -> Path +(++!) :: Path c t -> Term c t -> Path c t Path path ++! sel = Path (Right sel : path) -lintypeFollowPath :: Path -> LinType -> LinType +lintypeFollowPath :: Path c t -> LinType c t -> LinType c t lintypeFollowPath (Path path) = follow path where follow [] ctype = ctype follow (Right pat : path) (TblT _ ctype) = follow path ctype follow (Left lbl : path) (RecT rec) = maybe err (follow path) $ lookup lbl rec - where err = error $ "follow: " ++ prt rec ++ " . " ++ prt lbl + where err = error $ "lintypeFollowPath: label not in record type" -termFollowPath :: Path -> Term -> Term +termFollowPath :: (Eq c, Eq t) => Path c t -> Term c t -> Term c t termFollowPath (Path path) = follow (reverse path) where follow [] term = term follow (Right pat : path) term = follow path (term +! pat) follow (Left lbl : path) term = follow path (term +. lbl) -lintype2paths :: Path -> LinType -> [Path] +lintype2paths :: (Eq c, Eq t) => Path c t -> LinType c t -> [Path c t] lintype2paths path (ConT _ _) = [] lintype2paths path (StrT) = [ path ] lintype2paths path (RecT rec) = concat [ lintype2paths (path ++. lbl) ctype | @@ -178,25 +171,25 @@ lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt | ---------------------------------------------------------------------- -instance Print Decl where +instance Print c => Print (Decl c) where prt (var ::: typ) | var == anyVar = prt typ | otherwise = prt var ++ ":" ++ prt typ -instance Print Type where +instance Print c => Print (Type c) where prt (cat :@ ats) = prt cat ++ prtList ats instance Print Atom where prt (ACon con) = prt con prt (AVar var) = "?" ++ prt var -instance Print LinType where +instance (Print c, Print t) => Print (LinType c t) where prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}" prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")" prt (ConT t ts) = prt t ++ "[" ++ prtSep "|" ts ++ "]" prt (StrT) = "Str" -instance Print Term where +instance (Print c, Print t) => Print (Term c t) where prt (Arg n c p) = prt c ++ "@" ++ prt n ++ "(" ++ prt p ++ ")" prt (c :^ []) = prt c prt (c :^ ts) = prt c ++ prtList ts @@ -211,7 +204,7 @@ instance Print Term where prt (term :! sel) = prt term ++ "!" ++ prt sel prt (Var var) = "?" ++ prt var -instance Print Path where +instance (Print c, Print t) => Print (Path c t) where prt (Path path) = concatMap prtEither (reverse path) where prtEither (Left lbl) = "." ++ prt lbl prtEither (Right patt) = "!" ++ prt patt diff --git a/src/GF/Formalism/Symbol.hs b/src/GF/Formalism/Symbol.hs deleted file mode 100644 index 184dd1023..000000000 --- a/src/GF/Formalism/Symbol.hs +++ /dev/null @@ -1,46 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/11 13:52:50 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- Basic type declarations and functions to be used in grammar formalisms ------------------------------------------------------------------------------ - - -module GF.Formalism.Symbol where - -import GF.Infra.Print - ------------------------------------------------------------- --- symbols - -data Symbol c t = Cat c | Tok t - deriving (Eq, Ord, Show) - -symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a -symbol fc ft (Cat cat) = fc cat -symbol fc ft (Tok tok) = ft tok - -mapSymbol :: (c -> d) -> (t -> u) -> Symbol c t -> Symbol d u -mapSymbol fc ft = symbol (Cat . fc) (Tok . ft) - ------------------------------------------------------------- --- pretty-printing - -instance (Print c, Print t) => Print (Symbol c t) where - prt = symbol prt (simpleShow . prt) - where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\"" - mkEsc '\\' = "\\\\" - mkEsc '\"' = "\\\"" - mkEsc '\n' = "\\n" - mkEsc '\t' = "\\t" - mkEsc chr = [chr] - prtList = prtSep " " - - - diff --git a/src/GF/Parsing/CFGrammar.hs b/src/GF/Parsing/CFGrammar.hs deleted file mode 100644 index 03030a5bc..000000000 --- a/src/GF/Parsing/CFGrammar.hs +++ /dev/null @@ -1,153 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CFGrammar --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Definitions of context-free grammars, --- parser information and chart conversion ----------------------------------------------------------------------- - -module GF.Parsing.CFGrammar - (-- * Type definitions - Grammar, - Rule(..), - CFParser, - -- * Parser information - pInfo, - PInfo(..), - -- * Building parse charts - edges2chart, - -- * Grammar checking - checkGrammar - ) where - -import GF.System.Tracing - --- haskell modules: -import Array --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc -import qualified CF --- parser modules: -import GF.Parsing.Utilities -import GF.Printing.PrintParser - - ------------------------------------------------------------- --- type definitions - -type Grammar n c t = [Rule n c t] -data Rule n c t = Rule c [Symbol c t] n - deriving (Eq, Ord, Show) - - -type CFParser n c t = PInfo n c t -> [c] -> Input t -> [Edge (Rule n c t)] --- - - - - - - - - - - - - - - - - - ^^^ possible starting categories - - ------------------------------------------------------------- --- parser information - -pInfo :: (Ord n, Ord c, Ord t) => Grammar n c t -> PInfo n c t - -data PInfo n c t - = PInfo { grammarTokens :: SList t, - nameRules :: Assoc n (SList (Rule n c t)), - topdownRules :: Assoc c (SList (Rule n c t)), - bottomupRules :: Assoc (Symbol c t) (SList (Rule n c t)), - emptyLeftcornerRules :: Assoc c (SList (Rule n c t)), - emptyCategories :: Set c, - cyclicCategories :: SList c, - -- ^^ONLY FOR DIRECT CYCLIC RULES!!! - leftcornerTokens :: Assoc c (SList t) - -- ^^DOES NOT WORK WITH EMPTY RULES!!! - } - --- this is not permanent... -pInfo grammar = pInfo' (filter (not.isCyclic) grammar) - -pInfo' grammar = tracePrt "#parserInfo" prt $ - PInfo grToks nmRules tdRules buRules elcRules emptyCats cyclicCats leftToks - where grToks = union [ nubsort [ tok | Tok tok <- rhs ] | Rule _ rhs _ <- grammar ] - nmRules = accumAssoc id [ (name, rule) | rule@(Rule _ _ name) <- grammar ] - tdRules = accumAssoc id [ (cat, rule) | rule@(Rule cat _ _) <- grammar ] - buRules = accumAssoc id [ (next, rule) | rule@(Rule _ (next:_) _) <- grammar ] - elcRules = accumAssoc id $ limit lc emptyRules - leftToks = accumAssoc id $ limit lc $ - nubsort [ (cat, token) | Rule cat (Tok token:_) _ <- grammar ] - lc (left, res) = nubsort [ (cat, res) | Rule cat _ _ <- buRules ? Cat left ] - emptyRules = nubsort [ (cat, rule) | rule@(Rule cat [] _) <- grammar ] - emptyCats = listSet $ limitEmpties $ map fst emptyRules - limitEmpties es = if es==es' then es else limitEmpties es' - where es' = nubsort [ cat | Rule cat rhs _ <- grammar, - all (symbol (`elem` es) (const False)) rhs ] - cyclicCats = nubsort [ cat | Rule cat [Cat cat'] _ <- grammar, cat == cat' ] - -isCyclic (Rule cat [Cat cat'] _) = cat==cat' -isCyclic _ = False - ------------------------------------------------------------- --- building parse charts - -edges2chart :: (Ord n, Ord c, Ord t) => Input t -> - [Edge (Rule n c t)] -> ParseChart n (Edge c) - ----------- - -edges2chart input edges - = accumAssoc id [ (Edge i k cat, (name, children i k rhs)) | - Edge i k (Rule cat rhs name) <- edges ] - where children i k [] = [ [] | i == k ] - children i k (Tok tok:rhs) = [ rest | i <= k, - j <- (inputFrom input ! i) ? tok, - rest <- children j k rhs ] - children i k (Cat cat:rhs) = [ Edge i j cat : rest | i <= k, - j <- echart ? (i, cat), - rest <- children j k rhs ] - echart = accumAssoc id [ ((i, cat), j) | Edge i j (Rule cat _ _) <- edges ] - - ------------------------------------------------------------- --- grammar checking - -checkGrammar :: (Ord n, Ord c, Ord t, Print n, Print c, Print t) => - Grammar n c t -> [String] - ----------- - -checkGrammar rules = [ "rhs category does not exist: " ++ prt cat ++ "\n" ++ - " in rule: " ++ prt rule | - rule@(Rule _ rhs _) <- rules, - Cat cat <- rhs, cat `notElem` cats ] - where cats = nubsort [ cat | Rule cat _ _ <- rules ] - - ------------------------------------------------------------- --- pretty-printing - -instance (Print n, Print c, Print t) => Print (Rule n c t) where - prt (Rule cat rhs name) = prt name ++ ". " ++ prt cat ++ " -> " ++ prt rhs ++ - (if null rhs then ".\n" else "\n") - prtList = concatMap prt - - -instance (Ord n, Ord c, Ord t) => Print (PInfo n c t) where - prt pI = "[ tokens=" ++ show (length (grammarTokens pI)) ++ - "; names=" ++ sla nameRules ++ - "; tdCats=" ++ sla topdownRules ++ - "; buCats=" ++ sla bottomupRules ++ - "; elcCats=" ++ sla emptyLeftcornerRules ++ - "; eCats=" ++ sla emptyCategories ++ - "; cCats=" ++ show (length (cyclicCategories pI)) ++ - -- "; lctokCats=" ++ sla leftcornerTokens ++ - " ]" - where sla f = show $ length $ aElems $ f pI - - diff --git a/src/GF/Parsing/ConvertFiniteGFC.hs b/src/GF/Parsing/ConvertFiniteGFC.hs deleted file mode 100644 index 2c66209d5..000000000 --- a/src/GF/Parsing/ConvertFiniteGFC.hs +++ /dev/null @@ -1,272 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:58:46 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Calculating the finiteness of each type in a grammar ------------------------------------------------------------------------------ - -module GF.Parsing.ConvertFiniteGFC where - -import Operations -import GFC -import MkGFC -import AbsGFC -import Ident (Ident(..)) -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Data.BacktrackM - -type Cat = Ident -type Name = Ident - -type CnvMonad a = BacktrackM () () a - -convertGrammar :: CanonGrammar -> CanonGrammar -convertGrammar = canon2grammar . convertCanon . grammar2canon - -convertCanon :: Canon -> Canon -convertCanon (Gr modules) = Gr (map (convertModule split) modules) - where split = calcSplitable modules - -convertModule :: Splitable -> Module -> Module -convertModule split (Mod mtyp ext op fl defs) - = Mod mtyp ext op fl newDefs - where newDefs = solutions defMonad () () - defMonad = member defs >>= convertDef split - ----------------------------------------------------------------------- --- the main conversion function -convertDef :: Splitable -> Def -> CnvMonad Def - --- converting abstract "cat" definitions -convertDef split (AbsDCat cat decls cidents) - = case splitableCat split cat of - Just newCats -> do newCat <- member newCats - return $ AbsDCat newCat decls cidents - Nothing -> do (newCat, newDecls) <- expandDecls cat decls - return $ AbsDCat newCat newDecls cidents - where expandDecls cat [] = return (cat, []) - expandDecls cat (decl@(Decl var typ) : decls) - = do (newCat, newDecls) <- expandDecls cat decls - let argCat = resultCat typ - case splitableCat split argCat of - Nothing -> return (newCat, decl : newDecls) - Just newArgs -> do newArg <- member newArgs - return (mergeArg newCat newArg, newDecls) - --- converting abstract "fun" definitions -convertDef split (AbsDFun fun typ@(EAtom (AC (CIQ mod cat))) def) - = case splitableFun split fun of - Just newCat -> return (AbsDFun fun (EAtom (AC (CIQ mod newCat))) def) - Nothing -> do newTyp <- expandType split [] typ - return (AbsDFun fun newTyp def) -convertDef split (AbsDFun fun typ def) - = do newTyp <- expandType split [] typ - return (AbsDFun fun newTyp def) - --- converting concrete "lincat" definitions --- convertDef split ( - -convertDef _ def = return def - ----------------------------------------------------------------------- --- expanding type expressions -expandType :: Splitable -> [(Ident, Cat)] -> Exp -> CnvMonad Exp -expandType split env (EProd x a@(EAtom (AC (CIQ mod cat))) b) - = case splitableCat split cat of - Nothing -> do b' <- expandType split env b - return (EProd x a b') - Just newCats -> do newCat <- member newCats - b' <- expandType split ((x,newCat):env) b - return (EProd x (EAtom (AC (CIQ mod newCat))) b') -expandType split env (EProd x a b) - = do a' <- expandType split env a - b' <- expandType split env b - return (EProd x a' b') -expandType split env app - = expandApp split env [] app - -expandApp :: Splitable -> [(Ident, Cat)] -> [Cat] -> Exp -> CnvMonad Exp -expandApp split env addons (EAtom (AC (CIQ mod cat))) - = return (EAtom (AC (CIQ mod (foldl mergeArg cat addons)))) -expandApp split env addons (EApp exp arg@(EAtom (AC (CIQ mod fun)))) - = case splitableFun split fun of - Just newCat -> expandApp split env (newCat:addons) exp - Nothing -> do exp' <- expandApp split env addons exp - return (EApp exp' arg) -expandApp split env addons (EApp exp arg@(EAtom (AV x))) - = case lookup x env of - Just newCat -> expandApp split env (newCat:addons) exp - Nothing -> do exp' <- expandApp split env addons exp - return (EApp exp' arg) - ----------------------------------------------------------------------- --- 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 :: [Module] -> Splitable -calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns) - where splitableCats = tracePrt "splitableCats" (prtSep " ") $ - groupPairs $ nubsort - [ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ] - - splitableFuns = tracePrt "splitableFuns" (prtSep " ") $ - nubsort - [ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ] - - constantCats = tracePrt "constantCats" (prtSep " ") $ - [ (cat, fun) | - AbsDFun fun (EAtom (AC (CIQ _ cat))) _ <- absDefs, - dependentConstants ?= cat ] - - dependentConstants = listSet $ - tracePrt "dep consts" prt $ - dependentCats <\\> funCats - - funCats = tracePrt "fun cats" prt $ - nubsort [ resultCat typ | - AbsDFun _ typ@(EProd _ _ _) _ <- absDefs ] - - dependentCats = tracePrt "dep cats" prt $ - nubsort [ cat | AbsDCat _ decls _ <- absDefs, - Decl _ (EAtom (AC (CIQ _ cat))) <- decls ] - - absDefs = concat [ defs | Mod (MTAbs _) _ _ _ defs <- modules ] - - ----------------------------------------------------------------------- --- utilities - --- the main result category of a type expression -resultCat :: Exp -> Cat -resultCat (EProd _ _ b) = resultCat b -resultCat (EApp a _) = resultCat a -resultCat (EAtom (AC (CIQ _ cat))) = cat - --- 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 "" "" "" - ----------------------------------------------------------------------- --- obsolete? - -{- -type FiniteCats = Assoc Cat Integer - -calculateFiniteness :: Canon -> FiniteCats -calculateFiniteness canon@(Gr modules) - = trace2 "#typeInfo" (prt tInfo) $ - finiteCats - - where finiteCats = listAssoc [ (cat, fin) | (cat, Just fin) <- finiteInfo ] - finiteInfo = map finInfo groups - - finInfo :: (Cat, [[Cat]]) -> (Cat, Maybe Integer) - finInfo (cat, ctxts) - | cyclicCats ?= cat = (cat, Nothing) - | otherwise = (cat, fmap (sum . map product) $ - sequence (map (sequence . map lookFinCat) ctxts)) - - lookFinCat :: Cat -> Maybe Integer - lookFinCat cat = maybe (error "lookFinCat: Nothing") id $ - lookup cat finiteInfo - - cyclicCats :: Set Cat - cyclicCats = listSet $ - tracePrt "cyclic cats" prt $ - union $ map nubsort $ cyclesIn dependencies - - dependencies :: [(Cat, [Cat])] - dependencies = tracePrt "dependencies" (prtAfter "\n") $ - mapSnd (union . nubsort) groups - - groups :: [(Cat, [[Cat]])] - groups = tracePrt "groups" (prtAfter "\n") $ - mapSnd (map snd) $ groupPairs (nubsort allFuns) - - allFuns = tracePrt "all funs" (prtAfter "\n") $ - [ (cat, (fun, ctxt)) | - Mod (MTAbs _) _ _ _ defs <- modules, - AbsDFun fun typ _ <- defs, - let (cat, ctxt) = err error id $ typeForm typ ] - - tInfo = calculateTypeInfo 30 finiteCats (splitDefs canon) - --- | stolen from 'Macros.qTypeForm', converted to GFC, and severely simplified -typeForm :: Monad m => Exp -> m (Cat, [Cat]) -typeForm t = case t of - EProd x a b -> do - (cat, ctxt) <- typeForm b - a' <- stripType a - return (cat, a':ctxt) - EApp c a -> do - (cat, _) <- typeForm c - return (cat, []) - EAtom (AC (CIQ _ con)) -> - return (con, []) - _ -> - fail $ "no normal form of type: " ++ prt t - -stripType :: Monad m => Exp -> m Cat -stripType (EApp c a) = stripType c -stripType (EAtom (AC (CIQ _ con))) = return con -stripType t = fail $ "can't strip type: " ++ prt t - -mapSnd f xs = [ (a, f b) | (a, b) <- xs ] --} - ----------------------------------------------------------------------- --- obsolete? - -{- -type SplitDefs = ([Def], [Def], [Def], [Def]) ------ AbsDCat AbsDFun CncDCat CncDFun - -splitDefs :: Canon -> SplitDefs -splitDefs (Gr modules) = foldr splitDef ([], [], [], []) $ - concat [ defs | Mod _ _ _ _ defs <- modules ] - -splitDef :: Def -> SplitDefs -> SplitDefs -splitDef ac@(AbsDCat _ _ _) (acs, afs, ccs, cfs) = (ac:acs, afs, ccs, cfs) -splitDef af@(AbsDFun _ _ _) (acs, afs, ccs, cfs) = (acs, af:afs, ccs, cfs) -splitDef cc@(CncDCat _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, cc:ccs, cfs) -splitDef cf@(CncDFun _ _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, ccs, cf:cfs) -splitDef _ sd = sd - ---calculateTypeInfo :: Integer -> FiniteCats -> SplitDefs -> ? -calculateTypeInfo maxFin allFinCats (acs, afs, ccs, cfs) - = (depCatsToExpand, catsToSplit) - where absDefsToExpand = tracePrt "absDefsToExpand" prt $ - [ ((cat, fin), cats) | - AbsDCat cat args _ <- acs, - not (null args), - cats <- mapM catOfDecl args, - fin <- lookupAssoc allFinCats cat, - fin <= maxFin - ] - (depCatsToExpand, argsCats') = unzip absDefsToExpand - catsToSplit = union (map nubsort argsCats') - catOfDecl (Decl _ exp) = err fail return $ stripType exp --} diff --git a/src/GF/Parsing/ConvertGFCtoMCFG.hs b/src/GF/Parsing/ConvertGFCtoMCFG.hs deleted file mode 100644 index 632443d67..000000000 --- a/src/GF/Parsing/ConvertGFCtoMCFG.hs +++ /dev/null @@ -1,34 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- All different conversions from GFC to MCFG ------------------------------------------------------------------------------ - - -module GF.Parsing.ConvertGFCtoMCFG - (convertGrammar) where - -import GFC (CanonGrammar) -import GF.Parsing.GrammarTypes -import Ident (Ident(..)) -import Option -import GF.System.Tracing - -import qualified GF.Parsing.ConvertGFCtoMCFG.Old as Old -import qualified GF.Parsing.ConvertGFCtoMCFG.Nondet as Nondet -import qualified GF.Parsing.ConvertGFCtoMCFG.Strict as Strict -import qualified GF.Parsing.ConvertGFCtoMCFG.Coercions as Coerce - -convertGrammar :: String -> (CanonGrammar, Ident) -> MCFGrammar -convertGrammar "nondet" = Coerce.addCoercions . Nondet.convertGrammar -convertGrammar "strict" = Strict.convertGrammar -convertGrammar "old" = Old.convertGrammar - diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs deleted file mode 100644 index 81328ad15..000000000 --- a/src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs +++ /dev/null @@ -1,71 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Coercions --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:55 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Adding coercion functions to a MCFG if necessary. ------------------------------------------------------------------------------ - - -module GF.Parsing.ConvertGFCtoMCFG.Coercions (addCoercions) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import qualified Ident -import GF.Parsing.Utilities -import GF.Parsing.GrammarTypes -import GF.Parsing.MCFGrammar (Rule(..), Lin(..)) -import GF.Data.SortedList -import List (groupBy) -- , transpose) - ----------------------------------------------------------------------- - -addCoercions :: MCFGrammar -> MCFGrammar -addCoercions rules = coercions ++ rules - where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | - Rule head args lins _ <- rules, - let lbls = [ lbl | Lin lbl _ <- lins ] ] - allHeadSet = nubsort allHeads - allArgSet = union allArgs <\\> map fst allHeadSet - coercions = tracePrt "#coercions total" (prt . length) $ - concat $ - tracePrt "#coercions per cat" (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 (mainCat $ fst $ head heads) (mainCat $ head args) of - LT -> combineCoercions allHeads allArgs' - GT -> combineCoercions allHeads' allArgs - EQ -> makeCoercion heads args : combineCoercions allHeads allArgs - - -makeCoercion heads args = [ Rule arg [head] lins coercionName | - (head@(MCFCat _ headCns), lbls) <- heads, - let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], - arg@(MCFCat _ argCns) <- args, - argCns `subset` headCns ] - - -coercionName = Ident.IW - -mainCat (MCFCat c _) = c - -sameCat mc1 mc2 = mainCat mc1 == mainCat mc2 - - diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs deleted file mode 100644 index d6ac60ec0..000000000 --- a/src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs +++ /dev/null @@ -1,280 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Nondet --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:55 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Converting GFC grammars to MCFG grammars, nondeterministically. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. --- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) ------------------------------------------------------------------------------ - - -module GF.Parsing.ConvertGFCtoMCFG.Nondet (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import Monad -import Ident (Ident(..)) -import AbsGFC -import GFC -import Look -import Operations -import qualified Modules as M -import CMacros (defLinType) -import MkGFC (grammar2canon) -import GF.Parsing.Utilities -import GF.Parsing.GrammarTypes -import GF.Parsing.MCFGrammar (Grammar, Rule(..), Lin(..)) -import GF.Data.SortedList --- import Maybe (listToMaybe) -import List (groupBy) -- , transpose) - -import GF.Data.BacktrackM - ----------------------------------------------------------------------- - -type GrammarEnv = (CanonGrammar, Ident) - -convertGrammar :: GrammarEnv -- ^ the canonical grammar, together with the selected language - -> MCFGrammar -- ^ the resulting MCF grammar -convertGrammar gram = trace2 "language" (prt (snd gram)) $ - trace2 "modules" (prtSep " " modnames) $ - tracePrt "#mcf-rules total" (prt . length) $ - solutions conversion gram undefined - where Gr modules = grammar2canon (fst gram) - modnames = uncurry M.allExtends gram - conversion = member modules >>= convertModule - convertModule (Mod (MTCnc modname _) _ _ _ defs) - | modname `elem` modnames = member defs >>= convertDef - convertModule _ = failure - -convertDef :: Def -> CnvMonad MCFRule -convertDef (CncDFun fun (CIQ _ cat) args term _) - | trace2 "converting function" (prt fun) True - = do let iCat : iArgs = map initialMCat (cat : map catOfArg args) - writeState (iCat, iArgs, []) - convertTerm cat term - (newCat, newArgs, linRec) <- readState - let newTerm = map (instLin newArgs) linRec - traceDot $ - return (Rule newCat newArgs newTerm fun) -convertDef _ = failure - -instLin newArgs (Lin lbl lin) = Lin lbl (map instSym lin) - where instSym = mapSymbol instCat id - instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg) - -convertTerm :: Cat -> Term -> CnvMonad () -convertTerm cat term = do rterm <- simplifyTerm term - env <- readEnv - let ctype = lookupCType env cat - reduce ctype rterm emptyPath - ------------------------------------------------------------- - -type CnvMonad a = BacktrackM GrammarEnv CMRule a - -type CMRule = (MCFCat, [MCFCat], LinRec) -type LinRec = [Lin Cat Path Tokn] - -initialMCat :: Cat -> MCFCat -initialMCat cat = MCFCat cat [] - ----------------------------------------------------------------------- - -simplifyTerm :: Term -> CnvMonad STerm -simplifyTerm (Arg (A cat nr)) = return (SArg (fromInteger nr) cat emptyPath) -simplifyTerm (Con con terms) = liftM (SCon con) $ mapM simplifyTerm terms -simplifyTerm (R record) = liftM SRec $ mapM simplifyAssign record -simplifyTerm (P term lbl) = liftM (+. lbl) $ simplifyTerm term -simplifyTerm (T ct table) = liftM STbl $ sequence $ concatMap simplifyCase table -simplifyTerm (V ct terms) - = do env <- readEnv - liftM STbl $ sequence [ liftM ((,) pat) (simplifyTerm term) | - (pat, term) <- zip (groundTerms env ct) terms ] -simplifyTerm (S term sel) - = do sterm <- simplifyTerm term - ssel <- simplifyTerm sel - case sterm of - STbl table -> do (pat, val) <- member table - pat =?= ssel - return val - _ -> do sel' <- expandTerm ssel - return (sterm +! sel') -simplifyTerm (FV terms) = liftM SVariants $ mapM simplifyTerm terms -simplifyTerm (term1 `C` term2) = liftM2 (SConcat) (simplifyTerm term1) (simplifyTerm term2) -simplifyTerm (K tokn) = return $ SToken tokn -simplifyTerm (E) = return $ SEmpty -simplifyTerm x = error $ "simplifyTerm: " ++ show x --- error constructors: --- (I CIdent) - from resource --- (LI Ident) - pattern variable --- (EInt Integer) - integer - -simplifyAssign :: Assign -> CnvMonad (Label, STerm) -simplifyAssign (Ass lbl term) = liftM ((,) lbl) $ simplifyTerm term - -simplifyCase :: Case -> [CnvMonad (STerm, STerm)] -simplifyCase (Cas pats term) = [ liftM2 (,) (simplifyPattern pat) (simplifyTerm term) | - pat <- pats ] - -simplifyPattern :: Patt -> CnvMonad STerm -simplifyPattern (PC con pats) = liftM (SCon con) $ mapM simplifyPattern pats -simplifyPattern (PW) = return SWildcard -simplifyPattern (PR record) = do record' <- mapM simplifyPattAssign record - case filter (\row -> snd row /= SWildcard) record' of - [] -> return SWildcard - record'' -> return (SRec record') -simplifyPattern x = error $ "simplifyPattern: " ++ show x --- error constructors: --- (PV Ident) - pattern variable - -simplifyPattAssign :: PattAssign -> CnvMonad (Label, STerm) -simplifyPattAssign (PAss lbl pat) = liftM ((,) lbl) $ simplifyPattern pat - - ------------------------------------------------------------- --- reducing simplified terms, collecting mcf rules - -reduce :: CType -> STerm -> Path -> CnvMonad () -reduce TStr term path = updateLin (path, term) -reduce (Cn _) term path - = do pat <- expandTerm term - updateHead (path, pat) -reduce ctype (SVariants terms) path - = do term <- member terms - reduce ctype term path -reduce (RecType rtype) term path - = sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) | - Lbg lbl ctype <- rtype ] -reduce (Table _ ctype) (STbl table) path - = sequence_ [ reduce ctype term (path ++! pat) | - (pat, term) <- table ] -reduce (Table ptype vtype) arg@(SArg _ _ _) path - = do env <- readEnv - sequence_ [ reduce vtype (arg +! pat) (path ++! pat) | - pat <- groundTerms env ptype ] -reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++ - ")\n term = (" ++ show term ++ - ")\n path = (" ++ show path ++ ")\n") - - ------------------------------------------------------------- --- expanding a term to ground terms - -expandTerm :: STerm -> CnvMonad STerm -expandTerm arg@(SArg _ _ _) - = do env <- readEnv - pat <- member $ groundTerms env $ cTypeForArg env arg - pat =?= arg - return pat -expandTerm (SCon con terms) = liftM (SCon con) $ mapM expandTerm terms -expandTerm (SRec record) = liftM SRec $ mapM expandAssign record -expandTerm (SVariants terms) = member terms >>= expandTerm -expandTerm term = error $ "expandTerm: " ++ show term - -expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm) -expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term - ------------------------------------------------------------- --- unification of patterns and selection terms - -(=?=) :: STerm -> STerm -> CnvMonad () -SWildcard =?= _ = return () -SRec precord =?= arg@(SArg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | - (lbl, pat) <- precord ] -pat =?= SArg arg _ path = updateArg arg (path, pat) -SCon con pats =?= SCon con' terms = do guard (con==con' && length pats==length terms) - sequence_ $ zipWith (=?=) pats terms -SRec precord =?= SRec record = sequence_ [ maybe mzero (pat =?=) mterm | - (lbl, pat) <- precord, - let mterm = lookup lbl record ] -pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term - - ------------------------------------------------------------- --- updating the mcf rule - -updateArg :: Int -> Constraint -> CnvMonad () -updateArg arg cn - = do (head, args, lins) <- readState - args' <- updateNth (addToMCFCat cn) arg args - writeState (head, args', lins) - -updateHead :: Constraint -> CnvMonad () -updateHead cn - = do (head, args, lins) <- readState - head' <- addToMCFCat cn head - writeState (head', args, lins) - -updateLin :: Constraint -> CnvMonad () -updateLin (path, term) - = do let newLins = term2lins term - (head, args, lins) <- readState - let lins' = lins ++ map (Lin path) newLins - writeState (head, args, lins') - -term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]] -term2lins (SArg arg cat path) = return [Cat (cat, path, arg)] -term2lins (SToken str) = return [Tok str] -term2lins (SConcat t1 t2) = liftM2 (++) (term2lins t1) (term2lins t2) -term2lins (SEmpty) = return [] -term2lins (SVariants terms) = terms >>= term2lins -term2lins term = error $ "term2lins: " ++ show term - -addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat -addToMCFCat cn (MCFCat cat cns) = liftM (MCFCat 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) - -catOfArg (A aCat _) = aCat -catOfArg (AB aCat _ _) = aCat - -lookupCType :: GrammarEnv -> Cat -> CType -lookupCType env cat = errVal defLinType $ - lookupLincat (fst env) (CIQ (snd env) cat) - -groundTerms :: GrammarEnv -> CType -> [STerm] -groundTerms env ctype = err error (map term2spattern) $ - allParamValues (fst env) ctype - -cTypeForArg :: GrammarEnv -> STerm -> CType -cTypeForArg env (SArg nr cat (Path path)) - = follow path $ lookupCType env cat - where follow [] ctype = ctype - follow (Right pat : path) (Table _ ctype) = follow path ctype - follow (Left lbl : path) (RecType rec) - = case [ ctype | Lbg lbl' ctype <- rec, lbl == lbl' ] of - [ctype] -> follow path ctype - err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ - " results in " ++ show err - -term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ] -term2spattern (Con con terms) = SCon con $ map term2spattern terms - diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Old.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Old.hs deleted file mode 100644 index 826fcdc39..000000000 --- a/src/GF/Parsing/ConvertGFCtoMCFG/Old.hs +++ /dev/null @@ -1,277 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Old --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:55 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- Converting GFC grammars to MCFG grammars. (Old variant) --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. --- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) ------------------------------------------------------------------------------ - - -module GF.Parsing.ConvertGFCtoMCFG.Old (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm ---import PrintGFC -import qualified PrGrammar as PG - -import Monad (liftM, liftM2, guard) --- import Maybe (listToMaybe) -import Ident (Ident(..)) -import AbsGFC -import GFC -import Look -import Operations -import qualified Modules as M -import CMacros (defLinType) -import MkGFC (grammar2canon) -import GF.Parsing.Utilities -import GF.Parsing.GrammarTypes -import GF.Parsing.MCFGrammar (Rule(..), Lin(..)) -import GF.Data.SortedList (nubsort, groupPairs) -import Maybe (listToMaybe) -import List (groupBy, transpose) - ----------------------------------------------------------------------- --- old style types - -data XMCFCat = XMCFCat Cat [(XPath, Term)] deriving (Eq, Ord, Show) -type XMCFLabel = XPath - -cnvXMCFCat :: XMCFCat -> MCFCat -cnvXMCFCat (XMCFCat cat constrs) = MCFCat cat [ (cnvXPath path, cnvTerm term) | - (path, term) <- constrs ] - -cnvXMCFLabel :: XMCFLabel -> MCFLabel -cnvXMCFLabel = cnvXPath - -cnvXMCFLin :: Lin XMCFCat XMCFLabel Tokn -> Lin MCFCat MCFLabel Tokn -cnvXMCFLin (Lin lbl lin) = Lin (cnvXMCFLabel lbl) $ - map (mapSymbol cnvSym id) lin - where cnvSym (cat, lbl, nr) = (cnvXMCFCat cat, cnvXMCFLabel lbl, nr) - --- Term -> STerm - -cnvTerm (R rec) = SRec [ (lbl, cnvTerm term) | Ass lbl term <- rec ] -cnvTerm (T _ tbl) = STbl [ (cnvPattern pat, cnvTerm term) | - Cas pats term <- tbl, pat <- pats ] -cnvTerm (Con con terms) = SCon con $ map cnvTerm terms -cnvTerm term - | isArgPath term = cnvArgPath term - -cnvPattern (PR rec) = SRec [ (lbl, cnvPattern term) | PAss lbl term <- rec ] -cnvPattern (PC con pats) = SCon con $ map cnvPattern pats -cnvPattern (PW) = SWildcard - -isArgPath (Arg _) = True -isArgPath (P _ _) = True -isArgPath (S _ _) = True -isArgPath _ = False - -cnvArgPath (Arg (A cat nr)) = SArg (fromInteger nr) cat emptyPath -cnvArgPath (term `P` lbl) = cnvArgPath term +. lbl -cnvArgPath (term `S` sel) = cnvArgPath term +! cnvTerm sel - --- old style paths - -newtype XPath = XPath [Either Label Term] deriving (Eq, Ord, Show) - -cnvXPath :: XPath -> Path -cnvXPath (XPath path) = Path (map (either Left (Right . cnvTerm)) (reverse path)) - -emptyXPath :: XPath -emptyXPath = XPath [] - -(++..) :: XPath -> Label -> XPath -XPath path ++.. lbl = XPath (Left lbl : path) - -(++!!) :: XPath -> Term -> XPath -XPath path ++!! sel = XPath (Right sel : path) - ----------------------------------------------------------------------- - --- | combining alg. 1 and alg. 2 from Ljunglöf's PhD thesis -convertGrammar :: (CanonGrammar, Ident) -> MCFGrammar -convertGrammar (gram, lng) = trace2 "language" (prt lng) $ - trace2 "modules" (prtSep " " modnames) $ - trace2 "#lin-terms" (prt (length cncdefs)) $ - tracePrt "#mcf-rules total" (prt.length) $ - concat $ - tracePrt "#mcf-rules per fun" - (\rs -> concat [" "++show n++"="++show (length r) | - (n, r) <- zip [1..] rs]) $ - map (convertDef gram lng) cncdefs - where Gr mods = grammar2canon gram - cncdefs = [ def | Mod (MTCnc modname _) _ _ _ defs <- mods, - modname `elem` modnames, - def@(CncDFun _ _ _ _ _) <- defs ] - modnames = M.allExtends gram lng - - -convertDef :: CanonGrammar -> Ident -> Def -> [MCFRule] -convertDef gram lng (CncDFun fun (CIQ _ cat) args term _) - = [ Rule (cnvXMCFCat newCat) (map cnvXMCFCat newArgs) (map cnvXMCFLin newTerm) fun | - let ctype = lookupCType gram lng cat, - instArgs <- mapM (enumerateInsts gram lng) args, - let instTerm = substitutePaths gram lng instArgs term, - newCat <- emcfCat gram lng cat instTerm, - newArgs <- mapM (extractArg gram lng instArgs) args, - let newTerm = concatMap (extractLin newArgs) $ strPaths gram lng ctype instTerm - ] - - --- gammalt skräp: --- mergeArgs = zipWith mergeRec --- mergeRec (R r1) (R r2) = R (r1 ++ r2) - -extractArg :: CanonGrammar -> Ident -> [Term] -> ArgVar -> [XMCFCat] -extractArg gram lng args (A cat nr) = emcfCat gram lng cat (args !!! nr) - - -emcfCat :: CanonGrammar -> Ident -> Ident -> Term -> [XMCFCat] -emcfCat gram lng cat = map (XMCFCat cat) . parPaths gram lng (lookupCType gram lng cat) - - -extractLin :: [XMCFCat] -> (XPath, Term) -> [Lin XMCFCat XMCFLabel Tokn] -extractLin args (path, term) = map (Lin path) (convertLin term) - where convertLin (t1 `C` t2) = liftM2 (++) (convertLin t1) (convertLin t2) - convertLin (E) = [[]] - convertLin (K tok) = [[Tok tok]] - convertLin (FV terms) = concatMap convertLin terms - convertLin term = map (return . Cat) $ flattenTerm emptyXPath term - flattenTerm path (Arg (A _ nr)) = [(args !!! nr, path, fromInteger nr)] - flattenTerm path (term `P` lbl) = flattenTerm (path ++.. lbl) term - flattenTerm path (term `S` sel) = flattenTerm (path ++!! sel) term - flattenTerm path (FV terms) = concatMap (flattenTerm path) terms - flattenTerm path term = error $ "flattenTerm: \n " ++ show path ++ "\n " ++ prt term - - -enumerateInsts :: CanonGrammar -> Ident -> ArgVar -> [Term] -enumerateInsts gram lng arg@(A argCat _) = enumerate (Arg arg) (lookupCType gram lng argCat) - where enumerate path (TStr) = [ path ] - enumerate path (Cn con) = okError $ lookupParamValues gram con - enumerate path (RecType r) - = map R $ sequence [ map (lbl `Ass`) $ - enumerate (path `P` lbl) ctype | - lbl `Lbg` ctype <- r ] - enumerate path (Table s t) - = map (T s) $ sequence [ map ([term2pattern sel] `Cas`) $ - enumerate (path `S` sel) t | - sel <- enumerate (error "enumerate") s ] - - - -termPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, (CType, Term))] -termPaths gr l (TStr) term = [ (emptyXPath, (TStr, term)) ] -termPaths gr l (RecType rtype) (R record) - = [ (path ++.. lbl, value) | - lbl `Ass` term <- record, - let ctype = okError $ maybeErr "termPaths/record" $ lookupLabelling lbl rtype, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l (Table _ ctype) (T _ table) - = [ (path ++!! pattern2term pat, value) | - pats `Cas` term <- table, pat <- pats, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l (Table _ ctype) (V ptype table) - = [ (path ++!! pat, value) | - (pat, term) <- zip (okError $ allParamValues gr ptype) table, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l ctype (FV terms) - = concatMap (termPaths gr l ctype) terms -termPaths gr l (Cn pc) term = [ (emptyXPath, (Cn pc, 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 :: CanonGrammar -> Ident -> CType -> Term -> [[(XPath, Term)]] -parPaths gr l ctype term = mapM (uncurry (map . (,))) (groupPairs paths) - where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths gr l ctype term ] - -strPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, Term)] -strPaths gr l ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] - where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths gr l ctype term ] - - --- Substitute each instantiated parameter path for its instantiation -substitutePaths :: CanonGrammar -> Ident -> [Term] -> Term -> Term -substitutePaths gr l arguments trm = subst trm - where subst (con `Con` terms) = con `Con` map subst terms - subst (R record) = R $ map substAss record - subst (term `P` lbl) = subst term `evalP` lbl - subst (T ptype table) = T ptype $ map substCas table - subst (V ptype table) = T ptype [ [term2pattern pat] `Cas` subst term | - (pat, term) <- zip (okError $ allParamValues gr ptype) table ] - subst (term `S` select) = subst term `evalS` subst select - subst (term `C` term') = subst term `C` subst term' - subst (FV terms) = evalFV $ map subst terms - subst (Arg (A _ arg)) = arguments !!! arg - subst term = term - - substAss (l `Ass` term) = l `Ass` subst term - substCas (p `Cas` term) = p `Cas` subst term - - -evalP (R record) lbl = okError $ maybeErr errStr $ lookupAssign lbl record - where errStr = "evalP: " ++ prt (R record `P` lbl) -evalP (FV terms) lbl = evalFV [ evalP term lbl | term <- terms ] -evalP term lbl = term `P` lbl - -evalS t@(T _ tbl) sel = maybe (t `S` sel) id $ lookupCase sel tbl -evalS (FV terms) sel = evalFV [ term `evalS` sel | term <- terms ] -evalS term (FV sels)= evalFV [ term `evalS` sel | sel <- sels ] -evalS term sel = term `S` sel - -evalFV terms0 = case nubsort (concatMap flattenFV terms0) of - [term] -> term - terms -> FV terms - where flattenFV (FV ts) = ts - flattenFV t = [t] - - ----------------------------------------------------------------------- --- utilities - --- lookup a CType for an Ident -lookupCType :: CanonGrammar -> Ident -> Ident -> CType -lookupCType gr lng c = errVal defLinType $ lookupLincat gr (CIQ lng c) - --- lookup a label in a (record / record ctype / table) -lookupAssign :: Label -> [Assign] -> Maybe Term -lookupLabelling :: Label -> [Labelling] -> Maybe CType -lookupCase :: Term -> [Case] -> Maybe Term - -lookupAssign lbl rec = listToMaybe [ term | lbl' `Ass` term <- rec, lbl == lbl' ] -lookupLabelling lbl rtyp = listToMaybe [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] -lookupCase sel tbl = listToMaybe [ term | pats `Cas` term <- tbl, sel `matchesPats` pats ] - -matchesPats :: Term -> [Patt] -> Bool -matchesPats term patterns = or [ term == pattern2term pattern | pattern <- patterns ] - --- converting between patterns and terms -pattern2term :: Patt -> Term -term2pattern :: Term -> Patt - -pattern2term (con `PC` patterns) = con `Con` map pattern2term patterns -pattern2term (PR record) = R [ lbl `Ass` pattern2term pattern | - lbl `PAss` pattern <- record ] - -term2pattern (con `Con` terms) = con `PC` map term2pattern terms -term2pattern (R record) = PR [ lbl `PAss` term2pattern term | - lbl `Ass` term <- record ] - --- list lookup for Integers instead of Ints -(!!!) :: [a] -> Integer -> a -xs !!! n = xs !! fromInteger n diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs deleted file mode 100644 index 6e2e62cdd..000000000 --- a/src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs +++ /dev/null @@ -1,195 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Strict --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:55 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Converting GFC grammars to MCFG grammars, nondeterministically. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. --- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) ------------------------------------------------------------------------------ - - -module GF.Parsing.ConvertGFCtoMCFG.Strict (convertGrammar) where - -import GF.System.Tracing --- import IOExts (unsafePerformIO) -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import Monad -import Ident (Ident(..)) -import AbsGFC -import GFC -import Look -import Operations -import qualified Modules as M -import CMacros (defLinType) -import MkGFC (grammar2canon) -import GF.Parsing.Utilities -import GF.Parsing.GrammarTypes -import GF.Parsing.MCFGrammar (Grammar, Rule(..), Lin(..)) -import GF.Data.SortedList --- import Maybe (listToMaybe) -import List (groupBy) -- , transpose) - -import GF.Data.BacktrackM - ----------------------------------------------------------------------- - -type GrammarEnv = (CanonGrammar, Ident) - -convertGrammar :: GrammarEnv -- ^ the canonical grammar, together with the selected language - -> MCFGrammar -- ^ the resulting MCF grammar -convertGrammar gram = trace2 "language" (prt (snd gram)) $ - trace2 "modules" (prtSep " " modnames) $ - tracePrt "#mcf-rules total" (prt . length) $ - solutions conversion gram undefined - where Gr modules = grammar2canon (fst gram) - modnames = uncurry M.allExtends gram - conversion = member modules >>= convertModule - convertModule (Mod (MTCnc modname _) _ _ _ defs) - | modname `elem` modnames = member defs >>= convertDef - convertModule _ = failure - -convertDef :: Def -> CnvMonad MCFRule -convertDef (CncDFun fun (CIQ _ cat) args term _) - | trace2 "converting function" (prt fun) True - = do env <- readEnv - let ctype = lookupCType env cat - instArgs <- mapM enumerateArg args - let instTerm = substitutePaths env instArgs term - newCat <- emcfCat cat instTerm - newArgs <- mapM (extractArg instArgs) args - let newTerm = strPaths env ctype instTerm >>= extractLin newArgs - traceDot $ - return (Rule newCat newArgs newTerm fun) -convertDef _ = failure - ------------------------------------------------------------- - -type CnvMonad a = BacktrackM GrammarEnv () a - ----------------------------------------------------------------------- --- strict conversion - -extractArg :: [STerm] -> ArgVar -> CnvMonad MCFCat -extractArg args (A cat nr) = emcfCat cat (args !! fromInteger nr) - -emcfCat :: Cat -> STerm -> CnvMonad MCFCat -emcfCat cat term = do env <- readEnv - member $ map (MCFCat cat) $ parPaths env (lookupCType env cat) term - -enumerateArg :: ArgVar -> CnvMonad STerm -enumerateArg (A cat nr) = do env <- readEnv - let ctype = lookupCType env cat - enumerate (SArg (fromInteger nr) cat emptyPath) ctype - where enumerate arg (TStr) = return arg - enumerate arg ctype@(Cn _) = do env <- readEnv - member $ groundTerms env ctype - enumerate arg (RecType rtype) - = liftM SRec $ sequence [ liftM ((,) lbl) $ - enumerate (arg +. lbl) ctype | - lbl `Lbg` ctype <- rtype ] - enumerate arg (Table stype ctype) - = do env <- readEnv - state <- readState - liftM STbl $ sequence [ liftM ((,) sel) $ - enumerate (arg +! sel) ctype | - sel <- solutions (enumerate err stype) env state ] - where err = error "enumerate: parameter type should not be string" - --- Substitute each instantiated parameter path for its instantiation -substitutePaths :: GrammarEnv -> [STerm] -> Term -> STerm -substitutePaths env arguments trm = subst trm - where subst (con `Con` terms) = con `SCon` map subst terms - subst (R record) = SRec [ (lbl, subst term) | lbl `Ass` term <- record ] - subst (term `P` lbl) = subst term +. lbl - subst (T ptype table) = STbl [ (pattern2sterm pat, subst term) | - pats `Cas` term <- table, pat <- pats ] - subst (V ptype table) = STbl [ (pat, subst term) | - (pat, term) <- zip (groundTerms env ptype) table ] - subst (term `S` select) = subst term +! subst select - subst (term `C` term') = subst term `SConcat` subst term' - subst (K str) = SToken str - subst (E) = SEmpty - subst (FV terms) = evalFV $ map subst terms - subst (Arg (A _ arg)) = arguments !! fromInteger arg - - -termPaths :: GrammarEnv -> CType -> STerm -> [(Path, (CType, STerm))] -termPaths env (TStr) term = [ (emptyPath, (TStr, term)) ] -termPaths env (RecType rtype) (SRec record) - = [ (path ++. lbl, value) | - (lbl, term) <- record, - let ctype = lookupLabelling lbl rtype, - (path, value) <- termPaths env ctype term ] -termPaths env (Table _ ctype) (STbl table) - = [ (path ++! pat, value) | - (pat, term) <- table, - (path, value) <- termPaths env ctype term ] -termPaths env ctype (SVariants terms) - = terms >>= termPaths env ctype -termPaths env (Cn pc) term = [ (emptyPath, (Cn pc, 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 :: GrammarEnv -> CType -> STerm -> [[(Path, STerm)]] -parPaths env ctype term = mapM (uncurry (map . (,))) (groupPairs paths) - where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths env ctype term ] - -strPaths :: GrammarEnv -> CType -> STerm -> [(Path, STerm)] -strPaths env ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] - where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths env ctype term ] - -extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn] -extractLin args (path, term) = map (Lin path) (convertLin term) - where convertLin (t1 `SConcat` t2) = liftM2 (++) (convertLin t1) (convertLin t2) - convertLin (SEmpty) = [[]] - convertLin (SToken tok) = [[Tok tok]] - convertLin (SVariants terms) = concatMap convertLin terms - convertLin (SArg nr _ path) = [[Cat (args !! nr, path, nr)]] - -evalFV terms0 = case nubsort (concatMap flattenFV terms0) of - [term] -> term - terms -> SVariants terms - where flattenFV (SVariants ts) = ts - flattenFV t = [t] - ----------------------------------------------------------------------- --- utilities - -lookupCType :: GrammarEnv -> Cat -> CType -lookupCType env cat = errVal defLinType $ - lookupLincat (fst env) (CIQ (snd env) cat) - -lookupLabelling :: Label -> [Labelling] -> CType -lookupLabelling lbl rtyp = case [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] of - [ctyp] -> ctyp - err -> error $ "lookupLabelling:" ++ show err - -groundTerms :: GrammarEnv -> CType -> [STerm] -groundTerms env ctype = err error (map term2spattern) $ - allParamValues (fst env) ctype - -term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ] -term2spattern (Con con terms) = SCon con $ map term2spattern terms - -pattern2sterm :: Patt -> STerm -pattern2sterm (con `PC` patterns) = con `SCon` map pattern2sterm patterns -pattern2sterm (PR record) = SRec [ (lbl, pattern2sterm pattern) | - lbl `PAss` pattern <- record ] - diff --git a/src/GF/Parsing/ConvertGrammar.hs b/src/GF/Parsing/ConvertGrammar.hs deleted file mode 100644 index afaf68f3c..000000000 --- a/src/GF/Parsing/ConvertGrammar.hs +++ /dev/null @@ -1,44 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGrammar --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- All (?) grammar conversions which are used in GF ------------------------------------------------------------------------------ - - -module GF.Parsing.ConvertGrammar - (pInfo, emptyPInfo, - module GF.Parsing.GrammarTypes - ) where - -import GFC (CanonGrammar) -import MkGFC (grammar2canon) -import GF.Parsing.GrammarTypes -import Ident (Ident(..)) -import Option -import GF.System.Tracing - --- import qualified GF.Parsing.FiniteTypes.Calc as Fin -import qualified GF.Parsing.ConvertGFCtoMCFG as G2M -import qualified GF.Parsing.ConvertMCFGtoCFG as M2C -import qualified GF.Parsing.MCFGrammar as MCFG -import qualified GF.Parsing.CFGrammar as CFG - -pInfo :: Options -> CanonGrammar -> Ident -> PInfo -pInfo opts canon lng = PInfo mcfg cfg mcfp cfp - where mcfg = G2M.convertGrammar cnv (canon, lng) - cnv = maybe "nondet" id $ getOptVal opts gfcConversion - cfg = M2C.convertGrammar mcfg - mcfp = MCFG.pInfo mcfg - cfp = CFG.pInfo cfg - -emptyPInfo :: PInfo -emptyPInfo = PInfo [] [] (MCFG.pInfo []) (CFG.pInfo []) - diff --git a/src/GF/Parsing/ConvertMCFGtoCFG.hs b/src/GF/Parsing/ConvertMCFGtoCFG.hs deleted file mode 100644 index 514ff64eb..000000000 --- a/src/GF/Parsing/ConvertMCFGtoCFG.hs +++ /dev/null @@ -1,52 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertMCFGtoCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Converting MCFG grammars to (possibly overgenerating) CFG ------------------------------------------------------------------------------ - - -module GF.Parsing.ConvertMCFGtoCFG - (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser - -import Monad -import GF.Parsing.Utilities -import qualified GF.Parsing.MCFGrammar as MCFG -import qualified GF.Parsing.CFGrammar as CFG -import GF.Parsing.GrammarTypes - -convertGrammar :: MCFGrammar -> CFGrammar -convertGrammar gram = tracePrt "#cf-rules" (prt.length) $ - concatMap convertRule gram - -convertRule :: MCFRule -> [CFRule] -convertRule (MCFG.Rule cat args record name) - = [ CFG.Rule (CFCat cat lbl) rhs (CFName name profile) | - MCFG.Lin lbl lin <- record, - let rhs = map (mapSymbol convertArg id) lin, - let profile = map (argPlaces lin) [0 .. length args-1] - ] - -convertArg (cat, lbl, _arg) = CFCat cat lbl - -argPlaces lin arg = [ place | ((_cat, _lbl, arg'), place) <- - zip (filterCats lin) [0::Int ..], arg == arg' ] - -filterCats syms = [ cat | Cat cat <- syms ] - - - - - - - diff --git a/src/GF/Parsing/GFC.hs b/src/GF/Parsing/GFC.hs index 11fdbbe04..5ca6edcd1 100644 --- a/src/GF/Parsing/GFC.hs +++ b/src/GF/Parsing/GFC.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:51 $ +-- > CVS $Date: 2005/04/12 10:49:45 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- The main parsing module, parsing GFC grammars -- by translating to simpler formats, such as PMCFG and CFG @@ -45,7 +45,7 @@ import qualified GF.NewParsing.CFG as PC -- parsing information data PInfo = PInfo { mcfPInfo :: (), -- ^ not implemented yet - cfPInfo :: PC.CFPInfo CCat CName Token } + cfPInfo :: PC.CFPInfo CCat Name Token } buildPInfo :: MGrammar -> CGrammar -> PInfo buildPInfo mcfg cfg = PInfo { mcfPInfo = (), @@ -77,7 +77,7 @@ parse strategy pinfo abs start = parse ('c':strategy) pinfo abs start ---------------------------------------------------------------------- -parseCFG :: String -> PInfo -> [CCat] -> [Token] -> [SyntaxTree Name] +parseCFG :: String -> PInfo -> [CCat] -> [Token] -> [SyntaxTree Fun] parseCFG strategy pInfo startCats inString = trace2 "Parser" "CFG" $ trees where trees = tracePrt "#trees" (prt . length) $ @@ -144,7 +144,7 @@ newParser (m:strategy) gr (_, startCat) inString ---------------------------------------------------------------------- -- parse trees to GF terms -tree2term :: Ident.Ident -> SyntaxTree Name -> Grammar.Term +tree2term :: Ident.Ident -> SyntaxTree Fun -> Grammar.Term tree2term abs (TNode f ts) = Macros.mkApp (Macros.qq (abs,f)) (map (tree2term abs) ts) tree2term abs (TMeta) = Macros.mkMeta 0 @@ -152,19 +152,19 @@ tree2term abs (TMeta) = Macros.mkMeta 0 ---------------------------------------------------------------------- -- conversion and unification of forests -convertFromCFForest :: SyntaxForest CName -> [SyntaxForest Name] +convertFromCFForest :: SyntaxForest Name -> [SyntaxForest Fun] -- simplest implementation -convertFromCFForest (FNode (CName name profile) children) +convertFromCFForest (FNode name@(Name fun profile) children) | isCoercion name = concat chForests - | otherwise = [ FNode name chForests | not (null chForests) ] - where chForests = concat [ mapM (checkProfile forests) profile | + | otherwise = [ FNode fun chForests | not (null chForests) ] + where chForests = concat [ applyProfileM unifyManyForests profile forests | forests0 <- children, forests <- mapM convertFromCFForest forests0 ] {- -- more intelligent(?) implementation -convertFromCFForest (FNode (CName name profile) children) +convertFromCFForest (FNode (Name name profile) children) | isCoercion name = concat chForests | otherwise = [ FNode name chForests | not (null chForests) ] where chForests = concat [ mapM (checkProfile forests) profile | @@ -172,16 +172,16 @@ convertFromCFForest (FNode (CName name profile) children) forests <- mapM convertFromCFForest forests0 ] -} -checkProfile forests = unifyManyForests . map (forests !!) - - +{- ---------------------------------------------------------------------- -- conversion and unification for parse trees instead of forests +-- OBSOLETE! -convertFromCFTree :: SyntaxTree CName -> [SyntaxTree Name] -convertFromCFTree (TNode (CName name profile) children0) - = [ TNode name children | - children1 <- mapM convertFromCFTree children0, - children <- mapM (checkProfile children1) profile ] - where checkProfile trees = unifyManyTrees . map (trees !!) - +convertFromCFTree :: SyntaxTree Name -> [SyntaxTree Fun] +convertFromCFTree (TNode name@(Name fun profile) children0) + | isCoercion name = concat chTrees + | otherwise = map (TNode fun) chTrees + where chTrees = [ children | + children1 <- mapM convertFromCFTree children0, + children <- applyProfileM unifyManyTrees profile children1 ] +-} diff --git a/src/GF/Parsing/GeneralChart.hs b/src/GF/Parsing/GeneralChart.hs deleted file mode 100644 index c8fe2b202..000000000 --- a/src/GF/Parsing/GeneralChart.hs +++ /dev/null @@ -1,86 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GeneralChart --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/21 22:31:48 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Simple implementation of deductive chart parsing ------------------------------------------------------------------------------ - - -module GF.Parsing.GeneralChart - (-- * Type definition - Chart, - -- * Main functions - chartLookup, - buildChart, - -- * Probably not needed - emptyChart, - chartMember, - chartInsert, - chartList, - addToChart - ) where - --- import Trace - -import GF.Data.RedBlackSet - --- main functions - -chartLookup :: (Ord item, Ord key) => Chart item key -> key -> [item] -buildChart :: (Ord item, Ord key) => (item -> key) -> - [Chart item key -> item -> [item]] -> [item] -> [item] - -buildChart keyof rules axioms = chartList (addItems axioms emptyChart) - where addItems [] = id - addItems (item:items) = addItems items . addItem item - - -- addItem item | trace ("+ "++show item++"\n") False = undefined - addItem item = addToChart item (keyof item) - (\chart -> foldr (consequence item) chart rules) - - consequence item rule chart = addItems (rule chart item) chart - --- probably not needed - -emptyChart :: (Ord item, Ord key) => Chart item key -chartMember :: (Ord item, Ord key) => Chart item key -> item -> key -> Bool -chartInsert :: (Ord item, Ord key) => Chart item key -> item -> key -> Maybe (Chart item key) -chartList :: (Ord item, Ord key) => Chart item key -> [item] -addToChart :: (Ord item, Ord key) => item -> key -> (Chart item key -> Chart item key) -> Chart item key -> Chart item key - -addToChart item key after chart = maybe chart after (chartInsert chart item key) - - --------------------------------------------------------------------------------- --- key charts as red/black trees - -newtype Chart item key = KC (RedBlackMap key item) - deriving Show - -emptyChart = KC rbmEmpty -chartMember (KC tree) item key = rbmElem key item tree -chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree) -chartLookup (KC tree) key = rbmLookup key tree -chartList (KC tree) = concatMap snd (rbmList tree) ---------------------------------------------------------------------------------} - - -{-------------------------------------------------------------------------------- --- key charts as unsorted association lists -- OBSOLETE! - -newtype Chart item key = SC [(key, item)] - -emptyChart = SC [] -chartMember (SC chart) item key = (key,item) `elem` chart -chartInsert (SC chart) item key = if (key,item) `elem` chart then Nothing else Just (SC ((key,item):chart)) -chartLookup (SC chart) key = [ item | (key',item) <- chart, key == key' ] -chartList (SC chart) = map snd chart ---------------------------------------------------------------------------------} - diff --git a/src/GF/Parsing/GrammarTypes.hs b/src/GF/Parsing/GrammarTypes.hs deleted file mode 100644 index 2e3e665da..000000000 --- a/src/GF/Parsing/GrammarTypes.hs +++ /dev/null @@ -1,146 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- All possible instantiations of different grammar formats used for parsing --- --- Plus some helper types and utilities ------------------------------------------------------------------------------ - - -module GF.Parsing.GrammarTypes - (-- * Main parser information - PInfo(..), - -- * Multiple context-free grammars - MCFGrammar, MCFRule, MCFPInfo, - MCFCat(..), MCFLabel, - Constraint, - -- * Context-free grammars - CFGrammar, CFRule, CFPInfo, - CFProfile, CFName(..), CFCat(..), - -- * Assorted types - Cat, Name, Constr, Label, Tokn, - -- * Simplified terms - STerm(..), (+.), (+!), - -- * Record\/table paths - Path(..), emptyPath, - (++.), (++!) - ) where - -import Ident (Ident(..)) -import AbsGFC --- import qualified GF.Parsing.FiniteTypes.Calc as Fin -import qualified GF.Parsing.CFGrammar as CFG -import qualified GF.Parsing.MCFGrammar as MCFG -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm - ----------------------------------------------------------------------- - -data PInfo = PInfo { mcfg :: MCFGrammar, - cfg :: CFGrammar, - mcfPInfo :: MCFPInfo, - cfPInfo :: CFPInfo } - -type MCFGrammar = MCFG.Grammar Name MCFCat MCFLabel Tokn -type MCFRule = MCFG.Rule Name MCFCat MCFLabel Tokn -type MCFPInfo = MCFG.PInfo Name MCFCat MCFLabel Tokn - -data MCFCat = MCFCat Cat [Constraint] deriving (Eq, Ord, Show) -type MCFLabel = Path - -type Constraint = (Path, STerm) - -type CFGrammar = CFG.Grammar CFName CFCat Tokn -type CFRule = CFG.Rule CFName CFCat Tokn -type CFPInfo = CFG.PInfo CFName CFCat Tokn - -type CFProfile = [[Int]] -data CFName = CFName Name CFProfile deriving (Eq, Ord, Show) -data CFCat = CFCat MCFCat MCFLabel deriving (Eq, Ord, Show) - ----------------------------------------------------------------------- - -type Cat = Ident -type Name = Ident -type Constr = CIdent - -data STerm = SArg Int Cat Path -- ^ argument variable, the 'Path' is a path - -- pointing into the term - | SCon Constr [STerm] -- ^ constructor - | SRec [(Label, STerm)] -- ^ record - | STbl [(STerm, STerm)] -- ^ table of patterns\/terms - | SVariants [STerm] -- ^ variants - | SConcat STerm STerm -- ^ concatenation - | SToken Tokn -- ^ single token - | SEmpty -- ^ empty string - | SWildcard -- ^ wildcard pattern variable - - -- SRes CIdent -- resource identifier - -- SVar Ident -- bound pattern variable - -- SInt Integer -- integer - deriving (Eq, Ord, Show) - -(+.) :: STerm -> Label -> STerm -SRec record +. lbl = maybe err id $ lookup lbl record - where err = error $ "(+.), label not in record: " ++ show (SRec record) ++ " +. " ++ show lbl -SArg arg cat path +. lbl = SArg arg cat (path ++. lbl) -SVariants terms +. lbl = SVariants $ map (+. lbl) terms -sterm +. lbl = error $ "(+.): " ++ show sterm ++ " +. " ++ show lbl - -(+!) :: STerm -> STerm -> STerm -STbl table +! pat = maybe err id $ lookup pat table - where err = error $ "(+!), pattern not in table: " ++ show (STbl table) ++ " +! " ++ show pat -SArg arg cat path +! pat = SArg arg cat (path ++! pat) -SVariants terms +! pat = SVariants $ map (+! pat) terms -term +! SVariants pats = SVariants $ map (term +!) pats -sterm +! pat = error $ "(+!): " ++ show sterm ++ " +! " ++ show pat - ----------------------------------------------------------------------- - -newtype Path = Path [Either Label STerm] deriving (Eq, Ord, Show) - -emptyPath :: Path -emptyPath = Path [] - -(++.) :: Path -> Label -> Path -Path path ++. lbl = Path (Left lbl : path) - -(++!) :: Path -> STerm -> Path -Path path ++! sel = Path (Right sel : path) - ------------------------------------------------------------- - -instance Print STerm where - prt (SArg n c p) = prt c ++ "@" ++ prt n ++ prt p - prt (SCon c []) = prt c - prt (SCon c ts) = prt c ++ prtList ts - prt (SRec rec) = "{" ++ concat [ prt l ++ "=" ++ prt t ++ ";" | (l,t) <- rec ] ++ "}" - prt (STbl tbl) = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ ";" | (p,t) <- tbl ] ++ "}" - prt (SVariants ts) = "{| " ++ prtSep " | " ts ++ " |}" - prt (SConcat t1 t2) = prt t1 ++ "++" ++ prt t2 - prt (SToken t) = prt t - prt (SEmpty) = "[]" - prt (SWildcard) = "_" - -instance Print MCFCat where - prt (MCFCat cat params) - = prt cat ++ "{" ++ concat [ prt path ++ "=" ++ prt term ++ ";" | - (path, term) <- params ] ++ "}" - -instance Print CFName where - prt (CFName name profile) = prt name ++ prt profile - -instance Print CFCat where - prt (CFCat cat lbl) = prt cat ++ prt lbl - -instance Print Path where - prt (Path path) = concatMap prtEither (reverse path) - where prtEither (Left lbl) = "." ++ prt lbl - prtEither (Right patt) = "!" ++ prt patt diff --git a/src/GF/Parsing/IncrementalChart.hs b/src/GF/Parsing/IncrementalChart.hs deleted file mode 100644 index a5d9f54b1..000000000 --- a/src/GF/Parsing/IncrementalChart.hs +++ /dev/null @@ -1,50 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : IncrementalChart --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/21 22:31:49 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Implementation of /incremental/ deductive parsing, --- i.e. parsing one word at the time. ------------------------------------------------------------------------------ - - -module GF.Parsing.IncrementalChart - (-- * Type definitions - IncrementalChart, - -- * Functions - buildChart, - chartList - ) where - -import Array -import GF.Data.SortedList -import GF.Data.Assoc - -buildChart :: (Ord item, Ord key) => (item -> key) -> - (Int -> item -> SList item) -> - (Int -> SList item) -> - (Int, Int) -> IncrementalChart item key - -chartList :: (Ord item, Ord key) => (Int -> item -> edge) -> IncrementalChart item key -> [edge] - -type IncrementalChart item key = Array Int (Assoc key (SList item)) - ----------- - -buildChart keyof rules axioms bounds = finalChartArray - where buildState k = limit (rules k) $ axioms k - finalChartList = map buildState [fst bounds .. snd bounds] - finalChartArray = listArray bounds $ map stateAssoc finalChartList - stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ] - -chartList combine chart = [ combine k item | - (k, state) <- assocs chart, - item <- concatMap snd $ aAssocs state ] - - diff --git a/src/GF/Parsing/MCFGrammar.hs b/src/GF/Parsing/MCFGrammar.hs deleted file mode 100644 index c8ff0c329..000000000 --- a/src/GF/Parsing/MCFGrammar.hs +++ /dev/null @@ -1,206 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MCFGrammar --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/21 22:31:49 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- Definitions of multiple context-free grammars, --- parser information and chart conversion ------------------------------------------------------------------------------ - -module GF.Parsing.MCFGrammar - (-- * Type definitions - Grammar, - Rule(..), - Lin(..), - -- * Parser information - MCFParser, - MEdge, - edges2chart, - PInfo, - pInfo, - -- * Ranges - Range(..), - makeRange, - concatRange, - unifyRange, - unionRange, - failRange, - -- * Utilities - select, - updateIndex - ) where - --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc --- parser modules: -import GF.Parsing.Utilities -import GF.Printing.PrintParser - - - -select :: [a] -> [(a, [a])] -select [] = [] -select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ] - -updateIndex :: Functor f => Int -> [a] -> (a -> f a) -> f [a] -updateIndex 0 (a:as) f = fmap (:as) $ f a -updateIndex n (a:as) f = fmap (a:) $ updateIndex (n-1) as f -updateIndex _ _ _ = error "ParserUtils.updateIndex: Index out of range" - - ------------------------------------------------------------- --- grammar types - -type Grammar n c l t = [Rule n c l t] -data Rule n c l t = Rule c [c] [Lin c l t] n - deriving (Eq, Ord, Show) -data Lin c l t = Lin l [Symbol (c, l, Int) t] - deriving (Eq, Ord, Show) - --- variants is simply several linearizations with the same label - - ------------------------------------------------------------- --- parser information - -type PInfo n c l t = Grammar n c l t - -pInfo :: Grammar n c l t -> PInfo n c l t -pInfo = id - -type MCFParser n c l t = PInfo n c l t -> [c] -> Input t -> ParseChart n (MEdge c l) - -type MEdge c l = (c, [(l, Range)]) - -edges2chart :: (Ord n, Ord c, Ord l) => - [(n, MEdge c l, [MEdge c l])] -> ParseChart n (MEdge c l) -edges2chart edges = fmap groupPairs $ accumAssoc id $ - [ (medge, (name, medges)) | (name, medge, medges) <- edges ] - - ------------------------------------------------------------- --- ranges as sets of int-pairs - -newtype Range = Rng (SList (Int, Int)) deriving (Eq, Ord, Show) - -makeRange :: SList (Int, Int) -> Range -makeRange rho = Rng rho - -concatRange :: Range -> Range -> Range -concatRange (Rng rho) (Rng rho') = Rng $ nubsort [ (i,k) | (i,j) <- rho, (j',k) <- rho', j==j' ] - -unifyRange :: Range -> Range -> Range -unifyRange (Rng rho) (Rng rho') = Rng $ rho <**> rho' - -unionRange :: Range -> Range -> Range -unionRange (Rng rho) (Rng rho') = Rng $ rho <++> rho' - -failRange :: Range -failRange = Rng [] - - ------------------------------------------------------------- --- pretty-printing - -instance (Print n, Print c, Print l, Print t) => Print (Rule n c l t) where - prt (Rule cat args record name) - = prt name ++ ". " ++ prt cat ++ " -> " ++ prtSep " " args ++ "\n" ++ prt record - prtList = concatMap prt - -instance (Print c, Print l, Print t) => Print (Lin c l t) where - prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin) - where prArg (cat, lbl, arg) = prt cat ++ "@" ++ prt arg ++ "." ++ prt lbl - prtList = prtBeforeAfter "\t" "\n" - -instance Print Range where - prt (Rng rho) = "(" ++ prtSep "|" [ show i ++ "-" ++ show j | (i,j) <- rho ] ++ ")" - -{- ------------------------------------------------------------- --- items & forests - -data Item n c l = Item n (MEdge c l) [[MEdge c l]] - deriving (Eq, Ord, Show) -type MEdge c l = (c, [Edge l]) - -items2forests :: (Ord n, Ord c, Ord l) => Edge ((c, l) -> Bool) -> [Item n c l] -> [ParseForest n] - ----------- - -items2forests (Edge i0 k0 startCat) items - = concatMap edge2forests $ filter checkEdge $ aElems chart - where edge2forests (cat, []) = [FMeta] - edge2forests edge = filter checkForest $ map item2forest (chart ? edge) - - item2forest (Item name _ children) = FNode name [ forests | edges <- children, - forests <- mapM edge2forests edges ] - - checkEdge (cat, [Edge i k lbl]) = i == i0 && k == k0 && startCat (cat, lbl) - checkEdge _ = False - - checkForest (FNode _ children) = not (null children) - - chart = accumAssoc id [ (edge, item) | item@(Item _ edge _) <- items ] --} - - ------------------------------------------------------------- --- grammar checking -{- ---checkGrammar :: (Ord c, Ord l, Print n, Print c, Print l, Print t) => Grammar n c l t -> [String] - -checkGrammar rules - = do rule@(Rule cat rhs record name) <- rules - if null record - then [ "empty linearization record in rule: " ++ prt rule ] - else [ "category does not exist: " ++ prt rcat ++ "\n" ++ - " - in rule: " ++ prt rule | - rcat <- rhs, rcat `notElem` lhsCats ] ++ - do Lin _ lin <- record - Cat (arg, albl) <- lin - if arg<0 || arg>=length rhs - then [ "argument index out of range: " ++ show arg ++ "/" ++ prt albl ++ "\n" ++ - " - in rule: " ++ prt rule ] - else [ "label does not exist: " ++ prt albl ++ "\n" ++ - " - from rule: " ++ prt rule ++ - " - in rule: " ++ prt arule | - arule@(Rule _ acat _ arecord) <- rules, - acat == rhs !! arg, - albl `notElem` [ lbl | Lin lbl _ <- arecord ] ] - where lhsCats = nubsort [ cat | Rule _ cat _ _ <- rules ] --} - - - - - -{----- ------------------------------------------------------------- --- simplifications - -splitMRule :: (Ord n, Ord c, Ord l, Ord t) => Grammar n c l t -> Rule n c l t -> [Rule n c l t] -splitMRule rules (Rule name cat args record) = nubsort [ (Rule name cat args splitrec) | - (cat', lbls) <- rhsCats, cat == cat', - let splitrec = [ lin | lin@(Lin lbl _) <- record, lbl `elem` lbls ] ] - where rhsCats = limit rhsC lhsCats - lhsCats = nubsort [ (cat, [lbl]) | Rule _ cat _ record <- rules, Lin lbl _ <- record ] - rhsC (cat, lbls) = nubsort [ (rcat, rlbls) | - Rule _ cat' rhs lins <- rules, cat == cat', - (arg, rcat) <- zip [0..] rhs, - let rlbls = nubsort [ rlbl | Lin lbl lin <- lins, lbl `elem` lbls, - Cat (arg', rlbl) <- lin, arg == arg' ], - not $ null rlbls - ] - - -----} - - - diff --git a/src/GF/Parsing/ParseCF.hs b/src/GF/Parsing/ParseCF.hs deleted file mode 100644 index b69b89a59..000000000 --- a/src/GF/Parsing/ParseCF.hs +++ /dev/null @@ -1,82 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCF --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- Chart parsing of grammars in CF format ------------------------------------------------------------------------------ - -module GF.Parsing.ParseCF (parse, alternatives) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm - -import GF.Data.SortedList (nubsort) -import GF.Data.Assoc -import qualified CF -import qualified CFIdent as CFI -import GF.Parsing.Utilities -import GF.Parsing.CFGrammar -import qualified GF.Parsing.ParseCFG as P - -type Token = CFI.CFTok -type Name = CFI.CFFun -type Category = CFI.CFCat - -alternatives :: [(String, [String])] -alternatives = [ ("gb", ["G","GB","_gen","_genBU"]), - ("gt", ["GT","_genTD"]), - ("ibn", ["","I","B","IB","IBN","_inc","BU","_incBU"]), - ("ibb", ["BB","IBB","BU_BUF","_incBU_BUF"]), - ("ibt", ["BT","IBT","BU_TDF","_incBU_TDF"]), - ("iba", ["BA","IBA","BU_BTF","BU_TBF","_incBU_BTF","_incBU_TBF"]), - ("itn", ["T","IT","ITN","TD","_incTD"]), - ("itb", ["TB","ITB","TD_BUF","_incTD_BUF"]) - ] - -parse :: String -> CF.CF -> Category -> CF.CFParser -parse = buildParser . P.parse - -buildParser :: CFParser Name Category Token -> CF.CF -> Category -> CF.CFParser -buildParser parser cf start tokens = trace "ParseCF" $ - (parseResults, parseInformation) - where parseInformation = prtSep "\n" trees - parseResults = {-take maxTake-} [ (tree2cfTree t, []) | t <- trees ] - theInput = input tokens - edges = tracePrt "#edges" (prt.length) $ - parser pInf [start] theInput - chart = tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ - edges2chart theInput $ map (fmap addCategory) edges - forests = tracePrt "#forests" (prt.length) $ - chart2forests chart (const False) $ - uncurry Edge (inputBounds theInput) start - trees = tracePrt "#trees" (prt.length) $ - concatMap forest2trees forests - pInf = pInfo $ cf2grammar cf (nubsort tokens) - - -addCategory (Rule cat rhs name) = Rule cat rhs (name, cat) - -tree2cfTree (TNode (name, cat) trees) = CF.CFTree (name, (cat, map tree2cfTree trees)) - -cf2grammar :: CF.CF -> [Token] -> Grammar Name Category Token -cf2grammar cf tokens = [ Rule cat rhs name | - (name, (cat, rhs0)) <- cfRules, - rhs <- mapM item2symbol rhs0 ] - where cfRules = concatMap (CF.predefRules (CF.predefOfCF cf)) tokens ++ - CF.rulesOfCF cf - item2symbol (CF.CFNonterm cat) = [Cat cat] - item2symbol item = map Tok $ filter (CF.matchCFTerm item) tokens - --- maxTake :: Int --- maxTake = 500 --- maxTake = maxBound - - diff --git a/src/GF/Parsing/ParseCFG.hs b/src/GF/Parsing/ParseCFG.hs deleted file mode 100644 index c613ca312..000000000 --- a/src/GF/Parsing/ParseCFG.hs +++ /dev/null @@ -1,43 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/21 22:31:51 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Main parsing module for context-free grammars ------------------------------------------------------------------------------ - - -module GF.Parsing.ParseCFG (parse) where - -import Char (toLower) -import GF.Parsing.Utilities -import GF.Parsing.CFGrammar -import qualified GF.Parsing.ParseCFG.General as PGen -import qualified GF.Parsing.ParseCFG.Incremental as PInc - - -parse :: (Ord n, Ord c, Ord t, Show t) => - String -> CFParser n c t -parse = decodeParser . map toLower - -decodeParser ['g',s] = PGen.parse (decodeStrategy s) -decodeParser ['i',s,f] = PInc.parse (decodeStrategy s, decodeFilter f) -decodeParser _ = decodeParser "ibn" - -decodeStrategy 'b' = (True, False) -decodeStrategy 't' = (False, True) - -decodeFilter 'a' = (True, True) -decodeFilter 'b' = (True, False) -decodeFilter 't' = (False, True) -decodeFilter 'n' = (False, False) - - - - diff --git a/src/GF/Parsing/ParseCFG/General.hs b/src/GF/Parsing/ParseCFG/General.hs deleted file mode 100644 index 5e37635a5..000000000 --- a/src/GF/Parsing/ParseCFG/General.hs +++ /dev/null @@ -1,84 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCFG.General --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:55 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Several implementations of CFG chart parsing ------------------------------------------------------------------------------ - -module GF.Parsing.ParseCFG.General - (parse, Strategy) where - -import GF.System.Tracing - -import GF.Parsing.Utilities -import GF.Parsing.CFGrammar -import GF.Parsing.GeneralChart -import GF.Data.Assoc - -parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser n c t -parse strategy grammar start = extract . process strategy grammar start - -type Strategy = (Bool, Bool) -- (isBottomup, isTopdown) - -extract :: [Item n (Symbol c t)] -> [Edge (Rule n c t)] -extract edges = - edges' - where edges' = [ Edge j k (Rule cat (reverse found) name) | - Edge j k (Cat cat, found, [], Just name) <- edges ] - -process :: (Ord n, Ord c, Ord t) => Strategy -> PInfo n c t -> - [c] -> Input t -> [Item n (Symbol c t)] -process (isBottomup, isTopdown) grammar start - = trace ("CFParserGeneral" ++ - (if isBottomup then " BU" else "") ++ - (if isTopdown then " TD" else "")) $ - buildChart keyof [predict, combine] . axioms - where axioms input = initial ++ scan input - - scan input = map (fmap mkEdge) (inputEdges input) - mkEdge tok = (Tok tok, [], [], Nothing) - - -- the combine rule - combine chart (Edge j k (next, _, [], _)) - = [ edge `forwardTo` k | edge <- chartLookup chart (Active next j) ] - combine chart edge@(Edge _ j (_, _, next:_, _)) - = [ edge `forwardTo` k | Edge _ k _ <- chartLookup chart (Passive next j) ] - - -- initial predictions - initial = [ loopingEdge 0 rule | cat <- start, rule <- tdRuleLookup ? cat ] - - -- predictions - predict chart (Edge j k (next, _, [], _)) | isBottomup - = [ loopingEdge j rule `forwardTo` k | rule <- bottomupRules grammar ? next ] - -- - - - - - - - - - ^^^^^^^^^^^^^ Kilbury prediction: move dot forward - predict chart (Edge _ k (_, _, Cat cat:_, _)) - = [ loopingEdge k rule | rule <- tdRuleLookup ? cat ] - predict _ _ = [] - - tdRuleLookup | isTopdown = topdownRules grammar - | isBottomup = emptyLeftcornerRules grammar - --- internal representation of parse items - -type Item n s = Edge (s, [s], [s], Maybe n) -type IChart n s = Chart (Item n s) (IKey s) -data IKey s = Active s Int - | Passive s Int - deriving (Eq, Ord, Show) - -keyof (Edge _ j (_, _, next:_, _)) = Active next j -keyof (Edge j _ (cat, _, [], _)) = Passive cat j - -forwardTo (Edge i j (cat, found, next:tofind, name)) k = Edge i k (cat, next:found, tofind, name) - -loopingEdge k (Rule cat tofind name) = Edge k k (Cat cat, [], tofind, Just name) - - - diff --git a/src/GF/Parsing/ParseCFG/Incremental.hs b/src/GF/Parsing/ParseCFG/Incremental.hs deleted file mode 100644 index ed08d581e..000000000 --- a/src/GF/Parsing/ParseCFG/Incremental.hs +++ /dev/null @@ -1,143 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCFG.Incremental --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:55 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Incremental chart parsing for context-free grammars ------------------------------------------------------------------------------ - - - -module GF.Parsing.ParseCFG.Incremental - (parse, Strategy) where - -import GF.System.Tracing -import GF.Printing.PrintParser - --- haskell modules: -import Array --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc -import Operations --- parser modules: -import GF.Parsing.Utilities -import GF.Parsing.CFGrammar -import GF.Parsing.IncrementalChart - - -type Strategy = ((Bool, Bool), (Bool, Bool)) -- (predict:(BU, TD), filter:(BU, TD)) - -parse :: (Ord n, Ord c, Ord t, Show t) => - Strategy -> CFParser n c t -parse ((isPredictBU, isPredictTD), (isFilterBU, isFilterTD)) grammar start input = - trace2 "CFParserIncremental" - ((if isPredictBU then "BU-predict " else "") ++ - (if isPredictTD then "TD-predict " else "") ++ - (if isFilterBU then "BU-filter " else "") ++ - (if isFilterTD then "TD-filter " else "")) $ - trace2 "input" (show (inputTo input)) $ - finalEdges - where finalEdges = [ Edge j k (Rule cat (reverse found) name) | - (k, state) <- - tracePrt "#passiveChart" - (prt . map (length . (?Passive) . snd)) $ - tracePrt "#activeChart" - (prt . map (length . concatMap snd . aAssocs . snd)) $ - assocs finalChart, - Item j (Rule cat _Nil name) found <- state ? Passive ] - - finalChart = buildChart keyof rules axioms $ inputBounds input - - axioms 0 = --tracePrt ("axioms 0") (prtSep "\n") $ - union $ map (tdInfer 0) start - axioms k = --tracePrt ("axioms "++show k) (prtSep "\n") $ - union [ buInfer j k (Tok token) | - (token, js) <- aAssocs (inputTo input ! k), j <- js ] - - rules k (Item j (Rule cat [] _) _) - = buInfer j k (Cat cat) - rules k (Item j rule@(Rule _ (Cat next:_) _) found) - = tdInfer k next <++> - -- hack for empty rules: - [ Item j (forward rule) (Cat next:found) | - emptyCategories grammar ?= next ] - rules _ _ = [] - - buInfer j k next = --tracePrt ("buInfer "++show(j,k)++" "++prt next) (prtSep "\n") $ - buPredict j k next <++> buCombine j k next - tdInfer k next = tdPredict k next - - -- the combine rule - buCombine j k next - | j == k = [] -- hack for empty rules - | otherwise = [ Item i (forward rule) (next:found) | - Item i rule found <- (finalChart ! j) ? Active next ] - - -- kilbury bottom-up prediction - buPredict j k next - = [ Item j rule [next] | isPredictBU, - rule <- map forward $ --tracePrt ("buRules "++prt next) (prtSep "\n") $ - bottomupRules grammar ? next, - buFilter rule k, - tdFilter rule j k ] - - -- top-down prediction - tdPredict k cat - = [ Item k rule [] | isPredictTD || isFilterTD, - rule <- topdownRules grammar ? cat, - buFilter rule k ] <++> - -- hack for empty rules: - [ Item k rule [] | isPredictBU, - rule <- emptyLeftcornerRules grammar ? cat ] - - -- bottom up filtering: input symbol k can begin the given symbol list (first set) - -- leftcornerTokens DOESN'T WORK WITH EMPTY RULES!!! - buFilter (Rule _ (Cat cat:_) _) k | isFilterBU - = k < snd (inputBounds input) && - hasCommonElements (leftcornerTokens grammar ? cat) - (aElems (inputFrom input ! k)) - buFilter _ _ = True - - -- top down filtering: 'cat' is reachable by an active edge ending in node j < k - tdFilter (Rule cat _ _) j k | isFilterTD && j < k - = (tdFilters ! j) ?= cat - tdFilter _ _ _ = True - - tdFilters = listArray (inputBounds input) $ - map (listSet . limit leftCats . activeCats) [0..] - activeCats j = [ next | Active (Cat next) <- aElems (finalChart ! j) ] - leftCats cat = [ left | Rule _cat (Cat left:_) _ <- topdownRules grammar ? cat ] - - --- type declarations, items & keys -data Item n c t = Item Int (Rule n c t) [Symbol c t] - deriving (Eq, Ord, Show) - -data IKey c t = Active (Symbol c t) | Passive - deriving (Eq, Ord, Show) - -keyof :: Item n c t -> IKey c t -keyof (Item _ (Rule _ (next:_) _) _) = Active next -keyof (Item _ (Rule _ [] _) _) = Passive - -forward :: Rule n c t -> Rule n c t -forward (Rule cat (_:rest) name) = Rule cat rest name - - -instance (Print n, Print c, Print t) => Print (Item n c t) where - prt (Item k (Rule cat rhs name) syms) - = "<" ++show k++ ": "++prt name++". "++ - prt cat++" -> "++prt rhs++" / "++prt syms++">" - -instance (Print c, Print t) => Print (IKey c t) where - prt (Active sym) = "?" ++ prt sym - prt (Passive) = "!" - - diff --git a/src/GF/Parsing/ParseGFC.hs b/src/GF/Parsing/ParseGFC.hs deleted file mode 100644 index 308a0ef63..000000000 --- a/src/GF/Parsing/ParseGFC.hs +++ /dev/null @@ -1,177 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseGFC --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- The main parsing module, parsing GFC grammars --- by translating to simpler formats, such as PMCFG and CFG ----------------------------------------------------------------------- - -module GF.Parsing.ParseGFC (newParser) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import qualified PrGrammar - --- Haskell modules -import Monad --- import Ratio ((%)) --- GF modules -import qualified Grammar as GF -import Values -import qualified Macros -import qualified Modules as Mods -import qualified AbsGFC -import qualified Ident -import qualified ShellState as SS -import Operations -import GF.Data.SortedList --- Conversion and parser modules -import GF.Data.Assoc -import GF.Parsing.Utilities --- import ConvertGrammar -import GF.Parsing.GrammarTypes -import qualified GF.Parsing.MCFGrammar as M -import qualified GF.Parsing.CFGrammar as C -import qualified GF.Parsing.ParseMCFG as PM -import qualified GF.Parsing.ParseCFG as PC ---import MCFRange - -newParser :: String -> SS.StateGrammar -> GF.Cat -> String -> Err [GF.Term] - --- parsing via MCFG -newParser (m:strategy) gr (_, startCat) inString - | m=='m' || m=='M' = trace2 "Parser" "MCFG" $ Ok terms - where terms = map (ptree2term abstract) trees - trees = --tracePrt "trees" (prtBefore "\n") $ - tracePrt "#trees" (prt . length) $ - concatMap forest2trees forests - forests = --tracePrt "forests" (prtBefore "\n") $ - tracePrt "#forests" (prt . length) $ - concatMap (chart2forests chart isMeta) finalEdges - isMeta = null . snd - finalEdges = tracePrt "finalEdges" (prtBefore "\n") $ - filter isFinalEdge $ aElems chart --- nubsort [ (cat, [(lbl, E.makeRange [(i,j)])]) | --- let (i, j) = inputBounds inTokens, --- E.Rule cat _ [E.Lin lbl _] _ <- pInf, --- isStartCat cat ] - isFinalEdge (cat, rows) - = isStartCat cat && - inputBounds inTokens `elem` concat [ rho | (_, M.Rng rho) <- rows ] - chart = --tracePrt "chart" (prtBefore "\n" . aAssocs) $ - tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ - PM.parse strategy pInf starters inTokens - inTokens = input $ map AbsGFC.KS $ words inString - pInf = -- tracePrt "avg rec" (\gr -> show (sum [ length rec | E.Rule _ _ rec _ <- gr ] % length gr)) $ - mcfPInfo $ SS.statePInfo gr - starters = tracePrt "startCats" prt $ - filter isStartCat $ nubsort [ cat | M.Rule cat _ _ _ <- pInf ] - isStartCat (MCFCat cat _) = cat == startCat - abstract = tracePrt "abstract module" PrGrammar.prt $ - SS.absId gr - --- parsing via CFG -newParser (c:strategy) gr (_, startCat) inString - | c=='c' || c=='C' = trace2 "Parser" "CFG" $ Ok terms - where terms = -- tracePrt "terms" (unlines . map PrGrammar.prt) $ - map (ptree2term abstract) trees - trees = tracePrt "#trees" (prt . length) $ - --tracePrt "trees" (prtSep "\n") $ - concatMap forest2trees forests - forests = tracePrt "$cfForests" (prt) $ -- . length) $ - tracePrt "forests" (unlines . map prt) $ - concatMap convertFromCFForest cfForests - cfForests= tracePrt "cfForests" (unlines . map prt) $ - concatMap (chart2forests chart (const False)) finalEdges - finalEdges = tracePrt "finalChartEdges" prt $ - map (uncurry Edge (inputBounds inTokens)) starters - chart = --tracePrt "finalChartEdges" (prt . (? finalEdge)) $ - tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ - C.edges2chart inTokens edges - edges = --tracePrt "finalEdges" - --(prt . filter (\(Edge i j _) -> (i,j)==inputBounds inTokens)) $ - tracePrt "#edges" (prt . length) $ - PC.parse strategy pInf starters inTokens - inTokens = input $ map AbsGFC.KS $ words inString - pInf = cfPInfo $ SS.statePInfo gr - starters = tracePrt "startCats" prt $ - filter isStartCat $ map fst $ aAssocs $ C.topdownRules pInf - isStartCat (CFCat (MCFCat cat _) _) = cat == startCat - abstract = tracePrt "abstract module" PrGrammar.prt $ - SS.absId gr - --ifNull (Ident.identC "ABS") last $ - --[i | (i, Mods.ModMod m) <- Mods.modules (SS.grammar gr), Mods.isModAbs m] - -newParser "" gr start inString = newParser "c" gr start inString - -newParser opt gr (_,cat) _ = - Bad ("new-parser '" ++ opt ++ "' not defined yet") - -ptree2term :: Ident.Ident -> ParseTree Name -> GF.Term -ptree2term a (TNode f ts) = Macros.mkApp (Macros.qq (a,f)) (map (ptree2term a) ts) -ptree2term a (TMeta) = GF.Meta (GF.MetaSymb 0) - ----------------------------------------------------------------------- --- conversion and unification of forests - -convertFromCFForest :: ParseForest CFName -> [ParseForest Name] -convertFromCFForest (FNode (CFName name profile) children) - | isCoercion name = concat chForests - | otherwise = [ FNode name chForests | not (null chForests) ] - where chForests = concat [ mapM (checkProfile forests) profile | - forests0 <- children, - forests <- mapM convertFromCFForest forests0 ] - checkProfile forests = unifyManyForests . map (forests !!) - -- foldM unifyForests FMeta . map (forests !!) - -isCoercion Ident.IW = True -isCoercion _ = False - -unifyManyForests :: Eq n => [ParseForest n] -> [ParseForest n] -unifyManyForests [] = [FMeta] -unifyManyForests [f] = [f] -unifyManyForests (f:g:fs) = do h <- unifyForests f g - unifyManyForests (h:fs) - -unifyForests :: Eq n => ParseForest n -> ParseForest n -> [ParseForest n] -unifyForests FMeta forest = [forest] -unifyForests forest FMeta = [forest] -unifyForests (FNode name1 children1) (FNode name2 children2) - = [ FNode name1 children | name1 == name2, not (null children) ] - where children = [ forests | forests1 <- children1, forests2 <- children2, - forests <- zipWithM unifyForests forests1 forests2 ] - - - -{- ----------------------------------------------------------------------- --- conversion and unification for parse trees instead of forests - -convertFromCFTree :: ParseTree CFName -> [ParseTree Name] -convertFromCFTree (TNode (CFName name profile) children0) - = [ TNode name children | - children1 <- mapM convertFromCFTree children0, - children <- mapM (checkProfile children1) profile ] - where checkProfile trees = unifyManyTrees . map (trees !!) - -unifyManyTrees :: Eq n => [ParseTree n] -> [ParseTree n] -unifyManyTrees [] = [TMeta] -unifyManyTrees [f] = [f] -unifyManyTrees (f:g:fs) = do h <- unifyTrees f g - unifyManyTrees (h:fs) - -unifyTrees TMeta tree = [tree] -unifyTrees tree TMeta = [tree] -unifyTrees (TNode name1 children1) (TNode name2 children2) - = [ TNode name1 children | name1 == name2, - children <- zipWithM unifyTrees children1 children2 ] - --} - diff --git a/src/GF/Parsing/ParseMCFG.hs b/src/GF/Parsing/ParseMCFG.hs deleted file mode 100644 index 296a4d4d0..000000000 --- a/src/GF/Parsing/ParseMCFG.hs +++ /dev/null @@ -1,37 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseMCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/21 22:31:52 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Main module for MCFG parsing ------------------------------------------------------------------------------ - - -module GF.Parsing.ParseMCFG (parse) where - -import Char (toLower) -import GF.Parsing.Utilities -import GF.Parsing.MCFGrammar -import qualified GF.Parsing.ParseMCFG.Basic as PBas -import GF.Printing.PrintParser ----- import qualified MCFParserBasic2 as PBas2 -- file not found AR - - -parse :: (Ord n, Ord c, Ord l, Ord t, - Print n, Print c, Print l, Print t) => - String -> MCFParser n c l t -parse str = decodeParser (map toLower str) - -decodeParser "b" = PBas.parse ----- decodeParser "c" = PBas2.parse -decodeParser _ = decodeParser "b" - - - - diff --git a/src/GF/Parsing/ParseMCFG/Basic.hs b/src/GF/Parsing/ParseMCFG/Basic.hs deleted file mode 100644 index 3ed2dd6a9..000000000 --- a/src/GF/Parsing/ParseMCFG/Basic.hs +++ /dev/null @@ -1,156 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseMCFG.Basic --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:55 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Simplest possible implementation of MCFG chart parsing ------------------------------------------------------------------------------ - -module GF.Parsing.ParseMCFG.Basic - (parse) where - -import GF.System.Tracing - -import Ix -import GF.Parsing.Utilities -import GF.Parsing.MCFGrammar -import GF.Parsing.GeneralChart -import GF.Data.Assoc -import GF.Data.SortedList -import GF.Printing.PrintParser - - -parse :: (Ord n, Ord c, Ord l, Ord t, - Print n, Print c, Print l, Print t) => - MCFParser n c l t -parse grammar start = edges2chart . extract . process grammar - - -extract :: [Item n c l t] -> [(n, MEdge c l, [MEdge c l])] -extract items = tracePrt "#passives" (prt.length) $ - --trace2 "passives" (prtAfter "\n" [ i | i@(PItem _) <- items ]) $ - [ item | PItem item <- items ] - - -process :: (Ord n, Ord c, Ord l, Ord t, - Print n, Print c, Print l, Print t) => - Grammar n c l t -> Input t -> [Item n c l t] -process grammar input = buildChart keyof rules axioms - where axioms = initial - rules = [combine, scan, predict] - - -- axioms - initial = traceItems "axiom" [] $ - [ nextLin name tofind (addNull cat) (map addNull args) | - Rule cat args tofind name <- grammar ] - - addNull a = (a, []) - - -- predict - predict chart i1@(Item name tofind rho (Lin lbl []) (cat, found0) children) - = traceItems "predict" [i1] - [ nextLin name tofind (cat, found) children | - let found = insertRow lbl rho found0 ] - predict _ _ = [] - - -- combine - combine chart active@(Item _ _ _ (Lin _ (Cat(cat,_,_):_)) _ _) - = do passive <- chartLookup chart (Passive cat) - combineItems active passive - combine chart passive@(PItem (_, (cat, _), _)) - = do active <- chartLookup chart (Active cat) - combineItems active passive - combine _ _ = [] - - combineItems i1@(Item name tofind rho0 (Lin lbl (Cat(_,lbl',nr):rest)) found children0) - i2@(PItem (_, found', _)) - = traceItems "combine" [i1,i2] - [ Item name tofind rho (Lin lbl rest) found children | - rho1 <- lookupLbl lbl' found', - let rho = concatRange rho0 rho1, - children <- updateChild nr children0 (snd found') ] - - -- scan - scan chart i1@(Item name tofind rho0 (Lin lbl (Tok tok:rest)) found children) - = traceItems "scan" [i1] - [ Item name tofind rho (Lin lbl rest) found children | - let rho = concatRange rho0 (rangeOfToken tok) ] - scan _ _ = [] - - -- utilities - rangeOfToken tok = makeRange $ inputToken input ? tok - - zeroRange = makeRange $ map (\i -> (i,i)) $ range $ inputBounds input - - nextLin name [] found children = PItem (name, found, children) - nextLin name (lin : tofind) found children - = Item name tofind zeroRange lin found children - -lookupLbl a = map snd . filter (\b -> a == fst b) . snd -updateChild nr children found = updateIndex nr children $ - \child -> if null (snd child) - then [ (fst child, found) ] - else [ child | snd child == found ] - -insertRow lbl rho [] = [(lbl, rho)] -insertRow lbl rho rows'@(row@(lbl', rho') : rows) - = case compare lbl lbl' of - LT -> row : insertRow lbl rho rows - GT -> (lbl, rho) : rows' - EQ -> (lbl, unionRange rho rho') : rows - - --- internal representation of parse items - -data Item n c l t - = Item n [Lin c l t] -- tofind - Range (Lin c l t) -- current row - (MEdge c l) -- found rows - [MEdge c l] -- found children - | PItem (n, MEdge c l, [MEdge c l]) - deriving (Eq, Ord, Show) - -data IKey c = Passive c | Active c | AnyItem - deriving (Eq, Ord, Show) - -keyof (PItem (_, (cat, _), _)) = Passive cat -keyof (Item _ _ _ (Lin _ (Cat(cat,_,_):_)) _ _) = Active cat -keyof _ = AnyItem - - --- tracing - ---type TraceItem = Item String String Char String -traceItems :: (Print n, Print l, Print c, Print t) => - String -> [Item n c l t] -> [Item n c l t] -> [Item n c l t] -traceItems rule trigs items - | null items || True = items - | otherwise = trace ("\n" ++ rule ++ ":" ++ - unlines [ "\t" ++ prt i | i <- trigs ] ++ "=>" ++ - unlines [ "\t" ++ prt i | i <- items ]) items - --- pretty-printing - -instance (Print n, Print c, Print l, Print t) => Print (Item n c l t) where - prt (Item name tofind rho lin (cat, found) children) - = prt name ++ ". " ++ prt cat ++ prtRhs (map fst children) ++ - " { " ++ prt rho ++ prt lin ++ " ; " ++ - concat [ prt lbl ++ "=" ++ prt ln ++ " " | - Lin lbl ln <- tofind ] ++ "; " ++ - concat [ prt lbl ++ "=" ++ prt rho ++ " " | - (lbl, rho) <- found ] ++ "} " ++ - concat [ "[ " ++ concat [ prt lbl ++ "=" ++ prt rho ++ " " | - (lbl,rho) <- child ] ++ "] " | - child <- map snd children ] - prt (PItem (name, edge, edges)) - = prt name ++ ". " ++ prt edge ++ prtRhs edges - -prtRhs [] = "" -prtRhs rhs = " -> " ++ prtSep " " rhs - diff --git a/src/GF/Parsing/Utilities.hs b/src/GF/Parsing/Utilities.hs deleted file mode 100644 index 3853c1f20..000000000 --- a/src/GF/Parsing/Utilities.hs +++ /dev/null @@ -1,188 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Parsing.Utilities --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/03/29 11:17:54 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Basic type declarations and functions to be used when parsing ------------------------------------------------------------------------------ - - -module GF.Parsing.Utilities - ( -- * Symbols - Symbol(..), symbol, mapSymbol, - -- * Edges - Edge(..), - -- * Parser input - Input(..), makeInput, input, inputMany, - -- * charts, parse forests & trees - ParseChart, ParseForest(..), ParseTree(..), - chart2forests, forest2trees - ) where - --- haskell modules: -import Monad -import Array --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc --- parsing modules: -import GF.Printing.PrintParser - ------------------------------------------------------------- --- symbols - -data Symbol c t = Cat c | Tok t - deriving (Eq, Ord, Show) - -symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a -mapSymbol :: (c -> d) -> (t -> u) -> Symbol c t -> Symbol d u - ----------- - -symbol fc ft (Cat cat) = fc cat -symbol fc ft (Tok tok) = ft tok - -mapSymbol fc ft = symbol (Cat . fc) (Tok . ft) - - ------------------------------------------------------------- --- edges - -data Edge s = Edge Int Int s - deriving (Eq, Ord, Show) - -instance Functor Edge where - fmap f (Edge i j s) = Edge i j (f s) - - ------------------------------------------------------------- --- parser input - -data Input t = MkInput { inputEdges :: [Edge t], - inputBounds :: (Int, Int), - inputFrom :: Array Int (Assoc t [Int]), - inputTo :: Array Int (Assoc t [Int]), - inputToken :: Assoc t [(Int, Int)] - } - -makeInput :: Ord t => [Edge t] -> Input t -input :: Ord t => [t] -> Input t -inputMany :: Ord t => [[t]] -> Input t - ----------- - -makeInput inEdges | null inEdges = input [] - | otherwise = MkInput inEdges inBounds inFrom inTo inToken - where inBounds = foldr1 minmax [ (i, j) | Edge i j _ <- inEdges ] - where minmax (a, b) (a', b') = (min a a', max b b') - inFrom = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds $ - [ (i, [(tok, j)]) | Edge i j tok <- inEdges ] - inTo = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds - [ (j, [(tok, i)]) | Edge i j tok <- inEdges ] - inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] - -input toks = MkInput inEdges inBounds inFrom inTo inToken - where inEdges = zipWith3 Edge [0..] [1..] toks - inBounds = (0, length toks) - inFrom = listArray inBounds $ - [ listAssoc [(tok, [j])] | (tok, j) <- zip toks [1..] ] ++ [ listAssoc [] ] - inTo = listArray inBounds $ - [ listAssoc [] ] ++ [ listAssoc [(tok, [i])] | (tok, i) <- zip toks [0..] ] - inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] - -inputMany toks = MkInput inEdges inBounds inFrom inTo inToken - where inEdges = [ Edge i j t | (i, j, ts) <- zip3 [0..] [1..] toks, t <- ts ] - inBounds = (0, length toks) - inFrom = listArray inBounds $ - [ listAssoc [ (t, [j]) | t <- nubsort ts ] | (ts, j) <- zip toks [1..] ] - ++ [ listAssoc [] ] - inTo = listArray inBounds $ - [ listAssoc [] ] ++ - [ listAssoc [ (t, [i]) | t <- nubsort ts ] | (ts, i) <- zip toks [0..] ] - inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] - - ------------------------------------------------------------- --- charts, parse forests & trees - -type ParseChart n e = Assoc e [(n, [[e]])] - -data ParseForest n = FNode n [[ParseForest n]] | FMeta - deriving (Eq, Ord, Show) - -data ParseTree n = TNode n [ParseTree n] | TMeta - deriving (Eq, Ord, Show) - -chart2forests :: Ord e => ParseChart n e -> (e -> Bool) -> e -> [ParseForest n] - ---filterCoercions :: (n -> Bool) -> ParseForest n -> [ParseForest n] - -forest2trees :: ParseForest n -> [ParseTree n] - -instance Functor ParseTree where - fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees - fmap f (TMeta) = TMeta - -instance Functor ParseForest where - fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests - fmap f (FMeta) = FMeta - ----------- - -chart2forests chart isMeta = edge2forests - where item2forest (name, children) = FNode name $ - do edges <- children - mapM edge2forests edges - edge2forests edge - | isMeta edge = [FMeta] - | otherwise = filter checkForest $ map item2forest $ chart ? edge - checkForest (FNode _ children) = not (null children) - --- filterCoercions _ (FMeta) = [FMeta] --- filterCoercions isCoercion (FNode s forests) --- | isCoercion s = do [forest] <- forests ; filterCoercions isCoercion forest --- | otherwise = FNode s $ do children <- forests ; mapM (filterCoercions isCoercion) - -forest2trees (FNode s forests) = map (TNode s) $ forests >>= mapM forest2trees -forest2trees (FMeta) = [TMeta] - - - ------------------------------------------------------------- --- pretty-printing - -instance (Print c, Print t) => Print (Symbol c t) where - prt = symbol prt (simpleShow.prt) - prtList = prtSep " " - -simpleShow :: String -> String -simpleShow s = "\"" ++ concatMap mkEsc s ++ "\"" - where - mkEsc :: Char -> String - mkEsc c = case c of - _ | elem c "\\\"" -> '\\' : [c] - '\n' -> "\\n" - '\t' -> "\\t" - _ -> [c] - -instance (Print s) => Print (Edge s) where - prt (Edge i j s) = "[" ++ show i ++ "-" ++ show j ++ ": " ++ prt s ++ "]" - prtList = prtSep "" - -instance (Print s) => Print (ParseTree s) where - prt (TNode s trees) = prt s ++ "^{" ++ prtSep " " trees ++ "}" - prt (TMeta) = "?" - prtList = prtAfter "\n" - -instance (Print s) => Print (ParseForest s) where - prt (FNode s forests) = prt s ++ "^{" ++ prtSep " | " (map (prtSep " ") forests) ++ "}" - prt (FMeta) = "?" - prtList = prtAfter "\n" - - diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 7e8fe9162..519413af5 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:53:39 $ +-- > CVS $Date: 2005/04/12 10:49:45 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.51 $ +-- > CVS $Revision: 1.52 $ -- -- A database for customizable GF shell commands. -- @@ -84,6 +84,7 @@ import qualified GF.Printing.PrintParser as Prt --import qualified GF.Conversion.SimpleToMCFG as S2M --import GF.Conversion.FromGFC import qualified GF.Infra.Print as Prt2 +import qualified GF.Conversion.GFC as Cnv import GFC import qualified MkGFC as MC @@ -255,39 +256,16 @@ customGrammarPrinter = ,(strCI "gfc", GFC.showGFC . stateGrammarST) ,(strCI "canonOpt",showCanonOpt "Lang" . stateGrammarST) -} + -- add your own grammar printers here --- grammar conversions, (peb) --- ,(strCI "gfc_show", show . grammar2canon . stateGrammarST) - ,(strCI "mcfg-old", Prt.prt . CnvOld.mcfg . statePInfoOld) - ,(strCI "cfg-old", Prt.prt . CnvOld.cfg . statePInfoOld) --- ,(strCI "mcfg_show", show . CnvOld.mcfg . statePInfoOld) --- ,(strCI "cfg_show", show . CnvOld.cfg . statePInfoOld) --- hack for printing finiteness of grammar categories: --- ,(strCI "finiteness", Prt.prtAfter "\n" . Assoc.aAssocs . CnvOld.fintypes . statePInfoOld) --- ,(strCI "finite", prCanon . Fin.convertGrammar . stateGrammarST) --- ,(strCI "simpleMCF", (\sg -> Prt.prt $ MCFSimp.convertGrammar "nondet" $ --- Simp.convertGrammar (stateGrammarST sg, cncId sg))) --- ,(strCI "simpleGFC", (\sg -> Prt.prt $ Simp.convertGrammar (stateGrammarST sg, cncId sg))) --- ,(strCI "finiteSimple", (\sg -> Prt.prt $ FinSimp.convertGrammar $ --- Simp.convertGrammar (stateGrammarST sg, cncId sg))) ---- also include printing via grammar2syntax! --- ,(strCI "g2s", (\sg -> Prt2.prt $ G2S.convertGrammar (stateGrammarST sg, cncId sg))) --- ,(strCI "g2s2m", (\sg -> Prt2.prt $ S2M.convertGrammar "nondet" $ --- G2S.convertGrammar (stateGrammarST sg, cncId sg))) - ,(strCI "mcfg", Prt2.prt . stateMCFG) - ,(strCI "cfg", Prt2.prt . stateCFG) -{- - ,(strCI "simple", Prt2.prt . convertToSimple "" . stateGrammarLang) - ,(strCI "mcfg-nondet", Prt2.prt . convertToMCFG "" "nondet" . stateGrammarLang) - ,(strCI "mcfg-strict", Prt2.prt . convertToMCFG "" "strict" . stateGrammarLang) - ,(strCI "cfg-nondet", Prt2.prt . convertToCFG "" "nondet" . stateGrammarLang) - ,(strCI "cfg-strict", Prt2.prt . convertToCFG "" "strict" . stateGrammarLang) - ,(strCI "fin-simple", Prt2.prt . convertToSimple "fin" . stateGrammarLang) - ,(strCI "fin-mcfg-nondet", Prt2.prt . convertToMCFG "fin" "nondet" . stateGrammarLang) - ,(strCI "fin-mcfg-strict", Prt2.prt . convertToMCFG "fin" "strict" . stateGrammarLang) - ,(strCI "fin-cfg-nondet", Prt2.prt . convertToCFG "fin" "nondet" . stateGrammarLang) - ,(strCI "fin-cfg-strict", Prt2.prt . convertToCFG "fin" "strict" . stateGrammarLang) --} +-- grammar conversions: + ,(strCI "mcfg", Prt2.prt . stateMCFG) + ,(strCI "cfg", Prt2.prt . stateCFG) +-- obsolete, or only for testing: + ,(strCI "simple", Prt2.prt . Cnv.gfc2simple . stateGrammarLang) + ,(strCI "finite", Prt2.prt . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang) + ,(strCI "mcfg-old", Prt.prt . CnvOld.mcfg . statePInfoOld) + ,(strCI "cfg-old", Prt.prt . CnvOld.cfg . statePInfoOld) ] customMultiGrammarPrinter =