From 2ee936c7e23bd690b05b8362179911a2d176f150 Mon Sep 17 00:00:00 2001
From: aarne <unknown>
Date: Thu, 9 Oct 2003 15:23:32 +0000
Subject: Added treatment of transfer modules. Aggregation is an example.

---
 src/GF/Compile/CheckGrammar.hs   |  4 ++++
 src/GF/Compile/GrammarToCanon.hs |  4 ++++
 src/GF/Compile/Rename.hs         | 15 ++++++++++-----
 3 files changed, 18 insertions(+), 5 deletions(-)

(limited to 'src/GF/Compile')

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 544214cb9..07151d8b7 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -42,6 +42,10 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
       js' <- mapMTree (checkAbsInfo gr name) js
       return $ (name, ModMod (Module mt fs me ops js')) : ms
 
+    MTTransfer a b -> do
+      js' <- mapMTree (checkAbsInfo gr name) js
+      return $ (name, ModMod (Module mt fs me ops js')) : ms
+
     MTResource -> do
       js' <- mapMTree (checkResInfo gr) js
       return $ (name, ModMod (Module mt fs me ops js')) : ms
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index 23833a3c2..07708dd3c 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -43,6 +43,7 @@ redModInfo (c,info) = do
            return (a', MTConcrete a') 
          MTAbstract -> return (c',MTAbstract) --- c' not needed
          MTResource -> return (c',MTResource) --- c' not needed
+         MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
       defss <- mapM (redInfo a) $ tree2list $ jments m
       defs  <- return $ sorted2tree $ concat defss  -- sorted, but reduced
       return $ ModMod $ Module mt flags e os defs
@@ -54,6 +55,7 @@ redModInfo (c,info) = do
        _ -> return Nothing
      os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m
      return (e',os')
+   om = OSimple . openedModule --- normalizing away qualif
 
 redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
 redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
@@ -69,6 +71,8 @@ redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
                  Yes t -> t
                  _ -> EData --- data vs. primitive
       returns c' $ C.AbsFun typ df
+    AbsTrans t -> 
+      returns c' $ C.AbsTrans t
 
     ResParam (Yes ps) -> do
       ps' <- mapM redParam ps
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index eb6f6dcb9..a4d9b9365 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -117,7 +117,7 @@ tree2status o = case o of
 buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
 buildStatus gr c mo = let mo' = self2status c mo in case mo of
   ModMod m -> do
-    let ops  = opens m
+    let ops  = allOpens m
     mods <- mapM (lookupModule gr . openedModule) ops
     let sts = map modInfo2status $ zip ops mods    
     return $ if isModCnc m
@@ -130,10 +130,14 @@ modInfo2status (o,i) = (o,case i of
   )
 
 self2status :: Ident -> SourceModInfo -> StatusTree
-self2status c i = case i of
-  ModMod m -> mapTree (info2status (Just c)) (jments m)   -- qualify internal
----  ModMod m -> mapTree (resInfo2status Nothing) (jments m)
--- change Lookup.qualifAnnot if you change this
+self2status c i = mapTree (info2status (Just c)) js where   -- qualify internal
+  js = case i of
+    ModMod m 
+      | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m 
+      | otherwise -> jments m
+  noTrans (_,d) = case d of  -- to enable other than transfer js in transfer module 
+    AbsTrans _ -> False
+    _ -> True
 
 forceQualif o = case o of
   OSimple i   -> OQualif i i
@@ -145,6 +149,7 @@ renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $
   AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
                                   (renPerh (mapM rent) pfs)
   AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
+  AbsTrans f -> liftM AbsTrans (rent f)
 
   ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
   ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
-- 
cgit v1.2.3