GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

"Committed_by_peb"

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

6
src/GF/Compile/ShellState.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:53:38 $
-- > CVS $Date: 2005/04/14 11:42:05 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.41 $
-- > CVS $Revision: 1.42 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -190,7 +190,7 @@ updateShellState opts mcnc sh ((_,sgr,gr),rts) = do
let pinfosOld = map (CnvOld.pInfo opts cgr) concrs -- peb 18/6 (OBSOLETE)
let g2s = Cnv.gfc2simple
fin = Cnv.simple2finite
fin = Cnv.removeSingletons . Cnv.simple2finite
s2mN = Cnv.simple2mcfg_nondet
s2mS = Cnv.simple2mcfg_strict
-- ____ kan man ha flera '-conversion=X -conversion=Y'?

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

65
src/GF/Formalism/SimpleGFC.hs
View File

@@ -4,9 +4,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/12 10:49:45 $
-- > CVS $Date: 2005/04/14 11:42:05 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
-- > CVS $Revision: 1.3 $
--
-- Simplistic GFC format
-----------------------------------------------------------------------------
@@ -39,16 +39,29 @@ type SimpleRule c n t = Rule (Decl c) n (LinType c t) (Maybe (Term c t))
-- ** dependent type declarations
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
-- | 'Decl x c ts' == x is of type (c applied to ts)
data Decl c = Decl Var c [TTerm]
deriving (Eq, Ord, Show)
data TTerm = Constr :@ [TTerm]
| TVar Var
deriving (Eq, Ord, Show)
decl2cat :: Decl c -> c
decl2cat (_ ::: (cat :@ _)) = cat
decl2cat (Decl _ cat _) = cat
varsInTTerm :: TTerm -> [Var]
varsInTTerm tterm = vars tterm []
where vars (TVar x) = (x:)
vars (_ :@ ts) = foldr (.) id $ map vars ts
tterm2term :: TTerm -> Term c t
tterm2term (con :@ terms) = con :^ map tterm2term terms
tterm2term (TVar x) = Var x
term2tterm :: Term c t -> TTerm
term2tterm (con :^ terms) = con :@ map term2tterm terms
term2tterm (Var x) = TVar x
term2tterm term = error $ "term2tterm: illegal term"
-- ** linearization types and terms
@@ -172,38 +185,42 @@ lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt |
----------------------------------------------------------------------
instance Print c => Print (Decl c) where
prt (var ::: typ)
| var == anyVar = prt typ
| otherwise = prt var ++ ":" ++ prt typ
prt (Decl var cat args)
| null args = prVar ++ prt cat
| otherwise = "(" ++ prVar ++ prt cat ++ prtBefore " " args ++ ")"
where prVar | var == anyVar = ""
| otherwise = "?" ++ prt var ++ ":"
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 TTerm where
prt (con :@ args)
| null args = prt con
| otherwise = "(" ++ prt con ++ prtBefore " " args ++ ")"
prt (TVar var) = "?" ++ prt var
instance (Print c, Print t) => Print (LinType c t) where
prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
prt (RecT rec) = "{" ++ prtInterior ":" rec ++ "}"
prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")"
prt (ConT t ts) = prt t ++ "[" ++ prtSep "|" ts ++ "]"
prt (StrT) = "Str"
instance (Print c, Print t) => Print (Term c t) where
prt (Arg n c p) = prt c ++ "@" ++ prt n ++ "(" ++ prt p ++ ")"
prt (Arg n c p) = prt c ++ prt n ++ prt p
prt (c :^ []) = prt c
prt (c :^ ts) = prt c ++ prtList ts
prt (Rec rec) = "{" ++ concat [ prt l ++ "=" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
prt (Tbl tbl) = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ "; " | (p,t) <- tbl ] ++ "]"
prt (c :^ ts) = "(" ++ prt c ++ prtBefore " " ts ++ ")"
prt (Rec rec) = "{" ++ prtInterior "=" rec ++ "}"
prt (Tbl tbl) = "[" ++ prtInterior "=>" tbl ++ "]"
prt (Variants ts) = "{| " ++ prtSep " | " ts ++ " |}"
prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
prt (Token t) = prt t
prt (Token t) = "'" ++ prt t ++ "'"
prt (Empty) = "[]"
prt (Wildcard) = "_"
prt (term :. lbl) = prt term ++ "." ++ prt lbl
prt (term :! sel) = prt term ++ "!" ++ prt sel
prt (Var var) = "?" ++ prt var
prtInterior sep xys = if null str then str else init (init str)
where str = concat [ prt x ++ sep ++ prt y ++ "; " | (x,y) <- xys ]
instance (Print c, Print t) => Print (Path c t) where
prt (Path path) = concatMap prtEither (reverse path)
where prtEither (Left lbl) = "." ++ prt lbl

