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

some work on evaluation with abstract expressions in PGF

Browse Source
This commit is contained in:
krasimir
2009-05-22 18:54:51 +00:00
parent f29bdd762e
commit f9c877eec6
32 changed files with 207 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/GF/Grammar/Binary.hs
View File

@@ -90,7 +90,7 @@ instance Binary Options where
instance Binary Info where
put (AbsCat x y) = putWord8 0 >> put (x,y)
put (AbsFun x y) = putWord8 1 >> put (x,y)
put (AbsFun x y z) = putWord8 1 >> put (x,y,z)
put (ResParam x) = putWord8 2 >> put x
put (ResValue x) = putWord8 3 >> put x
put (ResOper x y) = putWord8 4 >> put (x,y)
@@ -101,7 +101,7 @@ instance Binary Info where
get = do tag <- getWord8
case tag of
0 -> get >>= \(x,y) -> return (AbsCat x y)
1 -> get >>= \(x,y) -> return (AbsFun x y)
1 -> get >>= \(x,y,z) -> return (AbsFun x y z)
2 -> get >>= \x -> return (ResParam x)
3 -> get >>= \x -> return (ResValue x)
4 -> get >>= \(x,y) -> return (ResOper x y)

8
src/GF/Grammar/Grammar.hs
View File

@@ -41,7 +41,6 @@ module GF.Grammar.Grammar (SourceGrammar,
Param,
Altern,
Substitution,
wildPatt,
varLabel, tupleLabel, linLabel, theLinLabel,
ident2label, label2ident
) where
@@ -80,8 +79,8 @@ type PValues = [Term]
-- and indirection to module (/INDIR/)
data Info =
-- judgements in abstract syntax
AbsCat (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
| AbsFun (Maybe Type) (Maybe [Equation]) -- ^ (/ABS/)
AbsCat (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) the second parameter is list of constructors - must be 'Id' or 'QId'
| AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function
-- judgements in resource
| ResParam (Maybe ([Param],Maybe PValues)) -- ^ (/RES/)
@@ -229,6 +228,3 @@ ident2label c = LIdent (ident2bs c)
label2ident :: Label -> Ident
label2ident (LIdent s) = identC s
label2ident (LVar i) = identC (BS.pack ('$':show i))
wildPatt :: Patt
wildPatt = PV identW

18
src/GF/Grammar/Lookup.hs
View File

@@ -121,7 +121,7 @@ lookupResType gr m c = do
mu <- lookupModule gr a
info <- lookupIdentInfo mu c
case info of
AbsFun (Just ty) _ -> return $ redirectTerm e ty
AbsFun (Just ty) _ _ -> return $ redirectTerm e ty
AbsCat _ _ -> return typeType
AnyInd _ n -> lookFun e m c n
_ -> prtBad "cannot find type of reused function" c
@@ -227,14 +227,14 @@ qualifAnnotPar m t = case t of
Con c -> QC m c
_ -> composSafeOp (qualifAnnotPar m) t
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe [Equation])
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsFun _ (Just t) -> return (Just t)
AnyInd _ n -> lookupAbsDef gr n c
_ -> return Nothing
AbsFun _ a d -> return (a,d)
AnyInd _ n -> lookupAbsDef gr n c
_ -> return (Nothing,Nothing)
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
@@ -252,9 +252,9 @@ lookupFunType gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsFun (Just t) _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
AbsFun (Just t) _ _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
-- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -281,7 +281,7 @@ opersForType gr orig val =
let cat = err error snd (valCat orig) in --- ignore module
[(f,ty) |
Ok a <- [abstractOfConcrete gr i >>= lookupModule gr],
(f, AbsFun (Just ty0) _) <- tree2list $ jments a,
(f, AbsFun (Just ty0) _ _) <- tree2list $ jments a,
let ty = redirectTerm i ty0,
Ok valt <- [valCat ty],
cat == snd valt ---

3
src/GF/Grammar/Macros.hs
View File

@@ -414,7 +414,8 @@ linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
term2patt :: Term -> Err Patt
term2patt trm = case termForm trm of
Ok ([], Vr x, []) -> return (PV x)
Ok ([], Vr x, []) | x == identW -> return PW
| otherwise -> return (PV x)
Ok ([], Val te ty x, []) -> do
te' <- term2patt te
return (PVal te' ty x)

20
src/GF/Grammar/Parser.y
View File

@@ -240,19 +240,19 @@ CatDef
FunDef :: { [(Ident,SrcSpan,Info)] }
FunDef
: Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) (Just [])) | fun <- $2] }
: Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] }
DefDef :: { [(Ident,SrcSpan,Info)] }
DefDef
: Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just [([],$4)])) | f <- $2] }
| Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just [($3,$5)]))] }
: Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] }
| Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] }
DataDef :: { [(Ident,SrcSpan,Info)] }
DataDef
: Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) :
[(fun, ($1,$5), AbsFun Nothing Nothing) | fun <- $4] }
[(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] }
| Posn ListIdent ':' Exp Posn { [(cat, ($1,$5), AbsCat Nothing (Just (map Cn $2))) | Ok (_,cat) <- [valCat $4]] ++
[(fun, ($1,$5), AbsFun (Just $4) Nothing) | fun <- $2] }
[(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] }
ParamDef :: { [(Ident,SrcSpan,Info)] }
ParamDef
@@ -481,7 +481,7 @@ Patt2
| '[' String ']' { PChars $2 }
| '#' Ident { PMacro $2 }
| '#' Ident '.' Ident { PM $2 $4 }
| '_' { wildPatt }
| '_' { PW }
| Ident { PV $1 }
| Ident '.' Ident { PP $1 $3 [] }
| Integer { PInt $1 }
@@ -609,8 +609,8 @@ listCatDef id pos cont size = [catd,nilfund,consfund]
consId = mkConsId id
catd = (listId, pos, AbsCat (Just cont') (Just [Cn baseId,Cn consId]))
nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing)
consfund = (consId, pos, AbsFun (Just constyp) Nothing)
nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing)
consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing)
cont' = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont]
xs = map (Vr . fst) cont'
@@ -667,7 +667,7 @@ type SrcSpan = (Posn,Posn)
checkInfoType MTAbstract (id,pos,info) =
case info of
AbsCat _ _ -> return ()
AbsFun _ _ -> return ()
AbsFun _ _ _ -> return ()
_ -> failLoc (fst pos) "illegal definition in abstract module"
checkInfoType MTResource (id,pos,info) =
case info of
@@ -701,7 +701,7 @@ checkInfoType (MTInstance _) (id,pos,info) =
checkInfoType (MTTransfer _ _) (id,pos,info) =
case info of
AbsCat _ _ -> return ()
AbsFun _ _ -> return ()
AbsFun _ _ _ -> return ()
_ -> failLoc (fst pos) "illegal definition in transfer module"

2
src/GF/Grammar/Printer.hs
View File

@@ -79,7 +79,7 @@ ppJudgement q (id, AbsCat pcont pconstrs) =
case pconstrs of
Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi
Nothing -> empty
ppJudgement q (id, AbsFun ptype pexp) =
ppJudgement q (id, AbsFun ptype _ pexp) =
(case ptype of
Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$