Added treatment of transfer modules. Aggregation is an example.

7 files changed, 19 insertions, 5 deletions

diff --git a/src/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs
index 56adb3b4e..a95dbce0f 100644
--- a/src/GF/Canon/AbsGFC.hs
+++ b/src/GF/Canon/AbsGFC.hs
@@ -5,6 +5,7 @@ import Ident --H
 -- Haskell module generated by the BNF converter, except --H
 
 -- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
+
 data Canon =
    Gr [Module]
   deriving (Eq,Ord,Show)
@@ -17,6 +18,7 @@ data ModType =
    MTAbs Ident
  | MTCnc Ident Ident
  | MTRes Ident
+ | MTTrans Ident Ident Ident
   deriving (Eq,Ord,Show)
 
 data Extend =
@@ -36,6 +38,7 @@ data Flag =
 data Def =
    AbsDCat Ident [Decl] [CIdent]
  | AbsDFun Ident Exp Exp
+ | AbsDTrans Ident Exp
  | ResDPar Ident [ParDef]
  | ResDOper Ident CType Term
  | CncDCat Ident CType Term Term
diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs
index e42c273cb..1a677e1a9 100644
--- a/src/GF/Canon/CanonToGrammar.hs
+++ b/src/GF/Canon/CanonToGrammar.hs
@@ -29,6 +29,7 @@ canon2sourceModule (i,mi) = do
             return (a', M.MTConcrete a') 
           M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
           M.MTResource -> return (i',M.MTResource) --- c' not needed
+          M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed
       defs   <- mapMTree redInfo $ M.jments m
       return $ M.ModMod $ M.Module mt flags e os defs
     _ -> Bad $ "cannot decompile module type"
@@ -50,6 +51,8 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
       return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs))
     AbsFun typ df -> do
       return $ G.AbsFun (Yes typ) (Yes df)
+    AbsTrans t -> do
+      return $ G.AbsTrans t
 
     ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par
 
diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs
index 63b697a35..48c77dfe3 100644
--- a/src/GF/Canon/GFC.hs
+++ b/src/GF/Canon/GFC.hs
@@ -27,6 +27,7 @@ type CanonAbs = M.Module Ident Option Info
 data Info = 
    AbsCat  A.Context [A.Fun]
  | AbsFun  A.Type A.Term
+ | AbsTrans A.Term
 
  | ResPar  [ParDef]
  | ResOper CType Term     -- global constant
diff --git a/src/GF/Canon/LexGFC.hs b/src/GF/Canon/LexGFC.hs
index 56048dce3..a4b4de7d7 100644
--- a/src/GF/Canon/LexGFC.hs
+++ b/src/GF/Canon/LexGFC.hs
@@ -52,7 +52,7 @@ tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
 eitherResIdent :: (String -> Tok) -> String -> Tok
 eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
   isResWord s = isInTree s $
-    B "lin" (B "concrete" (B "abstract" (B "Type" (B "Str" N N) N) (B "cat" N N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" N N))) (B "param" (B "open" (B "of" (B "lincat" N N) N) (B "oper" N N)) (B "table" (B "resource" (B "pre" N N) N) (B "variants" N N)))
+    B "lincat" (B "data" (B "abstract" (B "Type" (B "Str" N N) N) (B "concrete" (B "cat" N N) N)) (B "in" (B "fun" (B "flags" N N) N) (B "lin" N N))) (B "pre" (B "oper" (B "open" (B "of" N N) N) (B "param" N N)) (B "transfer" (B "table" (B "resource" N N) N) (B "variants" N N)))
 
 data BTree = N | B String BTree BTree deriving (Show)
 
@@ -79,13 +79,13 @@ tokens_acts = [("ident",ident),("int",int),("pTSpec",pTSpec),("string",string)]
 tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))]
 tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0]
 lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
-lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1),('!',6),('"',8),('$',6),('(',6),(')',6),('*',2),('+',5),(',',6),('-',3),('.',6),('/',6),('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11),(':',6),(';',6),('<',6),('=',4),('>',6),('?',6),('@',6),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('[',6),('\\',6),(']',6),('_',6),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('{',6),('|',6),('}',6),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)]))
+lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1),('!',6),('"',8),('$',6),('(',6),(')',6),('*',3),('+',5),(',',6),('-',2),('.',6),('/',6),('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11),(':',6),(';',6),('<',6),('=',4),('>',6),('?',6),('@',6),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('[',6),('\\',6),(']',6),('_',6),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('{',6),('|',6),('}',6),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)]))
 lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
 lx__1_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1)]))
 lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
-lx__2_0 = (False,[],-1,(('*','*'),[('*',6)]))
+lx__2_0 = (False,[],-1,(('>','>'),[('>',6)]))
 lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