14
src/GF/Formalism/Utilities.hs
View File

@@ -4,9 +4,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:50 $
-- > CVS $Date: 2005/04/14 11:42:05 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
-- > CVS $Revision: 1.2 $
--
-- Basic type declarations and functions for grammar formalisms
-----------------------------------------------------------------------------
@@ -259,12 +259,18 @@ instance (Print s) => Print (Edge s) where
prtList = prtSep ""
instance (Print s) => Print (SyntaxTree s) where
prt (TNode s trees) = prt s ++ "^{" ++ prtSep " " trees ++ "}"
prt (TNode s trees)
| null trees = prt s
| otherwise = "(" ++ prt s ++ prtBefore " " trees ++ ")"
prt (TMeta) = "?"
prtList = prtAfter "\n"
instance (Print s) => Print (SyntaxForest s) where
prt (FNode s forests) = prt s ++ "^{" ++ prtSep " | " (map (prtSep " ") forests) ++ "}"
prt (FNode s []) = "(" ++ prt s ++ " - ERROR: null forests)"
prt (FNode s [[]]) = prt s
prt (FNode s [forests]) = "(" ++ prt s ++ prtBefore " " forests ++ ")"
prt (FNode s children) = "{" ++ prtSep " | " [ prt s ++ prtBefore " " forests |
forests <- children ] ++ "}"
prt (FMeta) = "?"
prtList = prtAfter "\n"

7
src/GF/UseGrammar/Custom.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/12 10:49:45 $
-- > CVS $Date: 2005/04/14 11:42:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.52 $
-- > CVS $Revision: 1.53 $
--
-- A database for customizable GF shell commands.
--
@@ -264,6 +264,9 @@ customGrammarPrinter =
-- obsolete, or only for testing:
,(strCI "simple", Prt2.prt . Cnv.gfc2simple . stateGrammarLang)
,(strCI "finite", Prt2.prt . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
,(strCI "single", Prt2.prt . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
,(strCI "sg-sg", Prt2.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
,(strCI "sg-sg-sg", Prt2.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
,(strCI "mcfg-old", Prt.prt . CnvOld.mcfg . statePInfoOld)
,(strCI "cfg-old", Prt.prt . CnvOld.cfg . statePInfoOld)
]

11
src/GF/UseGrammar/Parsing.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:53:39 $
-- > CVS $Date: 2005/04/14 11:42:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.16 $
-- > CVS $Revision: 1.17 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -57,12 +57,12 @@ parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree]
parseStringC opts0 sg cat s
---- to test peb's new parser 6/10/2003
---- (to be obsoleted by "newer" below
---- (to be obsoleted by "newer" below)
| oElem newParser opts0 = do
let pm = maybe "" id $ getOptVal opts0 useParser -- -parser=pm
ct = cfCat2Cat cat
ts <- checkErr $ NewOld.newParser pm sg ct s
mapM (checkErr . annotate (stateGrammarST sg)) ts
mapM (checkErr . annotate (stateGrammarST sg) . refreshMetas []) ts
---- to test peb's newer parser 7/4-05
| oElem newerParser opts0 = do
@@ -70,7 +70,8 @@ parseStringC opts0 sg cat s
pm = maybe "" id $ getOptVal opts0 useParser -- -parser=pm
tok = customOrDefault opts useTokenizer customTokenizer sg
ts <- return $ New.parse pm (pInfo sg) (absId sg) cat (tok s)
mapM (checkErr . annotate (stateGrammarST sg)) ts
ts' <- mapM (checkErr . annotate (stateGrammarST sg) . refreshMetas []) ts
return $ optIntOrAll opts flagNumber ts'
| otherwise = do
let opts = unionOptions opts0 $ stateOptions sg