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
109
110
111
112
113
114
115

------------------------------------------------------------------------------
--- This library contains functions to convert FlatCurry programs
--- into corresponding XML expressions and vice versa.
--- This can be used to store Curry programs in a way independent
--- of a Curry system or to use a Curry system, like PAKCS,
--- as back end by other functional logic programming systems.
---
--- @author Sebastian Fischer
--- @version November 2024
------------------------------------------------------------------------------

{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}

module FlatCurry.XML (

  flatCurry2XmlFile, flatCurry2Xml, xmlFile2FlatCurry, xml2FlatCurry

  ) where

import FlatCurry.Types
import XML
import XmlConv

-- URL for the FlatCurry DTD:
flatCurryDtd :: String
flatCurryDtd = "http://www.curry-lang.org/docs/flatcurry.dtd"

--- Transforms a FlatCurry program term into a corresponding XML file.
flatCurry2XmlFile :: Prog -> String -> IO ()
flatCurry2XmlFile flatprog filename = writeFile filename $
  showXmlDocWithParams [DtdUrl flatCurryDtd] (flatCurry2Xml flatprog)

--- Transforms a FlatCurry program term into a corresponding XML expression.
flatCurry2Xml :: Prog -> XmlExp
flatCurry2Xml = xmlShow cProg

--- Reads an XML file with a FlatCurry program and returns
--- the FlatCurry program.
xmlFile2FlatCurry :: String -> IO Prog
xmlFile2FlatCurry filename = readXmlFile filename >>= return . xml2FlatCurry

--- Transforms an XML term into a FlatCurry program.
xml2FlatCurry :: XmlExp -> Prog
xml2FlatCurry = xmlRead cProg

-- FlatCurry XML converter specification:
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" (,)
                        (adapt (fromTVar,TVar) (eSeq1 "tvar" TVar int))
                        cKind

fromTVar :: TypeExpr -> TVarIndex
fromTVar (TVar i) = i

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