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

refactor the PGF.Expr type and the evaluation of abstract expressions

Browse Source
This commit is contained in:
krasimir
2009-05-20 21:03:56 +00:00
parent 401dfc28d6
commit 7db4b641ce
32 changed files with 245 additions and 360 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/GF/Command/Commands.hs
View File

@@ -600,11 +600,11 @@ allCommands cod env@(pgf, mos) = Map.fromList [
exec = \opts arg -> do
case arg of
[Fun id []] -> case Map.lookup id (funs (abstract pgf)) of
Just (ty,def) -> return $ fromString $
Just (ty,eqs) -> return $ fromString $
render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 ty $$
if def == EEq []
if null eqs
then empty
else text "def" <+> text (prCId id) <+> char '=' <+> ppExpr 0 def)
else text "def" <+> vcat [text (prCId id) <+> hsep (map (ppPatt 9) patts) <+> char '=' <+> ppExpr 0 res | Equ patts res <- eqs])
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just hyps -> do return $ fromString $
render (text "cat" <+> text (prCId id) <+> hsep (map ppHypo hyps) $$

6
src/GF/Command/TreeOperations.hs
View File

@@ -4,10 +4,8 @@ module GF.Command.TreeOperations (
) where
import GF.Compile.TypeCheck
import PGF (compute,paraphrase,typecheck)
import PGF
-- for conversions
import PGF.Data
--import GF.Compile.GrammarToGFCC (mkType,mkExp)
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.Macros as M
@@ -22,7 +20,7 @@ treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
allTreeOps :: PGF -> [(String,(String,TreeOp))]
allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)",
map (compute pgf))),
map (expr2tree pgf . tree2expr))),
("paraphrase",("paraphrase by using semantic definitions (def)",
nub . concatMap (paraphrase pgf))),
("smallest",("sort trees from smallest to largest, in number of nodes",

9
src/GF/Compile/AbsCompute.hs
View File

@@ -42,7 +42,7 @@ computeAbsTerm :: Grammar -> Exp -> Err Exp
computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
-- | a hack to make compute work on source grammar as well
type LookDef = Ident -> Ident -> Err (Maybe Term)
type LookDef = Ident -> Ident -> Err (Maybe [Equation])
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
@@ -55,7 +55,7 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
let vv' = yy ++ vv
aa' <- mapM (compt vv') aa
case look f of
Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $
Just eqs -> tracd ("\nmatching" +++ prt f) $
case findMatch eqs aa' of
Ok (d,g) -> do
--- let (xs,ts) = unzip g
@@ -67,19 +67,14 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
do
let v = mkApp f aa'
return $ mkAbs yy $ v
Just d -> tracd ("define" +++ prt t') $ do
da <- compt vv' $ mkApp d aa'
return $ mkAbs yy $ da
_ -> do
let t2 = mkAbs yy $ mkApp f aa'
tracd ("not defined" +++ prt_ t2) $ return t2
look t = case t of
(Q m f) -> case lookd m f of
Ok (Just EData) -> Nothing -- canonical --- should always be QC
Ok md -> md
_ -> Nothing
Eqs _ -> return t ---- for nested fn
_ -> Nothing
beta :: [Ident] -> Exp -> Exp

29
src/GF/Compile/CheckGrammar.hs
View File

@@ -124,16 +124,14 @@ checkAbsInfo st m mo (c,info) = do
AbsCat (Just cont) _ -> mkCheck "category" $
checkContext st cont ---- also cstrs
AbsFun (Just typ0) md -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions
mkCheck "type of function" $ checkTyp st typ
md' <- case md of
Just d -> do
let d' = elimTables d
---- mkCheckWarn "definition of function" $ checkEquation st (m,c) d'
mkCheck "definition of function" $ checkEquation st (m,c) d'
return $ Just d'
_ -> return md
return $ (c,AbsFun (Just typ) md')
typ <- compAbsTyp [] typ0 -- to calculate let definitions
mkCheck "type of function" $
checkTyp st typ
case md of
Just eqs -> mkCheck "definition of function" $
checkDef st (m,c) typ eqs
Nothing -> return (c,info)
return $ (c,AbsFun (Just typ) md)
_ -> return (c,info)
where
mkCheck cat ss = case ss of
@@ -161,17 +159,6 @@ checkAbsInfo st m mo (c,info) = do
Abs _ _ -> return t
_ -> composOp (compAbsTyp g) t
elimTables e = case e of
S t a -> elimSel (elimTables t) (elimTables a)
T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs]
_ -> composSafeOp elimTables e
elimPatt p = case p of
PR lps -> map snd lps
_ -> [p]
elimSel t a = case a of
R fs -> mkApp t (map (snd . snd) fs)
_ -> mkApp t [a]
checkCompleteGrammar :: SourceGrammar -> SourceModInfo -> SourceModInfo -> Check (BinTree Ident Info)
checkCompleteGrammar gr abs cnc = do
let jsa = jments abs

2
src/GF/Compile/GFCCtoJS.hs
View File

@@ -34,7 +34,7 @@ pgf2js pgf =
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(Type,Expr)) -> JS.Property
absdef2js :: (CId,(Type,[Equation])) -> JS.Property
absdef2js (f,(typ,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])

29
src/GF/Compile/GFCCtoProlog.hs
View File

@@ -71,17 +71,17 @@ plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ)
args = reverse [EVar x | (_,x) <- subst]
typ = wildcardUnusedVars $ DTyp hypos' cat args
plFun :: (CId, (Type, Expr)) -> String
plFun :: (CId, (Type, [Equation])) -> String
plFun (fun, (typ, _)) = plFact "fun" (plp fun : plTypeWithHypos typ')
where typ' = wildcardUnusedVars $ snd $ alphaConvert emptyEnv typ
plTypeWithHypos :: Type -> [String]
plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plp hypos]
plFundef :: (CId, (Type, Expr)) -> [String]
plFundef (fun, (_, EEq [])) = []
plFundef (fun, (_, fundef)) = [plFact "def" [plp fun, plp fundef']]
where fundef' = snd $ alphaConvert emptyEnv fundef
plFundef :: (CId, (Type, [Equation])) -> [String]
plFundef (fun, (_, [])) = []
plFundef (fun, (_, eqs)) = [plFact "def" [plp fun, plp fundef']]
where fundef' = snd $ alphaConvert emptyEnv eqs
----------------------------------------------------------------------
@@ -122,8 +122,14 @@ instance PLPrint Expr where
plp (EApp e e') = plOper " * " (plp e) (plp e')
plp (ELit lit) = plp lit
plp (EMeta n) = "Meta_" ++ show n
plp (EEq eqs) = plList [plOper ":" (plp patterns) (plp result) |
Equ patterns result <- eqs]
instance PLPrint Patt where
plp (PVar x) = plp x
plp (PApp f ps) = plOper " * " (plp f) (plp ps)
plp (PLit lit) = plp lit
instance PLPrint Equation where
plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
instance PLPrint Term where
plp (S terms) = plTerm "s" [plp terms]
@@ -267,17 +273,14 @@ instance AlphaConvert Expr where
where (env', e1') = alphaConvert env e1
(env'', e2') = alphaConvert env' e2
alphaConvert env expr@(EVar i) = (env, maybe expr EVar (lookup i (snd env)))
alphaConvert env (EEq eqs) = (env', EEq eqs')
where (env', eqs') = alphaConvert env eqs
alphaConvert env expr = (env, expr)
-- pattern variables are not alpha converted
-- (but they probably should be...)
instance AlphaConvert Equation where
alphaConvert env@(_,subst) (Equ patterns result)
= ((ctr,subst), Equ patterns' result')
where (env', patterns') = alphaConvert env patterns
((ctr,_), result') = alphaConvert env' result
= ((ctr,subst), Equ patterns result')
where ((ctr,_), result') = alphaConvert env result
----------------------------------------------------------------------
-- translate unused variables to wildcards
@@ -295,6 +298,4 @@ wildcardUnusedVars typ@(DTyp hypos cat args) = DTyp hypos' cat args
unusedInExpr x (EAbs y e) = unusedInExpr x e
unusedInExpr x (EApp e e') = unusedInExpr x e && unusedInExpr x e'
unusedInExpr x (EVar y) = x/=y
unusedInExpr x (EEq eqs) = and [all (unusedInExpr x) (result:patterns) |
Equ patterns result <- eqs]
unusedInExpr x expr = True

8
src/GF/Compile/GenerateFCFG.hs
View File

@@ -43,7 +43,7 @@ convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats'
cats = lincats cnc
(abs_defs',conc',cats') = expandHOAS abs_defs conc cats
expandHOAS :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],TermMap,TermMap)
expandHOAS :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,[Equation]))],TermMap,TermMap)
expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
Map.unions [lins, hoLins, varLins],
Map.unions [lincats, hoLincats, varLincat])
@@ -59,14 +59,14 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
hoCats = sortNub (map snd hoTypes)
-- for each Cat with N bindings, we add a new category _NCat
-- each new category contains a single function __NCat : Cat -> _Var -> ... -> _Var -> _NCat
hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),EEq [])) | ty@(n,c) <- hoTypes]
hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),[])) | ty@(n,c) <- hoTypes]
-- lincats for the new categories
hoLincats = Map.fromList [(catName ty, modifyRec (++ replicate n (S [])) (lincatOf c)) | ty@(n,c) <- hoTypes]
-- linearizations of the new functions, lin __NCat v_0 ... v_n-1 x = { s1 = x.s1; ...; sk = x.sk; $0 = v_0.s ...
hoLins = Map.fromList [ (funName ty, mkLin c n) | ty@(n,c) <- hoTypes]
where mkLin c n = modifyRec (\fs -> [P (V 0) (C j) | j <- [0..length fs-1]] ++ [P (V i) (C 0) | i <- [1..n]]) (lincatOf c)
-- for each Cat, we a add a fun _Var_Cat : _Var -> Cat
varFuns = [(varFunName cat, (cftype [varCat] cat,EEq [])) | cat <- hoCats]
varFuns = [(varFunName cat, (cftype [varCat] cat,[])) | cat <- hoCats]
-- linearizations of the _Var_Cat functions
varLins = Map.fromList [(varFunName cat, R [P (V 0) (C 0)]) | cat <- hoCats]
-- lincat for the _Var category
@@ -98,7 +98,7 @@ fixHoasFuns pinfo = pinfo{functions=mkArray [FFun (fixName n) prof lins | FFun n
| BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
fixName n = n
convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ParserInfo
convert :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ParserInfo
convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv)
where
srules = [

2
src/GF/Compile/GeneratePMCFG.hs
View File

@@ -38,7 +38,7 @@ convertConcrete abs cnc = convert abs_defs conc cats
conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
cats = lincats cnc
convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ParserInfo
convert :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ParserInfo
convert abs_defs cnc_defs cat_defs =
let env = expandHOAS abs_defs cnc_defs cat_defs (emptyGrammarEnv cnc_defs cat_defs)
in getParserInfo (List.foldl' (convertRule cnc_defs) env pfrules)

24
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -68,9 +68,9 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
abs = D.Abstr aflags funs cats catfuns
gflags = Map.empty
aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)]
mkDef pty = case pty of
Just t -> mkExp t
_ -> CM.primNotion
mkDef (Just eqs) = [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
mkDef Nothing = []
-- concretes
lfuns = [(f', (mkType ty, mkDef pty)) |
@@ -119,9 +119,7 @@ mkType t = case GM.typeForm t of
Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
mkExp :: A.Term -> C.Expr
mkExp t = case t of
A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
_ -> case GM.termForm t of
mkExp t = case GM.termForm t of
Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args))
where
mkAbs xs t = foldr (C.EAbs . i2i) t xs
@@ -134,11 +132,15 @@ mkExp t = case t of
K s -> C.ELit (C.LStr s)
Meta (MetaSymb i) -> C.EMeta i
_ -> C.EMeta 0
mkPatt p = case p of
A.PP _ c ps -> foldl C.EApp (C.EVar (i2i c)) (map mkPatt ps)
A.PV x -> C.EVar (i2i x)
A.PW -> C.EVar wildCId
A.PInt i -> C.ELit (C.LInt i)
mkPatt p = case p of
A.PP _ c ps -> C.PApp (i2i c) (map mkPatt ps)
A.PV x -> C.PVar (i2i x)
A.PW -> C.PWild
A.PInt i -> C.PLit (C.LInt i)
A.PFloat f -> C.PLit (C.LFlt f)
A.PString s -> C.PLit (C.LStr s)
mkContext :: A.Context -> [C.Hypo]
mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]

2
src/GF/Compile/PGFPretty.hs
View File

@@ -31,7 +31,7 @@ prCat :: CId -> [Hypo] -> Doc
prCat c h | isLiteralCat c = empty
| otherwise = text "cat" <+> text (prCId c)
prFun :: CId -> (Type,Expr) -> Doc
prFun :: CId -> (Type,[Equation]) -> Doc
prFun f (t,_) = text "fun" <+> text (prCId f) <+> text ":" <+> prType t
prType :: Type -> Doc

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

@@ -116,7 +116,7 @@ renameIdentPatt env p = do
info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
info2status mq (c,i) = case i of
AbsFun _ (Just EData) -> maybe Con QC mq
AbsFun _ Nothing -> maybe Con QC mq
ResValue _ -> maybe Con QC mq
ResParam _ -> maybe Con QC mq
AnyInd True m -> maybe Con (const (QC m)) mq
@@ -156,8 +156,7 @@ renameInfo mo status (i,info) = errIn
liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
AbsFun pty ptr -> liftM2 AbsFun (ren pty) (renPerh (mapM (renameEquation status [])) ptr)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResOverload os tysts ->
liftM (ResOverload os) (mapM (pairM rent) tysts)
@@ -191,7 +190,6 @@ renameTerm env vars = ren vars where
Con _ -> renid trm
Q _ _ -> renid trm
QC _ _ -> renid trm
Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
T i cs -> do
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source

7
src/GF/Compile/TC.hs
View File

@@ -16,6 +16,7 @@ module GF.Compile.TC (AExp(..),
Theory,
checkExp,
inferExp,
checkBranch,
eqVal,
whnf
) where
@@ -122,7 +123,6 @@ checkExp th tenv@(k,rho,gamma) e ty = do
let v = VGen k
case e of
Meta m -> return $ (AMeta m typ,[])
EData -> return $ (AData typ,[])
Abs x t -> case typ of
VClos env (Prod y a b) -> do
@@ -132,11 +132,6 @@ checkExp th tenv@(k,rho,gamma) e ty = do
return (AAbs x a' t', cs)
_ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ
Eqs es -> do
bcs <- mapM (\b -> checkBranch th tenv b typ) es
let (bs,css) = unzip bcs
return (AEqs bs, concat css)
Prod x a b -> do
testErr (typ == vType) "expected Type"
(a',csa) <- checkType th tenv a

13
src/GF/Compile/TypeCheck.hs
View File

@@ -15,7 +15,7 @@
module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should not be called directly.
checkContext,
checkTyp,
checkEquation,
checkDef,
checkConstrs,
) where
@@ -71,11 +71,12 @@ checkContext st = checkTyp st . cont2exp
checkTyp :: Grammar -> Type -> [String]
checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType
checkEquation :: Grammar -> Fun -> Term -> [String]
checkEquation gr (m,fun) def = err singleton prConstrs $ do
typ <- lookupFunType gr m fun
cs <- justTypeCheck gr def (vClos typ)
return $ filter notJustMeta cs
checkDef :: Grammar -> Fun -> Type -> [Equation] -> [String]
checkDef gr (m,fun) typ eqs = err singleton prConstrs $ do
bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs
let (bs,css) = unzip bcs
(constrs,_) <- unifyVal (concat css)
return $ filter notJustMeta constrs
checkConstrs :: Grammar -> Cat -> [Ident] -> [String]
checkConstrs gr cat _ = [] ---- check constructors!

14
src/GF/Compile/Update.hs
View File

@@ -163,7 +163,7 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
(b,n') = case info of
ResValue _ -> (True,n)
ResParam _ -> (True,n)
AbsFun _ (Just EData) -> (True,n)
AbsFun _ Nothing -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
@@ -203,13 +203,11 @@ unifMaybe (Just p1) (Just p2)
| p1==p2 = return (Just p1)
| otherwise = fail ""
unifAbsDefs :: Maybe Term -> Maybe Term -> Err (Maybe Term)
unifAbsDefs p1 p2 = case (p1,p2) of
(Nothing, _) -> return p2
(_, Nothing) -> return p1
(Just (Eqs bs), Just (Eqs ds))
-> return $ Just $ Eqs $ bs ++ ds --- order!
_ -> fail "definitions"
unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation])
unifAbsDefs Nothing Nothing = return Nothing
unifAbsDefs (Just _ ) Nothing = fail ""
unifAbsDefs Nothing (Just _ ) = fail ""
unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term])
unifConstrs p1 p2 = case (p1,p2) of

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

