From dc06abd643de8837b2d810d76986468d08b1851e Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Tue, 29 Nov 2005 13:59:27 +0000
Subject: [PATCH] Transfer data type generation now uses the Tree type
 constructor for data constructor types.

---
 src/GF/API/GrammarToTransfer.hs | 29 ++++++++++++++++++++---------
 1 file 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