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

refactoring in GF.Grammar.Macros

Browse Source
This commit is contained in:
krasimir
2009-09-21 06:56:39 +00:00
parent 96786c1136
commit af831e01a7
11 changed files with 74 additions and 112 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -163,7 +163,7 @@ checkCompleteGrammar gr abs cnc = do
_ -> False
checkOne js i@(c,info) = case info of
AbsFun (Just ty) _ _ -> do let mb_def = do
(cxt,(_,i),_) <- typeForm ty
let (cxt,(_,i),_) = typeForm ty
info <- lookupIdent i js
info <- case info of
(AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
@@ -224,7 +224,7 @@ checkResInfo gr mo mm c info = do
--- this can only be a partial guarantee, since matching
--- with value type is only possible if expected type is given
checkUniq $
sort [t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1, Ok (xs,t) <- [typeFormCnc x]]
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
return (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just (pcs,_)) -> chIn "parameter type" $ do
@@ -255,7 +255,7 @@ checkCncInfo gr m mo (a,abs) c info = do
CncFun _ (Just trm) mpr -> chIn "linearization of" $ do
typ <- checkErr $ lookupFunType gr a c
cat0 <- checkErr $ valCat typ
let cat0 = valCat typ
(cont,val) <- linTypeOfType gr m typ -- creates arg vars
(trm',_) <- check trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
checkPrintname gr mpr
@@ -574,7 +574,7 @@ inferLType gr trm = case trm of
_ -> False
inferPatt p = case p of
PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc
PP q c ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr q c)
PAs _ p -> inferPatt p
PNeg p -> inferPatt p
PAlt p q -> checks [inferPatt p, inferPatt q]
@@ -830,7 +830,7 @@ pattContext env typ p = case p of
PV x -> return [(Explicit,x,typ)]
PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- checkErr $ lookupResType cnc q c
(cont,v) <- checkErr $ typeFormCnc t
let (cont,v) = typeFormCnc t
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
(length cont == length ps)
checkEqLType env typ v (patt2term p)
@@ -998,7 +998,7 @@ ppType env ty =
-- | linearization types and defaults
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
linTypeOfType cnc m typ = do
(cont,cat) <- checkErr $ typeSkeleton typ
let (cont,cat) = typeSkeleton typ
val <- lookLin cat
args <- mapM mkLinArg (zip [0..] cont)
return (args, val)

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

@@ -126,8 +126,8 @@ b2b A.Implicit = C.Implicit
mkType :: [Ident] -> A.Type -> C.Type
mkType scope t =
case GM.typeForm t of
Ok (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
(hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
mkExp :: [Ident] -> A.Term -> C.Expr
mkExp scope t = case GM.termForm t of

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

@@ -127,7 +127,7 @@ evalCncInfo opts gr cnc abs (c,info) = do
return (CncCat ptyp pde' ppr')
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd (cont,val,[])) $$ text "of function") $ do
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
pde' <- case pde of
Just de -> liftM Just $ pEval ty de
Nothing -> return pde

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

@@ -239,7 +239,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k')
PP m c xs -> (mkApp (Q m c) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
_ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch")

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

@@ -42,7 +42,7 @@ type2val :: Type -> Val
type2val = VClos []
cont2exp :: Context -> Exp
cont2exp c = mkProd (c, eType, []) -- to check a context
cont2exp c = mkProd c eType [] -- to check a context
cont2val :: Context -> Val
cont2val = type2val . cont2exp

6
src/GF/Grammar/AppPredefined.hs
View File

@@ -50,11 +50,11 @@ typPredefined f
| f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt)
---- "read" -> (P : Type) -> Tok -> P
| f == cShow = return $ mkProd -- (P : PType) -> P -> Tok
([(Explicit,varP,typePType),(Explicit,identW,Vr varP)],typeStr,[])
[(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr []
| f == cToStr = return $ mkProd -- (L : Type) -> L -> Str
([(Explicit,varL,typeType),(Explicit,identW,Vr varL)],typeStr,[])
[(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr []
| f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
([(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)],Vr varL,[])
[(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []
| f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
| f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
| otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f))

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

@@ -110,7 +110,7 @@ cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items]
cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
cf2rule (fun, (cat, items)) = (def,ldef) where
f = identS fun
def = (f, AbsFun (Just (mkProd (args', Cn (identS cat), []))) Nothing Nothing)
def = (f, AbsFun (Just (mkProd args' (Cn (identS cat)) [])) Nothing Nothing)
args0 = zip (map (identS . ("x" ++) . show) [0..]) items
args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0]
args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0]

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

@@ -111,7 +111,7 @@ lookupResType gr m c = do
CncCat _ _ _ -> return typeType
CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
val' <- lock cat val
return $ mkProd (cont, val', [])
return $ mkProd cont val' []
CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
@@ -137,8 +137,8 @@ lookupOverload gr m c = do
case info of
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr x c) os
return $ [(map (\(b,x,t) -> t) args,(val,tr)) |
(ty,tr) <- tysts, Ok (args,val) <- [typeFormCnc ty]] ++
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
(ty,tr) <- tysts] ++
concat tss
AnyInd _ n -> lookupOverload gr n c
@@ -279,14 +279,12 @@ opersForType gr orig val =
opers i m val =
[(f,ty) |
(f,ResOper (Just ty) _) <- tree2list $ jments m,
Ok valt <- [valTypeCnc ty],
elem valt [val,orig]
elem (valTypeCnc ty) [val,orig]
] ++
let cat = err error snd (valCat orig) in --- ignore module
let cat = snd (valCat orig) in --- ignore module
[(f,ty) |
Ok a <- [abstractOfConcrete gr i >>= lookupModule gr],
(f, AbsFun (Just ty0) _ _) <- tree2list $ jments a,
let ty = redirectTerm i ty0,
Ok valt <- [valCat ty],
cat == snd valt ---
cat == snd (valCat ty) ---
]

9
src/GF/Grammar/MMacros.hs
View File

@@ -134,10 +134,10 @@ getMetaAtom a = case a of
_ -> Bad "the active node is not meta"
-}
cat2val :: Context -> Cat -> Val
cat2val cont cat = vClos $ mkApp (qq cat) [Meta i | i <- [1..length cont]]
cat2val cont cat = vClos $ mkApp (uncurry Q cat) [Meta i | i <- [1..length cont]]
val2cat :: Val -> Err Cat
val2cat v = val2exp v >>= valCat
val2cat v = liftM valCat (val2exp v)
substTerm :: [Ident] -> Substitution -> Term -> Term
substTerm ss g c = case c of
@@ -183,7 +183,7 @@ val2expP safe v = case v of
else substVal g e
VClos g e -> substVal g e
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
VCn c -> return $ qq c
VCn c -> return $ uncurry Q c
VGen i x -> if safe
then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v))
else return $ Vr $ x --- in editing, no alpha conversions presentv
@@ -214,9 +214,6 @@ freeVarsExp e = case e of
Prod _ x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
_ -> [] --- thus applies to abstract syntax only
mkJustProd :: Context -> Term -> Term
mkJustProd cont typ = mkProd (cont,typ,[])
int2var :: Int -> Ident
int2var = identC . BS.pack . ('$':) . show

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

@@ -31,89 +31,56 @@ import Data.Char (isDigit)
import Data.List (sortBy)
import Text.PrettyPrint
firstTypeForm :: Type -> Err (Context, Type)
firstTypeForm t = case t of
Prod b x a t -> do
(x', val) <- firstTypeForm t
return ((b,x,a):x',val)
_ -> return ([],t)
typeForm :: Type -> (Context, Cat, [Term])
typeForm t =
case t of
Prod b x a t ->
let (x', cat, args) = typeForm t
in ((b,x,a):x', cat, args)
App c a ->
let (_, cat, args) = typeForm c
in ([],cat,args ++ [a])
Q m c -> ([],(m,c),[])
QC m c -> ([],(m,c),[])
Sort c -> ([],(identW, c),[])
_ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
qTypeForm :: Type -> Err (Context, Cat, [Term])
qTypeForm t = case t of
Prod b x a t -> do
(x', cat, args) <- qTypeForm t
return ((b,x,a):x', cat, args)
App c a -> do
(_,cat, args) <- qTypeForm c
return ([],cat,args ++ [a])
Q m c ->
return ([],(m,c),[])
QC m c ->
return ([],(m,c),[])
_ ->
Bad (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
typeFormCnc :: Type -> (Context, Type)
typeFormCnc t =
case t of
Prod b x a t -> let (x', v) = typeFormCnc t
in ((b,x,a):x',v)
_ -> ([],t)
qq :: QIdent -> Term
qq (m,c) = Q m c
typeForm :: Type -> Err (Context, Cat, [Term])
typeForm = qTypeForm ---- no need to distinguish any more
typeFormCnc :: Type -> Err (Context, Type)
typeFormCnc t = case t of
Prod b x a t -> do
(x', v) <- typeFormCnc t
return ((b,x,a):x',v)
_ -> return ([],t)
valCat :: Type -> Err Cat
valCat :: Type -> Cat
valCat typ =
do (_,cat,_) <- typeForm typ
return cat
let (_,cat,_) = typeForm typ
in cat
valType :: Type -> Err Type
valType typ =
do (_,cat,xx) <- typeForm typ --- not optimal to do in this way
return $ mkApp (qq cat) xx
valType :: Type -> Type
valType typ =
let (_,cat,xx) = typeForm typ --- not optimal to do in this way
in mkApp (uncurry Q cat) xx
valTypeCnc :: Type -> Err Type
valTypeCnc typ =
do (_,ty) <- typeFormCnc typ
return ty
valTypeCnc :: Type -> Type
valTypeCnc typ = snd (typeFormCnc typ)
typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
typeRawSkeleton typ =
do (cont,typ) <- typeFormCnc typ
args <- mapM (\(b,x,t) -> typeRawSkeleton t) cont
return ([(length c, v) | (c,v) <- args], typ)
typeSkeleton :: Type -> ([(Int,Cat)],Cat)
typeSkeleton typ =
let (cont,cat,_) = typeForm typ
args = map (\(b,x,t) -> typeSkeleton t) cont
in ([(length c, v) | (c,v) <- args], cat)
type MCat = (Ident,Ident)
getMCat :: Term -> Err MCat
getMCat t = case t of
Q m c -> return (m,c)
QC m c -> return (m,c)
Sort c -> return (identW, c)
App f _ -> getMCat f
_ -> Bad (render (text "no qualified constant" <+> ppTerm Unqualified 0 t))
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do
(cont,val) <- typeRawSkeleton typ
cont' <- mapPairsM getMCat cont
val' <- getMCat val
return (cont',val')
catSkeleton :: Type -> Err ([MCat],MCat)
catSkeleton :: Type -> ([Cat],Cat)
catSkeleton typ =
do (args,val) <- typeSkeleton typ
return (map snd args, val)
let (args,val) = typeSkeleton typ
in (map snd args, val)
funsToAndFrom :: Type -> (MCat, [(MCat,[Int])])
funsToAndFrom t = errVal undefined $ do ---
(cs,v) <- catSkeleton t
let cis = zip cs [0..]
return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
funsToAndFrom :: Type -> (Cat, [(Cat,[Int])])
funsToAndFrom t =
let (cs,v) = catSkeleton t
cis = zip cs [0..]
in (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
typeFormConcrete :: Type -> Err (Context, Type)
typeFormConcrete t = case t of
@@ -123,9 +90,9 @@ typeFormConcrete t = case t of
_ -> return ([],t)
isRecursiveType :: Type -> Bool
isRecursiveType t = errVal False $ do
(cc,c) <- catSkeleton t -- thus recursivity on Cat level
return $ any (== c) cc
isRecursiveType t =
let (cc,c) = catSkeleton t -- thus recursivity on Cat level
in any (== c) cc
isHigherOrderType :: Type -> Bool
isHigherOrderType t = errVal True $ do -- pessimistic choice
@@ -159,11 +126,11 @@ appForm t = case t of
_ -> (t,[])
mkProdSimple :: Context -> Term -> Term
mkProdSimple c t = mkProd (c,t,[])
mkProdSimple c t = mkProd c t []
mkProd :: (Context, Term, [Term]) -> Term
mkProd ([], typ, args) = mkApp typ args
mkProd ((b,x,a):dd, typ, args) = Prod b x a (mkProd (dd, typ, args))
mkProd :: Context -> Term -> [Term] -> Term
mkProd [] typ args = mkApp typ args
mkProd ((b,x,a):dd) typ args = Prod b x a (mkProd dd typ args)
mkTerm :: ([(BindType,Ident)], Term, [Term]) -> Term
mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)
@@ -293,7 +260,7 @@ mkWildCases :: Term -> Term
mkWildCases = mkCases identW
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(Explicit,identW, ty) | ty <- tt], t, []) -- nondep prod
mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of

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

@@ -249,7 +249,7 @@ DataDef :: { [(Ident,SrcSpan,Info)] }
DataDef
: Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $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]] ++
| Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing (Just (map Cn $2))) :
[(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] }
ParamDef :: { [(Ident,SrcSpan,Info)] }