GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 19:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
bringert
2005-11-29 13:59:27 +00:00
parent 465ad22516
commit e60754e612
1 changed files with 20 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
src/GF/API/GrammarToTransfer.hs
View File

@@ -28,8 +28,10 @@ import Transfer.Core.Print
-- | the main function -- | the main function
grammar2transfer :: GFC.CanonGrammar -> String 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 where
cat = C.CIdent "Cat" -- FIXME
tree = C.CIdent "Tree" -- FIXME
defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m] defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
-- get category name and context -- get category name and context
cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs] 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] 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 -- | Create a declaration of the type of categories given a list
-- of category names and their contexts. -- of category names and their contexts.
cats2cat :: [(A.Ident,A.Context)] -> Decl cats2cat :: CIdent -- ^ the name of the Cat type
cats2cat = C.DataDecl cat C.EType . map (uncurry catCons) -> CIdent -- ^ the name of the Tree type
-> [(A.Ident,A.Context)] -> Decl
cats2cat cat tree = C.DataDecl cat C.EType . map (uncurry catCons)
where 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) catConsType = foldr pi (C.EVar cat)
pi (i,x) t = C.EPi (id2pv i) (term2exp x) t pi (i,x) t = C.EPi (id2pv i) (term2exp x) t
funs2tree :: [(A.Ident,A.Type)] -> Decl funs2tree :: CIdent -- ^ the name of the Cat type
funs2tree = -> 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) C.DataDecl tree (C.EPi C.PVWild (EVar cat) C.EType) . map (uncurry funCons)
where 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 :: A.Term -> C.Exp
term2exp t = case t of term2exp t = case t of
@@ -70,3 +75,9 @@ id2id = CIdent . symid
id2pv :: A.Ident -> PatternVariable id2pv :: A.Ident -> PatternVariable
id2pv = C.PVVar . id2id 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