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

Perhaps -> Maybe refactoring and better error message for conflicts during module update

Browse Source
This commit is contained in:
krasimir
2009-02-23 12:42:44 +00:00
parent 03aa49aece
commit 0296492f9d
23 changed files with 387 additions and 644 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/GF/Grammar/Binary.hs
View File

@@ -228,16 +228,6 @@ instance Binary Patt where
17 -> get >>= \x -> return (PMacro x)
18 -> get >>= \(x,y) -> return (PM x y)
instance (Binary a, Binary b) => Binary (Perhaps a b) where
put (Yes x) = putWord8 0 >> put x
put (May y) = putWord8 1 >> put y
put Nope = putWord8 2
get = do tag <- getWord8
case tag of
0 -> fmap Yes get
1 -> fmap May get
2 -> return Nope
instance Binary TInfo where
put TRaw = putWord8 0
put (TTyped t) = putWord8 1 >> put t

26
src/GF/Grammar/Grammar.hs
View File

@@ -21,8 +21,6 @@ module GF.Grammar.Grammar (SourceGrammar,
mapSourceModule,
Info(..),
PValues,
Perh,
MPr,
Type,
Cat,
Fun,
@@ -82,30 +80,24 @@ type PValues = [Term]
-- and indirection to module (/INDIR/)
data Info =
-- judgements in abstract syntax
AbsCat (Perh Context) (Perh [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
| AbsFun (Perh Type) (Perh Term) -- ^ (/ABS/) 'Yes f' = canonical
AbsCat (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
| AbsFun (Maybe Type) (Maybe Term) -- ^ (/ABS/) 'Yes f' = canonical
-- judgements in resource
| ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)
| ResValue (Perh (Type,Maybe Int)) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Perh Type) (Perh Term) -- ^ (/RES/)
| ResParam (Maybe ([Param],Maybe PValues)) -- ^ (/RES/)
| ResValue (Maybe (Type,Maybe Int)) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe Type) (Maybe Term) -- ^ (/RES/)
| ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited
| ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
| CncCat (Perh Type) (Perh Term) MPr -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- (/CNC/) type info added at 'TC'
| CncCat (Maybe Type) (Maybe Term) (Maybe Term) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,(Context,Type))) (Maybe Term) (Maybe Term) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving (Read, Show)
-- | to express indirection to other module
type Perh a = Perhaps a Ident
-- | printname
type MPr = Perhaps Term Ident
type Type = Term
type Cat = QIdent
type Fun = QIdent

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