-lx__3_0 = (False,[],-1,(('>','>'),[('>',6)]))
+lx__3_0 = (False,[],-1,(('*','*'),[('*',6)]))
 lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
 lx__4_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',6)]))
 lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs
index 25feb5a47..d747634d2 100644
--- a/src/GF/Canon/MkGFC.hs
+++ b/src/GF/Canon/MkGFC.hs
@@ -21,6 +21,7 @@ canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where
             MTAbs a -> (a,M.MTAbstract)
             MTRes a -> (a,M.MTResource)
             MTCnc a x -> (a,M.MTConcrete x)
+            MTTrans a x y -> (a,M.MTTransfer (M.OSimple x) (M.OSimple y))
       in (a,M.ModMod (M.Module mt' flags (ee e) (oo os) defs'))
   ee (Ext m) = Just m
   ee _ = Nothing
@@ -37,6 +38,7 @@ info2mod m = case m of
              M.MTAbstract -> MTAbs a
              M.MTResource -> MTRes a
              M.MTConcrete x -> MTCnc a x
+             M.MTTransfer (M.OSimple x) (M.OSimple y) -> MTTrans a x y
       in
         Mod mt' (gfcE me) (gfcO os) flags defs'
  where
@@ -51,6 +53,7 @@ defs2infos = sorted2tree . map def2info
 def2info d = case d of
   AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs))
   AbsDFun c ty df   -> (c,AbsFun (trExp ty) (trExp df))
+  AbsDTrans c t     -> (c,AbsTrans (trExp t))
   ResDPar c    df   -> (c,ResPar df)
   ResDOper c ty df  -> (c,ResOper ty df)
   CncDCat c ty df pr   -> (c, CncCat ty df pr)
@@ -95,6 +98,7 @@ infos2defs = map info2def . tree2list
 info2def d = case d of
   (c,AbsCat cont fs)    -> AbsDCat c (rtCont cont) (rtFs fs)
   (c,AbsFun ty df)      -> AbsDFun c (rtExp ty) (rtExp df)
+  (c,AbsTrans t)        -> AbsDTrans c (rtExp t)
   (c,ResPar    df)      -> ResDPar c df
   (c,ResOper ty df)     -> ResDOper c ty df
   (c,CncCat ty df pr)   -> CncDCat c ty df pr
diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs
index bc89ffd6f..81bea7b34 100644
--- a/src/GF/Canon/PrintGFC.hs
+++ b/src/GF/Canon/PrintGFC.hs
@@ -97,7 +97,7 @@ instance Print ModType where
    MTAbs id -> prPrec i 0 (concat [["abstract"] , prt 0 id])
    MTCnc id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id])
    MTRes id -> prPrec i 0 (concat [["resource"] , prt 0 id])
-
+   MTTrans id open0 open -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open])
 
 instance Print Extend where
   prt i e = case e of
@@ -123,6 +123,7 @@ instance Print Def where
   prt i e = case e of
    AbsDCat id decls cidents -> prPrec i 0 (concat [["cat"] , prt 0 id , ["["] , prt 0 decls , ["]"] , ["="] , prt 0 cidents])
    AbsDFun id exp0 exp -> prPrec i 0 (concat [["fun"] , prt 0 id , [":"] , prt 0 exp0 , ["="] , prt 0 exp])
+   AbsDTrans id exp -> prPrec i 0 (concat [["transfer"] , prt 0 id , ["="] , prt 0 exp])
    ResDPar id pardefs -> prPrec i 0 (concat [["param"] , prt 0 id , ["="] , prt 0 pardefs])
    ResDOper id ctype term -> prPrec i 0 (concat [["oper"] , prt 0 id , [":"] , prt 0 ctype , ["="] , prt 0 term])
    CncDCat id ctype term0 term -> prPrec i 0 (concat [["lincat"] , prt 0 id , ["="] , prt 0 ctype , ["="] , prt 0 term0 , [";"] , prt 0 term])
diff --git a/src/GF/Canon/SkelGFC.hs b/src/GF/Canon/SkelGFC.hs
index 955cc442f..2b4323356 100644
--- a/src/GF/Canon/SkelGFC.hs
+++ b/src/GF/Canon/SkelGFC.hs
@@ -29,6 +29,7 @@ transModType x = case x of
   MTAbs id  -> failure x
   MTCnc id0 id  -> failure x
   MTRes id  -> failure x
+  MTTrans id0 id1 id  -> failure x
 
 
 transExtend :: Extend -> Result
@@ -52,6 +53,7 @@ transDef :: Def -> Result
 transDef x = case x of
   AbsDCat id decls cidents  -> failure x
   AbsDFun id exp0 exp  -> failure x
+  AbsDTrans id exp  -> failure x
   ResDPar id pardefs  -> failure x
   ResDOper id ctype term  -> failure x
   CncDCat id ctype term0 term  -> failure x