Interfaces and instances by reuse.

3 files changed, 81 insertions, 42 deletions

diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs
index 7a63f413d..ed24389a5 100644
--- a/src/GF/Compile/MkResource.hs
+++ b/src/GF/Compile/MkResource.hs
@@ -13,43 +13,74 @@ import Monad
 -- extracting resource r from abstract + concrete syntax
 -- AR 21/8/2002 -- 22/6/2003 for GF with modules
 
-makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> Ident -> Err SourceRes
-makeReuse gr r me c = do
-  mc <- lookupModule gr c
-
+makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> 
+             MReuseType Ident -> Err SourceRes
+makeReuse gr r me mrc = do
   flags <- return [] --- no flags are passed: they would not make sense
-
-  (ops,jms) <- case mc of 
-    ModMod m -> case mtype m of
-      MTConcrete a -> do
-        ma <- lookupModule gr a
-        jmsA <- case ma of 
-           ModMod m' -> return $ jments m'
-           _ -> prtBad "expected abstract to be the type of" a
-        liftM ((,) (opens m)) $ mkResDefs gr r a me (extends m) jmsA (jments m)
-      _ -> prtBad "expected concrete to be the type of" c
-    _ -> prtBad "expected concrete to be the type of" c
-
-  return $ Module MTResource MSComplete flags me ops jms
-
-mkResDefs :: SourceGrammar -> Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
+  case mrc of
+    MRResource c -> do
+      (ops,jms) <- mkFull True c
+      return $ Module MTResource MSComplete flags me ops jms
+
+    MRInstance c a -> do
+      (ops,jms) <- mkFull False c
+      return $ Module (MTInstance a) MSComplete flags me ops jms
+
+    MRInterface c -> do
+      mc <- lookupModule gr c
+
+      (ops,jms) <- case mc of 
+        ModMod m -> case mtype m of
+          MTAbstract -> liftM ((,) (opens m)) $ 
+                          mkResDefs True False gr r c me (extends m) (jments m) NT
+          _ -> prtBad "expected abstract to be the type of" c
+        _ -> prtBad "expected abstract to be the type of" c
+
+      return $ Module MTInterface MSIncomplete flags me ops jms
+
+ where
+    mkFull hasT c = do
+      mc <- lookupModule gr c
+
+      case mc of 
+        ModMod m -> case mtype m of
+          MTConcrete a -> do
+            ma <- lookupModule gr a
+            jmsA <- case ma of 
+               ModMod m' -> return $ jments m'
+               _ -> prtBad "expected abstract to be the type of" a
+            liftM ((,) (opens m)) $ 
+               mkResDefs hasT True gr r a me (extends m) jmsA (jments m)
+          _ -> prtBad "expected concrete to be the type of" c
+        _ -> prtBad "expected concrete to be the type of" c
+
+
+-- the first  Boolean indicates if the type needs be given
+-- the second Boolean indicates if the definition needs be given
+
+mkResDefs :: Bool -> Bool -> 
+             SourceGrammar -> Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
              BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
              Err (BinTree (Ident,Info))
-mkResDefs gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
+mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
+
+  ifTyped  = yes --- if hasT then yes else const nope --- needed for TC
+  ifCompl  = if isC  then yes else const nope
+  doIf b t = if b then t else return typeType -- latter value not used
 
   mkOne a mae (f,info) = case info of
       AbsCat _ _ -> do
-        typ  <- err (const (return defLinType)) return $ look cnc f
-        typ' <- lockRecType f typ 
-        return (f, ResOper (Yes typeType) (Yes typ'))
+        typ  <- doIf isC $ err (const (return defLinType)) return $ look cnc f
+        typ' <- doIf isC $ lockRecType f typ 
+        return (f, ResOper (ifTyped typeType) (ifCompl typ'))
       AbsFun (Yes typ0) _ -> do
-        trm <- look cnc f
+        trm <- doIf isC $ look cnc f
         testErr (not (isHardType typ0)) 
                 ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
         typ <- redirTyp True a mae typ0
         cat <- valCat typ
-        trm' <- unlockRecord (snd cat) trm 
-        return (f, ResOper (Yes typ) (Yes trm'))
+        trm' <- doIf isC $ unlockRecord (snd cat) trm 
+        return (f, ResOper (ifTyped typ) (ifCompl trm'))
       AnyInd b n -> do
         mo    <- lookupModMod gr n
         info' <- lookupInfo mo f
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index d2bfae5c1..45933e126 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -43,9 +43,13 @@ data ModuleType i =
 
   | MTInterface
   | MTInstance i 
-  | MTReuse i
+  | MTReuse (MReuseType i)
   deriving (Eq,Show)
 
+data MReuseType i = MRInterface i | MRInstance i i | MRResource i
+  deriving (Show,Eq)
+
+
 -- destructive update
 
 --- dep order preserved since old cannot depend on new
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
index 17e1819ca..c01d06c9b 100644
--- a/src/GF/Source/SourceToGrammar.hs
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -51,14 +51,7 @@ transModDef x = case x of
       MTAbstract id -> do
         id' <- transIdent id
         return (transAbsDef, GM.MTAbstract, id')
-      MTResource id -> case body of
-        MReuse c -> do
-          id' <- transIdent id
-          c' <- transIdent c
-          return (transResDef, GM.MTReuse c', id')
-        _ -> do
-          id' <- transIdent id
-          return (transResDef, GM.MTResource, id')
+      MTResource id -> mkModRes id GM.MTResource body 
       MTConcrete id open -> do
         id'   <- transIdent id
         open' <- transIdent open
@@ -68,14 +61,11 @@ transModDef x = case x of
         a'   <- transOpen a
         b'   <- transOpen a
         return (transAbsDef, GM.MTTransfer a' b', id')
-      MTInterface id -> do
-        id' <- transIdent id
-        return (transResDef, GM.MTInterface, id')
+      MTInterface id -> mkModRes id GM.MTInterface body
       MTInstance id open -> do
-        id'   <- transIdent id
         open' <- transIdent open
-        return (transResDef, GM.MTInstance open', id')
-    
+        mkModRes id (GM.MTInstance open') body
+
     case body of 
       MBody extends opens defs -> do
         extends' <- transExtend extends
@@ -83,13 +73,27 @@ transModDef x = case x of
         defs0    <- mapM trDef $ getTopDefs defs
         defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
         flags'   <- return       [f | Right fs <- defs0, f <- fs]
-        return $ (id', GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
+        return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
       MReuse _ -> do
         return (id', GM.ModMod (GM.Module mtyp' mstat' [] Nothing [] NT))
       MWith m opens -> do
         m'     <- transIdent m
         opens' <- mapM transOpen opens 
         return (id', GM.ModWith mtyp' mstat' m' opens')
+ where
+       mkModRes id mtyp body = do
+         id' <- transIdent id
+         case body of
+           MReuse c -> do
+             c' <- transIdent c
+             mtyp' <- trMReuseType mtyp c'
+             return (transResDef, GM.MTReuse mtyp', id')
+           _ -> return (transResDef, mtyp, id')
+       trMReuseType mtyp c = case mtyp of
+         GM.MTInterface -> return $ GM.MRInterface c
+         GM.MTInstance op -> return $ GM.MRInstance c op
+         GM.MTResource -> return $ GM.MRResource c
+
 
 transComplMod :: ComplMod -> GM.ModuleStatus
 transComplMod x = case x of