@@ -115,7 +115,6 @@ instance Binary Term where
put (Vr x) = putWord8 0 >> put x
put (Cn x) = putWord8 1 >> put x
put (Con x) = putWord8 2 >> put x
put (EData) = putWord8 3
put (Sort x) = putWord8 4 >> put x
put (EInt x) = putWord8 5 >> put x
put (EFloat x) = putWord8 6 >> put x
@@ -125,7 +124,6 @@ instance Binary Term where
put (Abs x y) = putWord8 10 >> put (x,y)
put (Meta x) = putWord8 11 >> put x
put (Prod x y z) = putWord8 12 >> put (x,y,z)
put (Eqs x) = putWord8 13 >> put x
put (Typed x y) = putWord8 14 >> put (x,y)
put (Example x y) = putWord8 15 >> put (x,y)
put (RecType x) = putWord8 16 >> put x
@@ -155,7 +153,6 @@ instance Binary Term where
0 -> get >>= \x -> return (Vr x)
1 -> get >>= \x -> return (Cn x)
2 -> get >>= \x -> return (Con x)
3 -> return (EData)
4 -> get >>= \x -> return (Sort x)
5 -> get >>= \x -> return (EInt x)
6 -> get >>= \x -> return (EFloat x)
@@ -165,7 +162,6 @@ instance Binary Term where
10 -> get >>= \(x,y) -> return (Abs x y)
11 -> get >>= \x -> return (Meta x)
12 -> get >>= \(x,y,z) -> return (Prod x y z)
13 -> get >>= \x -> return (Eqs x)
14 -> get >>= \(x,y) -> return (Typed x y)
15 -> get >>= \(x,y) -> return (Example x y)
16 -> get >>= \x -> return (RecType x)

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

