summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs4
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs4
-rw-r--r--src/compiler/GF/Compile/Rename.hs3
-rw-r--r--src/compiler/GF/Compile/Update.hs4
-rw-r--r--src/compiler/GF/Grammar/Binary.hs4
-rw-r--r--src/compiler/GF/Grammar/CF.hs4
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs2
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs6
-rw-r--r--src/compiler/GF/Grammar/Macros.hs2
-rw-r--r--src/compiler/GF/Grammar/Parser.y10
-rw-r--r--src/compiler/GF/Grammar/Printer.hs11
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:40:09 +0000