forked from GitHub/gf-core
"Committed_by_peb"
This commit is contained in:
peb
@@ -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
|
||||
|
||||
@@ -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))
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 "" "" ""
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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) = [[]]
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user