Transfer data type generation now uses the Tree type constructor for data constructor types.

1 files changed, 20 insertions, 9 deletions

diff --git a/src/GF/API/GrammarToTransfer.hs b/src/GF/API/GrammarToTransfer.hs
index 0f4fa6a6f..960673d08 100644
--- a/src/GF/API/GrammarToTransfer.hs
+++ b/src/GF/API/GrammarToTransfer.hs
@@ -28,8 +28,10 @@ import Transfer.Core.Print
 
 -- | the main function
 grammar2transfer :: GFC.CanonGrammar -> String
-grammar2transfer gr = printTree $ C.Module [cats2cat cats, funs2tree funs]
+grammar2transfer gr = printTree $ C.Module [cats2cat cat tree cats, funs2tree cat tree funs]
   where
+  cat = C.CIdent "Cat" -- FIXME
+  tree = C.CIdent "Tree" -- FIXME
   defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
   -- get category name and context
   cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs]
@@ -38,23 +40,26 @@ grammar2transfer gr = printTree $ C.Module [cats2cat cats, funs2tree funs]
   name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
 
 
-cat = C.CIdent "Cat" -- FIXME
-tree = C.CIdent "Tree" -- FIXME
+
 
 -- | Create a declaration of the type of categories given a list
 --   of category names and their contexts.
-cats2cat :: [(A.Ident,A.Context)] -> Decl
-cats2cat = C.DataDecl cat C.EType . map (uncurry catCons)
+cats2cat :: CIdent -- ^ the name of the Cat type
+         -> CIdent -- ^ the name of the Tree type
+         -> [(A.Ident,A.Context)] -> Decl
+cats2cat cat tree = C.DataDecl cat C.EType . map (uncurry catCons)
   where
-  catCons i c = C.ConsDecl (id2id i) (catConsType c)
+  catCons i c = C.ConsDecl (id2id i) (addTree tree $ catConsType c)
   catConsType = foldr pi (C.EVar cat)
   pi (i,x) t = C.EPi (id2pv i) (term2exp x) t
 
-funs2tree :: [(A.Ident,A.Type)] -> Decl
-funs2tree = 
+funs2tree :: CIdent -- ^ the name of the Cat type
+          -> CIdent -- ^ the name of the Tree type
+          -> [(A.Ident,A.Type)] -> Decl
+funs2tree cat tree = 
     C.DataDecl tree (C.EPi C.PVWild (EVar cat) C.EType) . map (uncurry funCons)
   where 
-  funCons i t = C.ConsDecl (id2id i) (term2exp t)
+  funCons i t = C.ConsDecl (id2id i) (addTree tree $ term2exp t)
 
 term2exp :: A.Term -> C.Exp
 term2exp t = case t of
@@ -70,3 +75,9 @@ id2id = CIdent . symid
 
 id2pv :: A.Ident -> PatternVariable
 id2pv = C.PVVar . id2id
+
+-- FIXME: I think this is not general enoguh.
+addTree :: CIdent -> C.Exp -> C.Exp
+addTree tree x = case x of
+  C.EPi i t e -> C.EPi i (addTree tree t) (addTree tree e)
+  e -> C.EApp (C.EVar tree) e
\ No newline at end of file