From 19b17dceb6a1882ee779e75b9703d7fd2b93cc95 Mon Sep 17 00:00:00 2001 From: krasimir Date: Tue, 16 Feb 2010 09:34:02 +0000 Subject: [PATCH] no need to keep the list of constructors per category in .gfo --- src/compiler/GF/Compile/CheckGrammar.hs | 4 ++-- src/compiler/GF/Compile/GrammarToPGF.hs | 4 ++-- src/compiler/GF/Compile/Rename.hs | 3 +-- src/compiler/GF/Compile/Update.hs | 4 ++-- src/compiler/GF/Grammar/Binary.hs | 4 ++-- src/compiler/GF/Grammar/CF.hs | 4 ++-- src/compiler/GF/Grammar/Grammar.hs | 2 +- src/compiler/GF/Grammar/Lookup.hs | 6 +++--- src/compiler/GF/Grammar/Macros.hs | 2 +- src/compiler/GF/Grammar/Parser.y | 10 +++++----- src/compiler/GF/Grammar/Printer.hs | 11 ++++------- 11 files changed, 25 insertions(+), 29 deletions(-) diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index f4765eb26..84ecdde0a 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -121,7 +121,7 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do return $ updateTree (c,CncFun (Just linty) (Just def) Nothing) js Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c return js - AbsCat (Just _) _ -> case lookupIdent c js of + AbsCat (Just _) -> case lookupIdent c js of Ok (AnyInd _ _) -> return js Ok (CncCat (Just _) _ _) -> return js Ok (CncCat _ mt mp) -> do @@ -156,7 +156,7 @@ checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info checkInfo ms (m,mo) c info = do checkReservedId c case info of - AbsCat (Just cont) _ -> mkCheck "category" $ + AbsCat (Just cont) -> mkCheck "category" $ checkContext gr cont AbsFun (Just typ0) ma md -> do diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 1b2b68f63..ce857d3f9 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -71,7 +71,7 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f] funs = Map.fromAscList lfuns lcats = [(i2i c, snd (mkContext [] cont)) | - (c,AbsCat (Just cont) _) <- tree2list (M.jments abm)] + (c,AbsCat (Just cont)) <- tree2list (M.jments abm)] cats = Map.fromAscList lcats catfuns = Map.fromList [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] @@ -240,7 +240,7 @@ reorder abs cg = M.MGrammar $ adefs = sorted2tree $ sortIds $ predefADefs ++ Look.allOrigInfos cg abs predefADefs = - [(c, AbsCat (Just []) Nothing) | c <- [cFloat,cInt,cString]] + [(c, AbsCat (Just [])) | c <- [cFloat,cInt,cString]] aflags = concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index b3f3426da..59a8c6a3d 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -141,8 +141,7 @@ renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info renameInfo mo status i info = checkIn (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $ case info of - AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) - (renPerh (mapM rent) pfs) + AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr) ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) ResOverload os tysts -> diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 1e39a2e03..6ee0dc65b 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -169,8 +169,8 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old unifyAnyInfo :: Ident -> Info -> Info -> Err Info unifyAnyInfo m i j = case (i,j) of - (AbsCat mc1 mf1, AbsCat mc2 mf2) -> - liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs + (AbsCat mc1, AbsCat mc2) -> + liftM AbsCat (unifMaybe mc1 mc2) (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) -> liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 7e56492cb..8ac7f4dea 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -87,7 +87,7 @@ instance Binary Options where Bad msg -> fail msg instance Binary Info where - put (AbsCat x y) = putWord8 0 >> put (x,y) + put (AbsCat x) = putWord8 0 >> put x put (AbsFun x y z) = putWord8 1 >> put (x,y,z) put (ResParam x y) = putWord8 2 >> put (x,y) put (ResValue x) = putWord8 3 >> put x @@ -98,7 +98,7 @@ instance Binary Info where put (AnyInd x y) = putWord8 8 >> put (x,y) get = do tag <- getWord8 case tag of - 0 -> get >>= \(x,y) -> return (AbsCat x y) + 0 -> get >>= \x -> return (AbsCat x) 1 -> get >>= \(x,y,z) -> return (AbsFun x y z) 2 -> get >>= \(x,y) -> return (ResParam x y) 3 -> get >>= \x -> return (ResValue x) diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs index a1d716994..e883d0552 100644 --- a/src/compiler/GF/Grammar/CF.hs +++ b/src/compiler/GF/Grammar/CF.hs @@ -99,9 +99,9 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where cat = case rules of (_,(c,_)):_ -> c -- the value category of the first rule _ -> error "empty CF" - cats = [(cat, AbsCat (Just []) (Just [])) | + cats = [(cat, AbsCat (Just [])) | cat <- nub (concat (map cf2cat rules))] ----notPredef cat - lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _ _) <- cats] + lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _) <- cats] (funs,lins) = unzip (map cf2rule rules) cf2cat :: CFRule -> [Ident] diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index e0ca01341..b39e0f160 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -75,7 +75,7 @@ mapSourceModule f (i,mi) = (i, f mi) -- and indirection to module (/INDIR/) data Info = -- judgements in abstract syntax - AbsCat (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) the second parameter is list of constructors - must be 'Id' or 'QId' + AbsCat (Maybe Context) | AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function -- judgements in resource diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index d56c1ee30..14f1ab498 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -183,6 +183,6 @@ lookupCatContext gr m c = do mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of - AbsCat (Just co) _ -> return co - AnyInd _ n -> lookupCatContext gr n c - _ -> Bad (render (text "unknown category" <+> ppIdent c)) + AbsCat (Just co) -> return co + AnyInd _ n -> lookupCatContext gr n c + _ -> Bad (render (text "unknown category" <+> ppIdent c)) diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 799cd9ec5..ef68b740d 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -615,7 +615,7 @@ allDependencies ism b = CncCat pty _ _ -> [pty] CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual - AbsCat (Just co) _ -> [Just ty | (_,_,ty) <- co] + AbsCat (Just co) -> [Just ty | (_,_,ty) <- co] _ -> [] topoSortJments :: SourceModule -> Err [(Ident,Info)] diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index ef4a5d84b..2a08caa1b 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -232,7 +232,7 @@ TopDef CatDef :: { [(Ident,SrcSpan,Info)] } CatDef - : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3) Nothing)] } + : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3))] } | Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 } | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) } @@ -247,9 +247,9 @@ DefDef DataDef :: { [(Ident,SrcSpan,Info)] } DataDef - : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) : + : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing) : [(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] } - | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing (Just (map Cn $2))) : + | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing) : [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] } ParamDef :: { [(Ident,SrcSpan,Info)] } @@ -621,7 +621,7 @@ 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])) + catd = (listId, pos, AbsCat (Just cont')) nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing) consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing) @@ -679,7 +679,7 @@ type SrcSpan = (Posn,Posn) checkInfoType MTAbstract (id,pos,info) = case info of - AbsCat _ _ -> return () + AbsCat _ -> return () AbsFun _ _ _ -> return () _ -> failLoc (fst pos) "illegal definition in abstract module" checkInfoType MTResource (id,pos,info) = diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index befc61932..4ead4e0bb 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -25,7 +25,7 @@ import GF.Grammar.Values import GF.Grammar.Grammar import Text.PrettyPrint -import Data.Maybe (maybe) +import Data.Maybe (maybe, isNothing) import Data.List (intersperse) import qualified Data.Map as Map @@ -71,17 +71,14 @@ ppOptions opts = text "flags" $$ nest 2 (vcat [text option <+> equals <+> str value <+> semi | (option,value) <- optionsGFO opts]) -ppJudgement q (id, AbsCat pcont pconstrs) = +ppJudgement q (id, AbsCat pcont ) = text "cat" <+> ppIdent id <+> (case pcont of Just cont -> hsep (map (ppDecl q) cont) - Nothing -> empty) <+> semi $$ - case pconstrs of - Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi - Nothing -> empty + Nothing -> empty) <+> semi ppJudgement q (id, AbsFun ptype _ pexp) = (case ptype of - Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi + Just typ -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi Nothing -> empty) $$ (case pexp of Just [] -> empty