@@ -78,15 +78,15 @@ lookupResDefKind gr m c
mo <- lookupModule gr m
info <- lookupIdentInfoIn mo m c
case info of
ResOper _ (Yes t) -> return (qualifAnnot m t, 0)
ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c
ResOper _ (Just t) -> return (qualifAnnot m t, 0)
ResOper _ Nothing -> return (Q m c, 0) ---- if isTop then lookExt m c
---- else prtBad "cannot find in exts" c
CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty
CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType
CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr
CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
CncCat (Just ty) _ _ -> liftM (flip (,) 1) $ lock c ty
CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType
CncFun (Just (cat,_)) (Just tr) _ -> liftM (flip (,) 1) $ unlock cat tr
CncFun _ (Just tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
AnyInd _ n -> look False n c
ResParam _ -> return (QC m c,2)
@@ -100,8 +100,7 @@ lookupResType gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
ResOper (Yes t) _ -> return $ qualifAnnot m t
ResOper (May n) _ -> lookupResType gr n c
ResOper (Just t) _ -> return $ qualifAnnot m t
-- used in reused concrete
CncCat _ _ _ -> return typeType
@@ -111,7 +110,7 @@ lookupResType gr m c = do
CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t
ResValue (Just (t,_)) -> return $ qualifAnnotPar m t
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
where
lookFunType e m c = do
@@ -121,7 +120,7 @@ lookupResType gr m c = do
mu <- lookupModule gr a
info <- lookupIdentInfo mu c
case info of
AbsFun (Yes ty) _ -> return $ redirectTerm e ty
AbsFun (Just ty) _ -> return $ redirectTerm e ty
AbsCat _ _ -> return typeType
AnyInd _ n -> lookFun e m c n
_ -> prtBad "cannot find type of reused function" c
@@ -154,9 +153,9 @@ lookupParams gr = look True where
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
ResParam (Yes psm) -> return psm
AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
ResParam (Just psm) -> return psm
AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
lookExt m c =
checks [look False n c | n <- allExtensions gr m]
@@ -231,9 +230,9 @@ lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsFun _ (Yes t) -> return (Just t)
AnyInd _ n -> lookupAbsDef gr n c
_ -> return Nothing
AbsFun _ (Just t) -> return (Just t)
AnyInd _ n -> lookupAbsDef gr n c
_ -> return Nothing
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
@@ -241,9 +240,9 @@ lookupLincat gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
CncCat (Yes t) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m
CncCat (Just t) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m
-- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
@@ -251,9 +250,9 @@ lookupFunType gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsFun (Yes t) _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
AbsFun (Just t) _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
-- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -261,9 +260,9 @@ lookupCatContext gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsCat (Yes co) _ -> return co
AnyInd _ n -> lookupCatContext gr n c
_ -> prtBad "unknown category" c
AbsCat (Just co) _ -> return co
AnyInd _ n -> lookupCatContext gr n c
_ -> prtBad "unknown category" c
-- The first type argument is uncomputed, usually a category symbol.
-- This is a hack to find implicit (= reused) opers.
@@ -273,14 +272,14 @@ opersForType gr orig val =
[((i,f),ty) | (i,m) <- modules gr, (f,ty) <- opers i m val] where
opers i m val =
[(f,ty) |
(f,ResOper (Yes ty) _) <- tree2list $ jments m,
(f,ResOper (Just ty) _) <- tree2list $ jments m,
Ok valt <- [valTypeCnc ty],
elem valt [val,orig]
] ++
let cat = err error snd (valCat orig) in --- ignore module
[(f,ty) |
Ok a <- [abstractOfConcrete gr i >>= lookupModule gr],
(f, AbsFun (Yes ty0) _) <- tree2list $ jments a,
(f, AbsFun (Just ty0) _) <- tree2list $ jments a,
let ty = redirectTerm i ty0,
Ok valt <- [valCat ty],
cat == snd valt ---

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

@@ -21,15 +21,8 @@
module GF.Grammar.PrGrammar (Print(..),
prtBad,
prGrammar, prModule,
prContext, prParam,
prQIdent, prQIdent_,
prRefinement, prTermOpt,
-- prt_Tree, prMarkedTree, prTree,
-- tree2string, prprTree,
prGrammar,
prConstrs, prConstraints,
-- prMetaSubst, prEnv, prMSubst,
prExp, prOperSignature,
prTermTabular
) where

48
src/GF/Grammar/Printer.hs
View File

@@ -69,30 +69,30 @@ ppOptions opts =
ppJudgement (id, AbsCat pcont pconstrs) =
text "cat" <+> ppIdent id <+>
(case pcont of
Yes cont -> hsep (map ppDecl cont)
_ -> empty) <+> semi $$
Just cont -> hsep (map ppDecl cont)
Nothing -> empty) <+> semi $$
case pconstrs of
Yes costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm 0) costrs)) <+> semi
_ -> empty
Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm 0) costrs)) <+> semi
Nothing -> empty
ppJudgement (id, AbsFun ptype pexp) =
(case ptype of
Yes typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm 0 typ <+> semi
_ -> empty) $$
Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm 0 typ <+> semi
Nothing -> empty) $$
(case pexp of
Yes EData -> empty
Yes (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt 2) ps) <+> equals <+> ppTerm 0 e <+> semi
Yes exp -> text "def" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi
_ -> empty)
Just EData -> empty
Just (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt 2) ps) <+> equals <+> ppTerm 0 e <+> semi
Just exp -> text "def" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi
Nothing -> empty)
ppJudgement (id, ResParam pparams) =
text "param" <+> ppIdent id <+>
(case pparams of
Yes (ps,_) -> equals <+> fsep (intersperse (char '|') (map ppParam ps))
_ -> empty) <+> semi
Just (ps,_) -> equals <+> fsep (intersperse (char '|') (map ppParam ps))
_ -> empty) <+> semi
ppJudgement (id, ResValue pvalue) = empty
ppJudgement (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+>
(case ptype of {Yes t -> colon <+> ppTerm 0 t; _ -> empty} $$
case pexp of {Yes e -> equals <+> ppTerm 0 e; _ -> empty}) <+> semi
(case ptype of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty} $$
case pexp of {Just e -> equals <+> ppTerm 0 e; Nothing -> empty}) <+> semi
ppJudgement (id, ResOverload ids defs) =
text "oper" <+> ppIdent id <+> equals <+>
(text "overload" <+> lbrace $$
@@ -100,22 +100,22 @@ ppJudgement (id, ResOverload ids defs) =
rbrace) <+> semi
ppJudgement (id, CncCat ptype pexp pprn) =
(case ptype of
Yes typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm 0 typ <+> semi
_ -> empty) $$
Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm 0 typ <+> semi
Nothing -> empty) $$
(case pexp of
Yes exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi
_ -> empty) $$
Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi
Nothing -> empty) $$
(case pprn of
Yes prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi
_ -> empty)
Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi
Nothing -> empty)
ppJudgement (id, CncFun ptype pdef pprn) =
(case pdef of
Yes e -> let (vs,e') = getAbs e
Just e -> let (vs,e') = getAbs e
in text "lin" <+> ppIdent id <+> hsep (map ppIdent vs) <+> equals <+> ppTerm 0 e' <+> semi
_ -> empty) $$
Nothing -> empty) $$
(case pprn of
Yes prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi
_ -> empty)
Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi
Nothing -> empty)
ppJudgement (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid
ppTerm d (Abs v e) = let (vs,e') = getAbs e