msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

"Committed_by_peb"

Browse Source
This commit is contained in:
peb
2005-04-14 10:42:05 +00:00
parent 03fad6e1b8
commit f070a412a1
9 changed files with 133 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/GF/Conversion/GFC.hs
View File

@@ -4,9 +4,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/12 10:49:44 $
-- > CVS $Date: 2005/04/14 11:42:05 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
-- > CVS $Revision: 1.3 $
--
-- All conversions from GFC
-----------------------------------------------------------------------------
@@ -21,6 +21,7 @@ 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.RemoveSingletons as RemSing
import qualified GF.Conversion.SimpleToMCFG as S2M
import qualified GF.Conversion.MCFGtoCFG as M2C
@@ -30,6 +31,9 @@ gfc2simple = G2S.convertGrammar
simple2finite :: SGrammar -> SGrammar
simple2finite = S2Fin.convertGrammar
removeSingletons :: SGrammar -> SGrammar
removeSingletons = RemSing.convertGrammar
simple2mcfg_nondet :: SGrammar -> MGrammar
simple2mcfg_nondet = S2M.convertGrammarNondet

33
src/GF/Conversion/GFCtoSimple.hs
View File

@@ -4,9 +4,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/12 10:49:44 $
-- > CVS $Date: 2005/04/14 11:42:05 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
-- > CVS $Revision: 1.3 $
--
-- Converting GFC to SimpleGFC
--
@@ -54,23 +54,30 @@ convertAbsFun gram fun typing = Rule abs cnc
convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name
convertAbstract env fun (A.EProd x a b)
= convertAbstract ((x' ::: convertType [] a) : env) fun b
= convertAbstract (convertType x' [] 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) name
= Abs (convertType anyVar [] a) (reverse env) name
where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ]
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
convertType :: Var -> [TTerm] -> A.Exp -> SDecl
convertType x args (A.EApp a b) = convertType x (convertExp [] b : args) a
convertType x args (A.EAtom at) = Decl x (convertCat at) args
convertType x args exp = error $ "convertType: " ++ prt exp
convertAtom :: A.Atom -> Atom
convertAtom (A.AC con) = ACon con
convertAtom (A.AV var) = AVar var
convertExp :: [TTerm] -> A.Exp -> TTerm
convertExp args (A.EAtom at) = convertAtom args at
convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
convertExp args exp = error $ "convertExp: " ++ prt exp
convertAtom :: [TTerm] -> A.Atom -> TTerm
convertAtom args (A.AC con) = con :@ reverse args
convertAtom [] (A.AV var) = TVar var
convertAtom args atom = error $ "convertAtom: " ++ prt args ++ " " ++ prt atom
convertCat :: A.Atom -> SCat
convertCat (A.AC (A.CIQ _ cat)) = cat
convertCat at = error $ "convertCat: " ++ show at
convertCat atom = error $ "convertCat: " ++ show atom
----------------------------------------------------------------------
-- concrete definitions
@@ -101,10 +108,10 @@ convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term
A.Cas pats term <- tbl, pat <- pats ]
convertTerm gram (A.S term sel) = convertTerm gram term +! convertTerm gram sel
convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
convertTerm gram (A.FV terms) = Variants (map (convertTerm gram) terms)
convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms)
-- 'pre' tokens are converted to variants (over-generating):
convertTerm gram (A.K (A.KP [s] vs))
= Variants $ Token s : [ Token v | A.Var [v] _ <- vs ]
= variants $ Token s : [ Token v | A.Var [v] _ <- vs ]
convertTerm gram (A.K (A.KP _ _)) = error "convertTerm: don't know how to handle string lists in 'pre' tokens"
convertTerm gram (A.K (A.KS tok)) = Token tok
convertTerm gram (A.E) = Empty

46
src/GF/Conversion/SimpleToFinite.hs
View File

