1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
module FlatCurry.XML (
flatCurry2XmlFile, flatCurry2Xml, xmlFile2FlatCurry, xml2FlatCurry
) where
import FlatCurry.Types
import XML
import XmlConv
flatCurryDtd = "http://www.informatik.uni-kiel.de/~curry/flatcurrynew.dtd"
flatCurry2XmlFile :: Prog -> String -> IO ()
flatCurry2XmlFile flatprog filename = writeFile filename $
showXmlDocWithParams [DtdUrl flatCurryDtd] (flatCurry2Xml flatprog)
flatCurry2Xml :: Prog -> XmlExp
flatCurry2Xml = xmlShow cProg
xmlFile2FlatCurry :: String -> IO Prog
xmlFile2FlatCurry filename = readXmlFile filename >>= return . xml2FlatCurry
xml2FlatCurry :: XmlExp -> Prog
xml2FlatCurry = xmlRead cProg
cProg = eSeq5 "prog" Prog cModname cImports cTypes cFuncs cOps
cModname = eString "module"
cImports = eRep "import" (eString "module")
cTypes = eRep "types" cType
cType = eSeq4 "type" Type cQName cVis cTParams (rep cConsDecl)
! eSeq4 "typesyn" TypeSyn cQName cVis cTParams cTypeExpr
! eSeq4 "typenew" TypeNew cQName cVis cTParams cNewConsDecl
cQName = seq2 (\a b -> (a,b)) (aString "module") (aString "name")
cVis = adapt (b2v,v2b) (aBool "visibility" "public" "private")
b2v b = if b then Public else Private
v2b v = v==Public
cTParams = eRep "params" cTVarWithKind
cConsDecl = eSeq4 "cons" Cons cQName cArity cVis (rep cTypeExpr)
cNewConsDecl = eSeq3 "newcons" NewCons cQName cVis cTypeExpr
cArity = aInt "arity"
cTypeExpr = eSeq2 "functype" FuncType cTypeExpr cTypeExpr
! eSeq2 "tcons" TCons cQName (rep cTypeExpr)
! eSeq1 "tvar" TVar int
! eSeq2 "forall" ForallType cTParams cTypeExpr
cTVarWithKind = eSeq2 "tvarwithkind" (,) int cKind
cKind = eEmpty "kstar" KStar
! eSeq2 "karrow" KArrow cKind cKind
cFuncs = eRep "functions" cFunc
cFunc = eSeq5 "func" Func cQName cArity cVis cTypeExpr cRule
cRule = eSeq2 "rule" Rule cLHS cRHS
! eSeq1 "external" External string
cLHS = element "lhs" cVars
cRHS = element "rhs" cExpr
cVars = rep cVar
cVar = eInt "var"
cExpr = eSeq1 "var" Var int
! eSeq1 "lit" Lit cLit
! eSeq2 "funccall" fc cQName cExps
! eSeq2 "conscall" cc cQName cExps
! eSeq3 "funcpartcall" pfc cQName cMissing cExps
! eSeq3 "conspartcall" pcc cQName cMissing cExps
! eSeq2 "free" Free (element "freevars" cVars) cExpr
! eSeq2 "or" Or cExpr cExpr
! eSeq2 "case" cr cExpr (rep cBranch)
! eSeq2 "fcase" cf cExpr (rep cBranch)
! eSeq2 "letrec" Let (rep cBind) cExpr
! eSeq2 "typed" Typed cExpr cTypeExpr
cLit = eSeq1 "intc" Intc int
! eSeq1 "floatc" Floatc float
! eSeq1 "charc" Charc (adapt (chr,ord) int)
fc = Comb FuncCall
cc = Comb ConsCall
pfc n m = Comb (FuncPartCall m) n
pcc n m = Comb (ConsPartCall m) n
cExps = rep cExpr
cMissing = aInt "missing"
cr = Case Rigid
cf = Case Flex
cBranch = eSeq2 "branch" Branch cPat cExpr
cPat = eSeq2 "pattern" Pattern cQName cVars
! eSeq1 "lpattern" LPattern cLit
cBind = eSeq2 "binding" (\a b -> (a,b)) cVar cExpr
cOps = eRep "operators" cOp
cOp = eSeq3 "op" Op cQName cFixity (aInt "prec")
cFixity = adapt (rf,show) (aString "fixity")
rf "InfixOp" = InfixOp
rf "InfixlOp" = InfixlOp
rf "InfixrOp" = InfixrOp
|