From af831e01a7baf6de9ac3a475368f7315c99797a7 Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 21 Sep 2009 06:56:39 +0000 Subject: [PATCH] refactoring in GF.Grammar.Macros --- src/GF/Compile/CheckGrammar.hs | 12 +-- src/GF/Compile/GrammarToGFCC.hs | 4 +- src/GF/Compile/Optimize.hs | 2 +- src/GF/Compile/TC.hs | 2 +- src/GF/Compile/TypeCheck.hs | 2 +- src/GF/Grammar/AppPredefined.hs | 6 +- src/GF/Grammar/CF.hs | 2 +- src/GF/Grammar/Lookup.hs | 14 ++-- src/GF/Grammar/MMacros.hs | 9 +-- src/GF/Grammar/Macros.hs | 131 ++++++++++++-------------------- src/GF/Grammar/Parser.y | 2 +- 11 files changed, 74 insertions(+), 112 deletions(-) diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 98cd17f23..67526b5b5 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -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) diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 18e262de7..9d0a45e41 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -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 diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index e83f0e912..f0308cb7c 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -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 diff --git a/src/GF/Compile/TC.hs b/src/GF/Compile/TC.hs index 8cc2ff45b..c319cbd4a 100644 --- a/src/GF/Compile/TC.hs +++ b/src/GF/Compile/TC.hs @@ -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") diff --git a/src/GF/Compile/TypeCheck.hs b/src/GF/Compile/TypeCheck.hs index f2f494c31..05b0b288a 100644 --- a/src/GF/Compile/TypeCheck.hs +++ b/src/GF/Compile/TypeCheck.hs @@ -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 diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs index 9e5b0d83a..ae7ffd2d3 100644 --- a/src/GF/Grammar/AppPredefined.hs +++ b/src/GF/Grammar/AppPredefined.hs @@ -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)) diff --git a/src/GF/Grammar/CF.hs b/src/GF/Grammar/CF.hs index 2a94bbfdb..a1d716994 100644 --- a/src/GF/Grammar/CF.hs +++ b/src/GF/Grammar/CF.hs @@ -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] diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index a85f54c90..0d31b0a9e 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -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) --- ] diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs index a0852421d..a7f746b66 100644 --- a/src/GF/Grammar/MMacros.hs +++ b/src/GF/Grammar/MMacros.hs @@ -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 diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index 289531331..8df25527a 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -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 diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y index a6d9ca455..4dea6b8ec 100644 --- a/src/GF/Grammar/Parser.y +++ b/src/GF/Grammar/Parser.y @@ -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)] }