@@ -81,7 +81,7 @@ type PValues = [Term]
data Info =
-- judgements in abstract syntax
AbsCat (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
| AbsFun (Maybe Type) (Maybe Term) -- ^ (/ABS/) 'Yes f' = canonical
| AbsFun (Maybe Type) (Maybe [Equation]) -- ^ (/ABS/)
-- judgements in resource
| ResParam (Maybe ([Param],Maybe PValues)) -- ^ (/RES/)
@@ -108,7 +108,6 @@ data Term =
Vr Ident -- ^ variable
| Cn Ident -- ^ constant
| Con Ident -- ^ constructor
| EData -- ^ to mark in definition that a fun is a constructor
| Sort Ident -- ^ basic type
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
@@ -119,8 +118,6 @@ data Term =
| Abs Ident Term -- ^ abstraction: @\x -> b@
| Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0)
| Prod Ident Term Term -- ^ function type: @(x : A) -> B@
| Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@
-- only used in internal representation
| Typed Term Term -- ^ type-annotated term
--
-- /below this, the constructors are only for concrete syntax/

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

@@ -227,7 +227,7 @@ qualifAnnotPar m t = case t of
Con c -> QC m c
_ -> composSafeOp (qualifAnnotPar m) t
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Term)
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe [Equation])
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c

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