@@ -4,9 +4,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/12 10:49:44 $
-- > CVS $Date: 2005/04/14 11:42:05 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
-- > CVS $Revision: 1.3 $
--
-- Calculating the finiteness of each type in a grammar
-----------------------------------------------------------------------------
@@ -43,35 +43,35 @@ convertRule split (Rule abs cnc)
convertAbstract :: Splitable -> Abstract SDecl Name
-> CnvMonad (Abstract SDecl Name)
convertAbstract split (Abs (_ ::: typ) decls name)
convertAbstract split (Abs decl decls name)
= case splitableFun split (name2fun name) of
Just newCat -> return $ Abs (anyVar ::: (newCat :@ [])) decls name
Nothing -> expandTyping split name [] typ decls []
Just newCat -> return $ Abs (Decl anyVar newCat []) decls name
Nothing -> expandTyping split name [] decl decls []
expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SType -> [SDecl] -> [SDecl]
expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl]
-> CnvMonad (Abstract SDecl Name)
expandTyping split fun env (cat :@ atoms) [] decls
expandTyping split fun env (Decl x cat args) [] decls
= return $ Abs decl (reverse decls) fun
where decl = anyVar ::: substAtoms split env cat atoms []
expandTyping split fun env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone
where decl = substArgs split x env cat args []
expandTyping split fun env typ (Decl x xcat xargs : declsToDo) declsDone
= do (xcat', env') <- calcNewEnv
let decl = x ::: substAtoms split env xcat' xatoms []
let decl = substArgs split x env xcat' xargs []
expandTyping split fun env' typ declsToDo (decl : declsDone)
where calcNewEnv = case splitableCat split xcat of
Just newCats -> do newCat <- member newCats
return (newCat, (x,newCat) : env)
Nothing -> return (xcat, env)
substAtoms :: Splitable -> [(Var, 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
Just newCat -> substAtoms split env (mergeArg cat newCat) atomsToDo atomsDone
Nothing -> substAtoms split env cat atomsToDo (atom : atomsDone)
substArgs :: Splitable -> Var -> [(Var, SCat)] -> SCat -> [TTerm] -> [TTerm] -> SDecl
substArgs split x env cat [] args = Decl x cat (reverse args)
substArgs split x env cat (arg:argsToDo) argsDone
= case argLookup split env arg of
Just newCat -> substArgs split x env (mergeArg cat newCat) argsToDo argsDone
Nothing -> substArgs split x env cat argsToDo (arg : argsDone)
atomLookup split env (AVar x) = lookup x env
atomLookup split env (ACon con) = splitableFun split (constr2fun con)
argLookup split env (TVar x) = lookup x env
argLookup split env (con :@ _) = splitableFun split (constr2fun con)
----------------------------------------------------------------------
@@ -96,7 +96,7 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
-- cat-fun pairs that are splitable
splitableCatFuns = [ (cat, name2fun name) |
Rule (Abs (_ ::: (cat :@ [])) [] name) _ <- rules,
Rule (Abs (Decl _ cat []) [] name) _ <- rules,
splitableCats ?= cat ]
-- all cats that are splitable
@@ -105,20 +105,20 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
(nondepCats <**> depCats) <\\> resultCats
-- all result cats for some pure function
resultCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ _)) decls _) _ <- rules,
resultCats = nubsort [ cat | Rule (Abs (Decl _ cat _) decls _) _ <- rules,
not (null decls) ]
-- all cats in constants without dependencies
nondepCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ [])) [] _) _ <- rules ]
nondepCats = nubsort [ cat | Rule (Abs (Decl _ cat []) [] _) _ <- rules ]
-- all cats occurring as some dependency of another cat
depCats = nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
cat <- varCats [] (decls ++ [decl]) ]
varCats _ [] = []
varCats env ((x ::: (xcat :@ atoms)) : decls)
varCats env (Decl x xcat args : decls)
= varCats ((x,xcat) : env) decls ++
[ cat | AVar y <- atoms, cat <- lookupList y env ]
[ cat | arg <- args, y <- varsInTTerm arg, cat <- lookupList y env ]
----------------------------------------------------------------------

28
src/GF/Conversion/Types.hs
View File

@@ -4,9 +4,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/12 10:49:44 $
-- > CVS $Date: 2005/04/14 11:42:05 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
-- > CVS $Revision: 1.3 $
--
-- All possible instantiations of different grammar formats used in conversion from GFC
-----------------------------------------------------------------------------
@@ -49,20 +49,31 @@ name2fun (Name fun _) = fun
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
| Constant a
deriving (Eq, Ord, Show)
instance Functor Profile where
fmap f (Constant a) = Constant (f a)
fmap f (Unify xs) = Unify xs
-- | a function name where the profile does not contain
constantNameToForest :: Name -> SyntaxForest Fun
constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile]
where unConstant (Constant a) = a
unConstant (Unify []) = FMeta
unConstant _ = error $ "constantNameToForest: the profile should not contain arguments: " ++ prt name
-- | 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
apply (Constant 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
apply (Constant a) = return a
-- | profile composition:
--
@@ -76,13 +87,13 @@ applyProfileM unify profile args = mapM apply profile
-- > ==
-- > p (q arg)
--
-- Note that composing an 'Epsilon' with two or more arguments returns an error
-- Note that composing an 'Constant' 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
compose constant = constant
@@ -103,7 +114,6 @@ type SPath = Path SCat Token
type STerm = Term SCat Token
type SLinType = LinType SCat Token
type SDecl = Decl SCat
type SType = Type SCat
----------------------------------------------------------------------
-- * MCFG
@@ -159,6 +169,6 @@ instance Print Name where
instance Print a => Print (Profile a) where
prt (Unify []) = "?"
prt (Unify args) = prtSep "=" args
prt (Epsilon a) = prt a
prt (Constant a) = prt a