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

5 files changed, 61 insertions, 87 deletions

diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs
index 65fbfcd89..da1cd476f 100644
--- a/src/GF/Grammar/Binary.hs
+++ b/src/GF/Grammar/Binary.hs
@@ -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

diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index f36177774..c3f303655 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -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
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 2f5826752..f11f7d428 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -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 ---
diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs
index a4a9d9256..1b26d1d48 100644
--- a/src/GF/Grammar/PrGrammar.hs
+++ b/src/GF/Grammar/PrGrammar.hs
@@ -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
 
diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs
index 44687ebeb..72b72b571 100644
--- a/src/GF/Grammar/Printer.hs
+++ b/src/GF/Grammar/Printer.hs
@@ -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