@@ -593,10 +593,6 @@ composOp co trm =
i' <- changeTableType co i
return (TSh i' cc')
Eqs cc ->
do cc' <- mapPairListM (co . snd) cc
return (Eqs cc')
V ty vs ->
do ty' <- co ty
vs' <- mapM co vs

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

@@ -72,7 +72,6 @@ import GF.Compile.Update (buildAnyTree)
'data' { T_data }
'def' { T_def }
'flags' { T_flags }
'fn' { T_fn }
'fun' { T_fun }
'in' { T_in }
'incomplete' { T_incomplete}
@@ -241,19 +240,19 @@ CatDef
FunDef :: { [(Ident,SrcSpan,Info)] }
FunDef
: Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing) | fun <- $2] }
: Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) (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 (Eqs [($3,$5)])))] }
: 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)]))] }
DataDef :: { [(Ident,SrcSpan,Info)] }
DataDef
: Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) :
[(fun, ($1,$5), AbsFun Nothing (Just EData)) | 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) (Just EData)) | fun <- $2] }
: Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) :
[(fun, ($1,$5), AbsFun 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] }
ParamDef :: { [(Ident,SrcSpan,Info)] }
ParamDef
@@ -385,7 +384,6 @@ Exp
| Exp3 'where' '{' ListLocDef '}' {%
do defs <- mapM tryLoc $4
return $ mkLet defs $1 }
| 'fn' '{' ListEquation '}' { Eqs $3 }
| 'in' Exp5 String { Example $2 $3 }
| Exp1 { $1 }
@@ -441,7 +439,6 @@ Exp6
| Double { EFloat $1 }
| '?' { Meta (int2meta 0) }
| '[' ']' { Empty }
| 'data' { EData }
| '[' Ident Exps ']' { foldl App (Vr (mkListId $2)) $3 }
| '[' String ']' { case $2 of
[] -> Empty
@@ -486,7 +483,6 @@ Patt2
| '#' Ident '.' Ident { PM $2 $4 }
| '_' { wildPatt }
| Ident { PV $1 }
| '{' Ident '}' { PC $2 [] }
| Ident '.' Ident { PP $1 $3 [] }
| Integer { PInt $1 }
| Double { PFloat $1 }
@@ -569,15 +565,6 @@ ListCase
: Case { [$1] }
| Case ';' ListCase { $1 : $3 }
Equation :: { Equation }
Equation
: ListPatt '->' Exp { ($1,$3) }
ListEquation :: { [Equation] }
ListEquation
: Equation { (:[]) $1 }
| Equation ';' ListEquation { (:) $1 $3 }
Altern :: { (Term,Term) }
Altern
: Exp '/' Exp { ($1,$3) }
@@ -621,9 +608,9 @@ listCatDef id pos cont size = [catd,nilfund,consfund]
baseId = mkBaseId id
consId = mkConsId id
catd = (listId, pos, AbsCat (Just cont') (Just [Cn baseId,Cn consId]))
nilfund = (baseId, pos, AbsFun (Just niltyp) (Just EData))
consfund = (consId, pos, AbsFun (Just constyp) (Just EData))
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)
cont' = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont]
xs = map (Vr . fst) cont'

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

@@ -84,10 +84,8 @@ ppJudgement q (id, AbsFun ptype pexp) =
Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$
(case pexp of
Just EData -> empty
Just (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi
Just exp -> text "def" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty)
Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs]
Nothing -> empty)
ppJudgement q (id, ResParam pparams) =
text "param" <+> ppIdent id <+>
(case pparams of
@@ -145,9 +143,6 @@ ppTerm q d (Prod x a b)= if x == identW
ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt)
ppTerm q d (Let l e) = let (ls,e') = getLet e
in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e')
ppTerm q d (Eqs es) = text "fn" <+> lbrace $$
nest 2 (vcat (map (\e -> ppEquation q e <+> semi) es)) $$
rbrace
ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> text (show s))
ppTerm q d (C e1 e2) =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2)
ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2)
@@ -182,7 +177,6 @@ ppTerm q d (EInt n) = integer n
ppTerm q d (EFloat f) = double f
ppTerm q d (Meta _) = char '?'
ppTerm q d (Empty) = text "[]"
ppTerm q d (EData) = text "data"
ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+>
fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty},
equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))

9
src/GF/Source/GrammarToSource.hs
View File

@@ -75,10 +75,9 @@ mkTopDefs ds = ds
trAnyDef :: (Ident,Info) -> [P.TopDef]
trAnyDef (i,info) = let i' = tri i in case info of
AbsCat (Just co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]]
AbsFun (Just ty) (Just EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
AbsFun (Just ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of
Just t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
Nothing -> []
AbsFun (Just ty) Nothing -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
AbsFun (Just ty) (Just eqs) -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++
[P.DefDef [P.DPatt (mkName i') (map trp patts) (trt res)] | (patts,res) <- eqs]
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of
@@ -129,7 +128,6 @@ trt trm = case trm of
error $ "not yet sort " +++ show trm
App c a -> P.EApp (trt c) (trt a)
Abs x b -> P.EAbstr [trb x] (trt b)
Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
Meta m -> P.EMeta
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
@@ -178,7 +176,6 @@ trt trm = case trm of
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
FV ts -> P.EVariants $ map trt ts
Strs tt -> P.EStrs $ map trt tt
EData -> P.EData
Val te _ _ -> trt te ----
_ -> error $ "not yet" +++ show trm ----