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

1 files changed, 174 insertions, 96 deletions

diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs
index a0aefeea5..4bcea0db2 100644
--- a/src/GF/Compile/Update.hs
+++ b/src/GF/Compile/Update.hs
@@ -12,122 +12,200 @@
 -- (Description of the module)
 -----------------------------------------------------------------------------
 
-module GF.Compile.Update (updateRes, buildAnyTree, combineAnyInfos, unifyAnyInfo,
-	       -- * these auxiliaries should be somewhere else 
-	       -- since they don't use the info types
-	       groupInfos, sortInfos, combineInfos, unifyInfos,
-	       tryInsert, unifAbsDefs, unifConstrs
-	      ) where
+module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where
 
 import GF.Infra.Ident
 import GF.Grammar.Grammar
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer
 import GF.Infra.Modules
+import GF.Infra.Option
 
 import GF.Data.Operations
 
 import Data.List
+import qualified Data.Map as Map
 import Control.Monad
-
--- | update a resource module by adding a new or changing an old definition
-updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
-updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
-  upd (n,mo)
-    | n /= m = (n,mo)
-    | n == m = (n,updateModule mo i info)
+import Text.PrettyPrint
 
 -- | combine a list of definitions into a balanced binary search tree
-buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info)
-buildAnyTree ias = do
-  ias' <- combineAnyInfos ias
-  return $ buildTree ias'
-
-
--- | unifying information for abstract, resource, and concrete
-combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)]
-combineAnyInfos = combineInfos unifyAnyInfo
+buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info)
+buildAnyTree m = go Map.empty
+  where
+    go map []         = return map
+    go map ((c,j):is) = do
+      case Map.lookup c map of
+        Just i  -> case unifyAnyInfo c i j of
+		     Ok k  -> go (Map.insert c k map) is
+		     Bad _ -> fail $ render (text "cannot unify the informations" $$ 
+		                             nest 4 (ppJudgement (c,i)) $$
+		                             text "and" $+$
+		                             nest 4 (ppJudgement (c,j)) $$
+		                             text "in module" <+> ppIdent m)
+        Nothing -> go (Map.insert c j map) is
+
+extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
+extendModule ms (name,m)
+  ---- Just to allow inheritance in incomplete concrete (which are not
+  ---- compiled anyway), extensions are not built for them.
+  ---- Should be replaced by real control. AR 4/2/2005
+  | mstatus m == MSIncomplete && isModCnc m = return (name,m)
+  | otherwise                               = do m' <- foldM extOne m (extend m) 
+                                                 return (name,m')
+ where
+   extOne mo (n,cond) = do
+     m0 <- lookupModule (MGrammar ms) n
+
+     -- test that the module types match, and find out if the old is complete
+     testErr (sameMType (mtype m) (mtype mo)) 
+             ("illegal extension type to module" +++ prIdent name)
+
+     let isCompl = isCompleteModule m0
+
+     -- build extension in a way depending on whether the old module is complete
+     js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
+
+     -- if incomplete, throw away extension information
+     return $ 
+          if isCompl
+            then mo {jments = js1}
+            else mo {extend = filter ((/=n) . fst) (extend mo)
+                    ,mexdeps= nub (n : mexdeps mo)
+                    ,jments = js1
+                    }
+
+-- | rebuilding instance + interface, and "with" modules, prior to renaming. 
+-- AR 24/10/2003
+rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
+rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
+  let gr = MGrammar ms
+----  deps <- moduleDeps ms
+----  is   <- openInterfaces deps i
+  let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
+  mi'  <- case mw of
+
+    -- add the information given in interface into an instance module
+    Nothing -> do
+      testErr (null is || mstatus mi == MSIncomplete) 
+              ("module" +++ prIdent i +++ 
+               "has open interfaces and must therefore be declared incomplete") 
+      case mt of
+        MTInstance i0 -> do
+          m1 <- lookupModule gr i0
+          testErr (isModRes m1) ("interface expected instead of" +++ prIdent i0)
+          js' <- extendMod False (i0,const True) i (jments m1) (jments mi)
+          --- to avoid double inclusions, in instance I of I0 = J0 ** ...
+          case extends mi of
+            []  -> return $ replaceJudgements mi js'
+            j0s -> do
+                m0s <- mapM (lookupModule gr) j0s
+                let notInM0 c _  = all (not . isInBinTree c . jments) m0s
+                let js2 = filterBinTree notInM0 js'
+                return $ (replaceJudgements mi js2) 
+                  {positions = Map.union (positions m1) (positions mi)}
+        _ -> return mi
+
+    -- add the instance opens to an incomplete module "with" instances
+    Just (ext,incl,ops) -> do
+      let (infs,insts) = unzip ops
+      let stat' = ifNull MSComplete (const MSIncomplete)
+                    [i | i <- is, notElem i infs]
+      testErr (stat' == MSComplete || stat == MSIncomplete) 
+              ("module" +++ prIdent i +++ "remains incomplete")
+      ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext
+      let ops1 = nub $
+                   ops_ ++ -- N.B. js has been name-resolved already
+                   [OQualif i j | (i,j) <- ops] ++
+                   [o | o <- ops0, notElem (openedModule o) infs] ++
+                   [OQualif i i | i <- insts] ++
+                   [OSimple i   | i <- insts]
+
+      --- check if me is incomplete
+      let fs1 = fs `addOptions` fs_                           -- new flags have priority
+      let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
+      let js1 = buildTree (tree2list js_ ++ js0)
+      let ps1 = Map.union ps_ ps0
+      let med1= nub (ext : infs ++ insts ++ med_)
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1
+
+  return (i,mi')
+
+-- | When extending a complete module: new information is inserted,
+-- and the process is interrupted if unification fails.
+-- If the extended module is incomplete, its judgements are just copied.
+extendMod :: Bool -> (Ident,Ident -> Bool) -> Ident -> 
+             BinTree Ident Info -> BinTree Ident Info -> 
+             Err (BinTree Ident Info)
+extendMod isCompl (name,cond) base old new = foldM try new $ Map.toList old 
+  where
+    try new (c,i)
+      | not (cond c) = return new
+      | otherwise    = case Map.lookup c new of
+                         Just j -> case unifyAnyInfo c i j of
+		                     Ok k  -> return $ updateTree (c,k) new
+		                     Bad _ -> fail $ render (text "cannot unify the information" $$ 
+		                                             nest 4 (ppJudgement (c,i)) $$
+		                                             text "in module" <+> ppIdent name <+> text "with" $$
+		                                             nest 4 (ppJudgement (c,j)) $$
+		                                             text "in module" <+> ppIdent base)
+                         Nothing    -> if isCompl
+                                         then return $ updateTree (c,indirInfo name i) new
+                                         else return $ updateTree (c,i) new
+
+    indirInfo :: Ident -> Info -> Info
+    indirInfo n info = AnyInd b n' where 
+      (b,n') = case info of
+        ResValue _ -> (True,n)
+        ResParam _ -> (True,n)
+        AbsFun _ (Just EData) -> (True,n) 
+        AnyInd b k -> (b,k)
+        _ -> (False,n) ---- canonical in Abs
 
 unifyAnyInfo :: Ident -> Info -> Info -> Err Info
-unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of
+unifyAnyInfo c i j = case (i,j) of
   (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
-    liftM2 AbsCat (unifPerhaps mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
+    liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
   (AbsFun mt1 md1, AbsFun mt2 md2) -> 
-    liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
+    liftM2 AbsFun (unifMaybe mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
 
-  (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2
+  (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifMaybe mt1 mt2
+  (ResValue mt1, ResValue mt2) -> 
+    liftM ResValue $ unifMaybe mt1 mt2
+  (_, ResOverload ms t) | elem c ms ->
+    return $ ResOverload ms t
   (ResOper mt1 m1, ResOper mt2 m2) -> 
-    liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2)
+    liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2)
 
   (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
-    liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2)
+    liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2)
   (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
-    liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs
--- for bw compatibility with unspecified printnames in old GF
-  (CncFun Nothing Nope (Yes pr),_) -> 
-    unifyAnyInfo c (CncCat Nope Nope (Yes pr)) j 
-  (_,CncFun Nothing Nope (Yes pr)) -> 
-    unifyAnyInfo c i (CncCat Nope Nope (Yes pr)) 
-
-  _ -> Bad $ "cannot unify informations in" ++++ show i ++++ "and" ++++ show j
-
---- these auxiliaries should be somewhere else since they don't use the info types
-
-groupInfos :: Eq a => [(a,b)] -> [[(a,b)]]
-groupInfos = groupBy (\i j -> fst i == fst j)
-
-sortInfos :: Ord a => [(a,b)] -> [(a,b)]
-sortInfos = sortBy (\i j -> compare (fst i) (fst j))
-
-combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)]
-combineInfos f ris = do
-  let riss = groupInfos $ sortInfos ris
-  mapM (unifyInfos f) riss
-
-unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b)
-unifyInfos _ [] = Bad "empty info list"
-unifyInfos unif ris = do
-  let c = fst $ head ris
-  let infos = map snd ris
-  let ([i],is) = splitAt 1 infos 
-  info <- foldM (unif c) i is
-  return (c,info)
-
-
-tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
-             BinTree a b -> (a,b) -> Err (BinTree a b)
-tryInsert unif indir tree z@(x, info) = case justLookupTree x tree of
-  Ok info0 -> do
-    info1 <- unif info info0
-    return $ updateTree (x,info1) tree 
-  _ -> return $ updateTree (x,indir info) tree
-
-{- ----
-case tree of
- NT -> return $ BT (x, indir info) NT NT
- BT c@(a,info0) left right 
-   | x < a  -> do
-       left' <- tryInsert unif indir left z    
-       return $ BT c left' right 
-   | x > a  -> do
-       right' <- tryInsert unif indir right z    
-       return $ BT c left right' 
-   | x == a -> do
-       info' <- unif info info0
-       return $ BT (x,info') left right
--}
-
---- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m
-
-unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term)
+    liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs
+
+  (AnyInd b1 m1, AnyInd b2 m2) -> do
+    testErr (b1 == b2) $ "indirection status"
+    testErr (m1 == m2) $ "different sources of indirection"
+    return i
+
+  _ -> fail "informations"
+
+-- | this is what happens when matching two values in the same module
+unifMaybe :: Eq a => Maybe a -> Maybe a -> Err (Maybe a)
+unifMaybe Nothing   Nothing   = return Nothing
+unifMaybe (Just p1) Nothing   = return (Just p1)
+unifMaybe Nothing   (Just p2) = return (Just p2)
+unifMaybe (Just p1) (Just p2)
+  | p1==p2                    = return (Just p1)
+  | otherwise                 = fail ""
+
+unifAbsDefs :: Maybe Term -> Maybe Term -> Err (Maybe Term)
 unifAbsDefs p1 p2 = case (p1,p2) of
-  (Nope, _)  -> return p2
-  (_, Nope)  -> return p1
-  (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order!
-  _ -> Bad "update conflict for definitions"
+  (Nothing, _)  -> return p2
+  (_, Nothing)  -> return p1
+  (Just (Eqs bs), Just (Eqs ds))
+                -> return $ Just $ Eqs $ bs ++ ds --- order!
+  _             -> fail "definitions"
 
-unifConstrs :: Perh [Term] -> Perh [Term] -> Err (Perh [Term])
+unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term])
 unifConstrs p1 p2 = case (p1,p2) of
-  (Nope, _)  -> return p2
-  (_, Nope)  -> return p1
-  (Yes bs, Yes ds) -> return $ yes $ bs ++ ds
-  _ -> Bad "update conflict for constructors"
+  (Nothing, _)  -> return p2
+  (_, Nothing)  -> return p1
+  (Just bs, Just ds) -> return $ Just $ bs ++ ds