building extensions in new source format

4 files changed, 134 insertions, 12 deletions

diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs
index 78dbfec82..f24ce2f24 100644
--- a/src/GF/Devel/Compile/Compile.hs
+++ b/src/GF/Devel/Compile/Compile.hs
@@ -2,8 +2,7 @@ module GF.Devel.Compile.Compile (batchCompile) where
 
 -- the main compiler passes
 import GF.Devel.Compile.GetGrammar
-----import GF.Compile.Update
-----import GF.Compile.Extend
+import GF.Devel.Compile.Extend
 ----import GF.Compile.Rebuild
 ----import GF.Compile.Rename
 ----import GF.Grammar.Refresh
@@ -144,18 +143,19 @@ compileSourceModule :: Options -> CompileEnv ->
 compileSourceModule opts env@(k,gr) mo@(i,mi) = do
 
   intermOut opts (iOpt "show_gf") (prMod mo)
-  return (k,mo) ----
 
-{- ----
   let putp  = putPointE opts
       putpp = putPointEsil opts
-      mos   = modules gr
 
+  mo1  <- ioeErr $ extendModule gr mo
+  intermOut opts (iOpt "show_extend") (prMod mo1)
+
+  return (k,mo1) ----
+
+{- ----
   mo1   <- ioeErr $ rebuildModule mos mo
   intermOut opts (iOpt "show_rebuild") (prMod mo1)
 
-  mo1b  <- ioeErr $ extendModule mos mo1
-  intermOut opts (iOpt "show_extend") (prMod mo1b)
 
   case mo1b of
     (_,ModMod n) | not (isCompleteModule n) -> do
diff --git a/src/GF/Devel/Compile/Extend.hs b/src/GF/Devel/Compile/Extend.hs
new file mode 100644
index 000000000..6e0e64f97
--- /dev/null
+++ b/src/GF/Devel/Compile/Extend.hs
@@ -0,0 +1,98 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Extend
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.18 $
+--
+-- AR 14\/5\/2003 -- 11\/11
+--
+-- The top-level function 'extendModule'
+-- extends a module symbol table by indirections to the module it extends
+-----------------------------------------------------------------------------
+
+module GF.Devel.Compile.Extend (
+  extendModule
+  ) where
+
+import GF.Devel.Grammar.Modules
+import GF.Devel.Grammar.Judgements
+import GF.Devel.Grammar.MkJudgements
+import GF.Devel.Grammar.PrGF
+import GF.Devel.Grammar.Lookup
+import GF.Devel.Grammar.Macros
+
+import GF.Infra.Ident
+
+--import GF.Compile.Update
+
+import GF.Data.Operations
+
+import Data.Map
+import Control.Monad
+
+extendModule :: GF -> SourceModule -> Err SourceModule
+extendModule gf (name,mo) = case mtype mo of
+
+  ---- 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
+  MTConcrete _ | not (isCompleteModule mo) -> return (name,mo)
+  _  -> do
+    mo' <- foldM extOne mo (mextends mo) 
+    return (name, mo') 
+ where
+   extOne mo (n,cond) = do
+     (m0,isCompl) <- do
+        m <- lookupModule gf n
+
+        -- test that the module types match, and find out if the old is complete
+        testErr (mtype mo == mtype m) 
+                    ("illegal extension type to module" +++ prt name)
+        return (m, isCompleteModule m)
+
+     -- build extension in a way depending on whether the old module is complete
+     js0 <- extendMod isCompl n (isInherited cond) name (mjments m0) (mjments mo)
+
+     -- if incomplete, throw away extension information
+     let me' = mextends mo ----if isCompl then es else (filter ((/=n) . fst) es) 
+     return $ mo {mextends = me', mjments = js0}
+
+-- | 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 -> 
+             MapJudgement -> MapJudgement -> Err MapJudgement
+extendMod isCompl name cond base old new = foldM try new $ assocs old where
+  try t i@(c,_) | not (cond c) = return t
+  try t i@(c,_) = errIn ("constant" +++ prt c) $
+                  tryInsert (extendAnyInfo isCompl name base) indirIf t i
+  indirIf = if isCompl then indirInfo name else id
+
+indirInfo :: Ident -> JEntry -> JEntry
+indirInfo n info = Right $ case info of
+  Right (k,b) -> (k,b) -- original link is passed
+  Left j      -> (n,isConstructor j)
+
+extendAnyInfo :: Bool -> Ident -> Ident -> JEntry -> JEntry -> Err JEntry
+extendAnyInfo isc n o i j = 
+  errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of
+    (Left j1,Left j2) -> liftM Left $ unifyJudgement j1 j2
+    (Right (m1,b1), Right (m2,b2)) -> do
+      testErr (b1 == b2) "inconsistent indirection status"
+      testErr (m1 == m2) $ 
+        "different sources of inheritance:" +++ show m1 +++ show m2
+      return i
+    _ -> Bad $ "cannot unify information in"---- ++++ prt i ++++ "and" ++++ prt j
+
+tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
+             Map a b -> (a,b) -> Err (Map a b)
+tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of
+  Just info0 -> do
+    info1 <- unif info info0
+    return $ insert x info1 tree 
+  _ -> return $ insert x (indir info) tree
diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs
index 9236f0222..1bd36184d 100644
--- a/src/GF/Devel/Grammar/Lookup.hs
+++ b/src/GF/Devel/Grammar/Lookup.hs
@@ -59,15 +59,19 @@ lookupParamValues gf m c = do
 
 -- infrastructure for lookup
     
-lookupIdent :: GF -> Ident -> Ident -> Err (Either Judgement Ident)
+lookupModule :: GF -> Ident -> Err Module
+lookupModule gf m = do
+  maybe (raise "module not found") return $ mlookup m (gfmodules gf)
+
+lookupIdent :: GF -> Ident -> Ident -> Err JEntry
 lookupIdent gf m c = do
-  mo <- maybe (raise "module not found") return $ mlookup m (gfmodules gf)
+  mo <- lookupModule gf m
   maybe (Bad "constant not found") return $ mlookup c (mjments mo)
 
 lookupJudgement :: GF -> Ident -> Ident -> Err Judgement
 lookupJudgement gf m c = do
   eji <- lookupIdent gf m c
-  either return (\n -> lookupJudgement gf n c) eji 
+  either return (\n -> lookupJudgement gf (fst n) c) eji 
 
 mlookup = Data.Map.lookup
 
diff --git a/src/GF/Devel/Grammar/Modules.hs b/src/GF/Devel/Grammar/Modules.hs
index a2845e08f..a3bf69485 100644
--- a/src/GF/Devel/Grammar/Modules.hs
+++ b/src/GF/Devel/Grammar/Modules.hs
@@ -35,22 +35,27 @@ data Module = Module {
   mextends    :: [(Ident,MInclude)],
   mopens      :: [(Ident,Ident)],           -- used name, original name
   mflags      :: Map Ident String,
-  mjments     :: Map Ident (Either Judgement Indirection) -- def or indirection
+  mjments     :: MapJudgement 
   }
 
 emptyModule :: Ident -> Module
 emptyModule m = Module MTGrammar [] [] [] [] empty empty
 
+type MapJudgement = Map Ident JEntry -- def or indirection
+
 isCompleteModule :: Module -> Bool
 isCompleteModule = Prelude.null . minterfaces 
 
-listJudgements :: Module -> [(Ident,Either Judgement Indirection)]
+listJudgements :: Module -> [(Ident,JEntry)]
 listJudgements = assocs . mjments
 
+type JEntry = Either Judgement Indirection
+
 data ModuleType =
     MTAbstract
   | MTConcrete Ident
   | MTGrammar 
+  deriving Eq
 
 data MInclude =
     MIAll
@@ -59,3 +64,18 @@ data MInclude =
 
 type Indirection = (Ident,Bool) -- module of origin, whether canonical
 
+isConstructorEntry :: Either Judgement Indirection -> Bool
+isConstructorEntry ji = case ji of
+  Left j -> isConstructor j
+  Right i -> snd i
+
+isConstructor :: Judgement -> Bool
+isConstructor j = jdef j == EData
+
+isInherited :: MInclude -> Ident -> Bool
+isInherited mi i = case mi of
+  MIExcept is -> notElem i is
+  MIOnly is -> elem i is
+  _ -> True
+
+