GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-20 16:42:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

no need to keep the list of constructors per category in .gfo

Browse Source
This commit is contained in:
krasimir
2010-02-16 09:34:02 +00:00
parent 61287f3925
commit 19b17dceb6
11 changed files with 25 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -121,7 +121,7 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return $ updateTree (c,CncFun (Just linty) (Just def) Nothing) js return $ updateTree (c,CncFun (Just linty) (Just def) Nothing) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js return js
AbsCat (Just _) _ -> case lookupIdent c js of AbsCat (Just _) -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _) -> return js Ok (CncCat (Just _) _ _) -> return js
Ok (CncCat _ mt mp) -> do Ok (CncCat _ mt mp) -> do
@@ -156,7 +156,7 @@ checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info
checkInfo ms (m,mo) c info = do checkInfo ms (m,mo) c info = do
checkReservedId c checkReservedId c
case info of case info of
AbsCat (Just cont) _ -> mkCheck "category" $ AbsCat (Just cont) -> mkCheck "category" $
checkContext gr cont checkContext gr cont
AbsFun (Just typ0) ma md -> do AbsFun (Just typ0) ma md -> do

4
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -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] (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
funs = Map.fromAscList lfuns funs = Map.fromAscList lfuns
lcats = [(i2i c, snd (mkContext [] cont)) | 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 cats = Map.fromAscList lcats
catfuns = Map.fromList catfuns = Map.fromList
[(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
@@ -240,7 +240,7 @@ reorder abs cg = M.MGrammar $
adefs = sorted2tree $ sortIds $ adefs = sorted2tree $ sortIds $
predefADefs ++ Look.allOrigInfos cg abs predefADefs ++ Look.allOrigInfos cg abs
predefADefs = predefADefs =
[(c, AbsCat (Just []) Nothing) | c <- [cFloat,cInt,cString]] [(c, AbsCat (Just [])) | c <- [cFloat,cInt,cString]]
aflags = aflags =
concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]

3
src/compiler/GF/Compile/Rename.hs
View File

@@ -141,8 +141,7 @@ renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info
renameInfo mo status i info = checkIn renameInfo mo status i info = checkIn
(text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $ (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $
case info of case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr) AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResOverload os tysts -> ResOverload os tysts ->

4
src/compiler/GF/Compile/Update.hs
View File

@@ -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 :: Ident -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) -> (AbsCat mc1, AbsCat mc2) ->
liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs liftM AbsCat (unifMaybe mc1 mc2)
(AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) -> (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) ->
liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs

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

@@ -87,7 +87,7 @@ instance Binary Options where
Bad msg -> fail msg Bad msg -> fail msg
instance Binary Info where 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 (AbsFun x y z) = putWord8 1 >> put (x,y,z)
put (ResParam x y) = putWord8 2 >> put (x,y) put (ResParam x y) = putWord8 2 >> put (x,y)
put (ResValue x) = putWord8 3 >> put x put (ResValue x) = putWord8 3 >> put x
@@ -98,7 +98,7 @@ instance Binary Info where
put (AnyInd x y) = putWord8 8 >> put (x,y) put (AnyInd x y) = putWord8 8 >> put (x,y)
get = do tag <- getWord8 get = do tag <- getWord8
case tag of 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) 1 -> get >>= \(x,y,z) -> return (AbsFun x y z)
2 -> get >>= \(x,y) -> return (ResParam x y) 2 -> get >>= \(x,y) -> return (ResParam x y)
3 -> get >>= \x -> return (ResValue x) 3 -> get >>= \x -> return (ResValue x)

4
src/compiler/GF/Grammar/CF.hs
View File

@@ -99,9 +99,9 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
cat = case rules of cat = case rules of
(_,(c,_)):_ -> c -- the value category of the first rule (_,(c,_)):_ -> c -- the value category of the first rule
_ -> error "empty CF" _ -> error "empty CF"
cats = [(cat, AbsCat (Just []) (Just [])) | cats = [(cat, AbsCat (Just [])) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat 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) (funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident] cf2cat :: CFRule -> [Ident]

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

@@ -75,7 +75,7 @@ mapSourceModule f (i,mi) = (i, f mi)
-- and indirection to module (/INDIR/) -- and indirection to module (/INDIR/)
data Info = data Info =
-- judgements in abstract syntax -- 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 | AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function
-- judgements in resource -- judgements in resource

6
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -183,6 +183,6 @@ lookupCatContext gr m c = do
mo <- lookupModule gr m mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
AbsCat (Just co) _ -> return co AbsCat (Just co) -> return co
AnyInd _ n -> lookupCatContext gr n c AnyInd _ n -> lookupCatContext gr n c
_ -> Bad (render (text "unknown category" <+> ppIdent c)) _ -> Bad (render (text "unknown category" <+> ppIdent c))

2
src/compiler/GF/Grammar/Macros.hs
View File

@@ -615,7 +615,7 @@ allDependencies ism b =
CncCat pty _ _ -> [pty] CncCat pty _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual 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)] topoSortJments :: SourceModule -> Err [(Ident,Info)]

10
src/compiler/GF/Grammar/Parser.y
View File

@@ -232,7 +232,7 @@ TopDef
CatDef :: { [(Ident,SrcSpan,Info)] } CatDef :: { [(Ident,SrcSpan,Info)] }
CatDef 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 ']' Posn { listCatDef $3 ($1,$6) $4 0 }
| Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) } | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) }
@@ -247,9 +247,9 @@ DefDef
DataDef :: { [(Ident,SrcSpan,Info)] } DataDef :: { [(Ident,SrcSpan,Info)] }
DataDef 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] } [(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] } [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] }
ParamDef :: { [(Ident,SrcSpan,Info)] } ParamDef :: { [(Ident,SrcSpan,Info)] }
@@ -621,7 +621,7 @@ listCatDef id pos cont size = [catd,nilfund,consfund]
baseId = mkBaseId id baseId = mkBaseId id
consId = mkConsId 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) nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing)
consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing) consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing)
@@ -679,7 +679,7 @@ type SrcSpan = (Posn,Posn)
checkInfoType MTAbstract (id,pos,info) = checkInfoType MTAbstract (id,pos,info) =
case info of case info of
AbsCat _ _ -> return () AbsCat _ -> return ()
AbsFun _ _ _ -> return () AbsFun _ _ _ -> return ()
_ -> failLoc (fst pos) "illegal definition in abstract module" _ -> failLoc (fst pos) "illegal definition in abstract module"
checkInfoType MTResource (id,pos,info) = checkInfoType MTResource (id,pos,info) =

11
src/compiler/GF/Grammar/Printer.hs
View File

@@ -25,7 +25,7 @@ import GF.Grammar.Values
import GF.Grammar.Grammar import GF.Grammar.Grammar
import Text.PrettyPrint import Text.PrettyPrint
import Data.Maybe (maybe) import Data.Maybe (maybe, isNothing)
import Data.List (intersperse) import Data.List (intersperse)
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -71,17 +71,14 @@ ppOptions opts =
text "flags" $$ text "flags" $$
nest 2 (vcat [text option <+> equals <+> str value <+> semi | (option,value) <- optionsGFO opts]) 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 <+> text "cat" <+> ppIdent id <+>
(case pcont of (case pcont of
Just cont -> hsep (map (ppDecl q) cont) Just cont -> hsep (map (ppDecl q) cont)
Nothing -> empty) <+> semi $$ Nothing -> empty) <+> semi
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 (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) $$ Nothing -> empty) $$
(case pexp of (case pexp of
Just [] -> empty Just [] -> empty