Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
61f6804a
Commit
61f6804a
authored
Jul 31, 2014
by
Björn Peemöller
Browse files
Removed support for FlatCurry XML files - fixes #1045
parent
98eaa471
Changes
6
Hide whitespace changes
Inline
Side-by-side
curry-frontend.cabal
View file @
61f6804a
...
...
@@ -75,7 +75,6 @@ Executable cymake
, IL
, IL.Pretty
, IL.Type
, IL.XML
, Imports
, InterfaceEquivalence
, Interfaces
...
...
src/CompilerOpts.hs
View file @
61f6804a
...
...
@@ -145,7 +145,6 @@ data TargetType
=
Parsed
-- ^ Parsed source code
|
FlatCurry
-- ^ FlatCurry
|
ExtendedFlatCurry
-- ^ Extended FlatCurry
|
FlatXml
-- ^ FlatCurry as XML
|
AbstractCurry
-- ^ AbstractCurry
|
UntypedAbstractCurry
-- ^ Untyped AbstractCurry
deriving
(
Eq
,
Show
)
...
...
@@ -361,10 +360,6 @@ options =
(
NoArg
(
onOpts
$
\
opts
->
opts
{
optTargetTypes
=
nub
$
ExtendedFlatCurry
:
optTargetTypes
opts
}))
"generate FlatCurry code with source references"
,
Option
""
[
"xml"
]
(
NoArg
(
onOpts
$
\
opts
->
opts
{
optTargetTypes
=
nub
$
FlatXml
:
optTargetTypes
opts
}))
"generate flat xml code"
,
Option
""
[
"acy"
]
(
NoArg
(
onOpts
$
\
opts
->
opts
{
optTargetTypes
=
nub
$
AbstractCurry
:
optTargetTypes
opts
}))
...
...
src/CurryBuilder.hs
View file @
61f6804a
...
...
@@ -158,7 +158,6 @@ process opts idx m fn deps
nameGens
=
[
(
FlatCurry
,
flatName
)
,
(
ExtendedFlatCurry
,
extFlatName
)
,
(
FlatXml
,
xmlName
)
,
(
AbstractCurry
,
acyName
)
,
(
UntypedAbstractCurry
,
uacyName
)
,
(
Parsed
,
sourceRepName
)
...
...
src/IL.hs
View file @
61f6804a
{- |
Module : $Header$
Description : Intermediate language
Copyright : (c) 201
1
, Björn Peemöller
Copyright : (c) 201
4
, Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -9,14 +9,9 @@
Portability : portable
This module is a simple re-export of the definition of the AST of IL
and the pretty-printing
/xml-printing function
s.
and the pretty-printing
of IL module
s.
-}
module
IL
(
module
IL
.
Type
,
ppModule
,
xmlModule
)
where
module
IL
(
module
IL
.
Type
,
ppModule
)
where
import
IL.Pretty
(
ppModule
)
import
IL.Type
import
IL.XML
(
xmlModule
)
src/IL/XML.lhs
deleted
100644 → 0
View file @
98eaa471
% $Id: ILxml.lhs,v 1.0 2001/06/19 12:19:18 rafa Exp $
%
% $Log: ILxml.lhs,v $
%
% Revision 1.1 2001/06/19 12:19:18 rafa
% Pretty printer in XML for the intermediate language added.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
%
\nwfilename{ILxml.lhs}
\section{A pretty printer in XML for the intermediate language}
This module implements just another pretty printer, this time in XML and for
the intermediate language. It was mainly adapted from the Curry pretty
printer (see sect.~\ref{sec:CurryPP}), which in turn is based on Simon
Marlow's pretty printer for Haskell. The format of the output intends to be
similar to that of Flat-Curry XML representation.
\begin{verbatim}
>
module
IL.XML
(
xmlModule
)
where
>
import
Data.Maybe
>
import
Curry.Base.Ident
>
import
Curry.Base.Pretty
>
import
IL.Type
>
import
Base.Messages
(
internalError
)
TODO: The following import should be avoided if possible as it makes
the program structure less clear.
>
import
qualified
Curry.Syntax
as
CS
>
-- identation level
>
level
::
Int
>
level
=
3
>
xmlModule
::
[
CS
.
IDecl
]
->
[
CS
.
IDecl
]
->
Module
->
Doc
>
xmlModule
intf
infx
m
>
=
text
"<prog>"
$$
nest
level
(
xmlBody
intf
infx
m
)
$$
text
"</prog>"
>
xmlBody
::
[
CS
.
IDecl
]
->
[
CS
.
IDecl
]
->
Module
->
Doc
>
xmlBody
intf
infx
(
Module
mname
mimports
decls
)
=
>
xmlElement
"module"
xmlModuleDecl
moduleDecl
$$
>
xmlElement
"import"
xmlImportDecl
importDecl
$$
>
xmlElement
"types"
xmlTypeDecl
typeDecl
$$
>
xmlElement
"functions"
xmlFunctionDecl
funcDecl
$$
>
xmlElement
"operators"
xmlOperatorDecl
operatorDecl
$$
>
xmlElement
"translation"
xmlTranslationDecl
translationDecl
>
where
>
moduleDecl
=
[
mname
]
>
importDecl
=
mimports
>
(
funcDecl
,
typeDecl
)
=
splitDecls
decls
>
operatorDecl
=
infx
>
translationDecl
=
foldl
(
qualIDeclId
mname
)
[]
intf
>
xmlModuleDecl
::
ModuleIdent
->
Doc
>
xmlModuleDecl
=
xmlModuleIdent
>
xmlImportDecl
::
ModuleIdent
->
Doc
>
xmlImportDecl
mname
=
xmlElement
"module"
xmlModuleDecl
[
mname
]
=========================================================================
T Y P E S
=========================================================================
>
xmlTypeDecl
::
Decl
->
Doc
>
xmlTypeDecl
(
DataDecl
tc
arity
cs
)
=
>
beginType
$$
>
nest
level
(
xmlTypeParams
arity
)
$$
>
xmlLines
xmlConstructor
cs
$$
>
endType
>
where
>
beginType
=
text
"<type name=
\"
"
<>
xmlQualIdent
tc
<>
text
"
\"
>"
>
endType
=
text
"</type>"
>
xmlTypeDecl
_
=
internalError
"IL.XML.xmlTypeDecl: no data declaration"
>
xmlTypeParams
::
Int
->
Doc
>
xmlTypeParams
n
=
xmlElement
"params"
xmlTypeVar
[
0
..
(
n
-
1
)]
>
xmlConstructor
::
ConstrDecl
[
Type
]
->
Doc
>
xmlConstructor
(
ConstrDecl
ident
[]
)
=
xmlConstructorBegin
ident
0
>
xmlConstructor
(
ConstrDecl
ident
l
)
=
>
xmlConstructorBegin
ident
(
length
l
)
$$
>
xmlLines
xmlType
l
$$
>
xmlConstructorEnd
>
where
>
xmlConstructorEnd
=
text
"</cons>"
>
xmlConstructorBegin
::
QualIdent
->
Int
->
Doc
>
xmlConstructorBegin
ident
n
=
xmlHeadingWithArity
"cons"
ident
n
(
n
==
0
)
>
xmlHeadingWithArity
::
String
->
QualIdent
->
Int
->
Bool
->
Doc
>
xmlHeadingWithArity
tagName
ident
n
single
=
>
if
single
>
then
prefix
<>
text
"/>"
>
else
prefix
<>
text
">"
>
where
>
prefix
=
text
(
"<"
++
tagName
++
" name=
\"
"
)
<>
qname
<>
text
"
\"
"
<>
arity
>
arity
=
text
"arity=
\"
"
<>
xmlInt
n
<>
text
"
\"
"
>
qname
=
xmlQualIdent
ident
>
xmlType
::
Type
->
Doc
>
xmlType
(
TypeConstructor
ident
[]
)
=
xmlTypeConsBegin
ident
True
>
xmlType
(
TypeConstructor
ident
l
)
=
xmlTypeConsBegin
ident
False
$$
>
xmlLines
xmlType
l
$$
>
xmlTypeConsEnd
>
where
>
xmlTypeConsEnd
=
text
"</tcons>"
>
xmlType
(
TypeVariable
n
)
=
xmlTypeVar
n
>
xmlType
(
TypeArrow
a
b
)
=
xmlTypeFun
a
b
>
xmlTypeConsBegin
::
QualIdent
->
Bool
->
Doc
>
xmlTypeConsBegin
ident
single
=
>
if
single
>
then
prefix
<>
text
"/>"
>
else
prefix
<>
text
">"
>
where
>
qname
=
xmlQualIdent
ident
>
prefix
=
text
"<tcons name=
\"
"
<>
qname
<>
text
"
\"
"
>
xmlTypeVar
::
Int
->
Doc
>
xmlTypeVar
n
=
text
"<tvar>"
<>
xmlInt
n
<>
text
"</tvar>"
>
xmlTypeFun
::
Type
->
Type
->
Doc
>
xmlTypeFun
a
b
=
xmlElement
"functype"
xmlType
[
a
,
b
]
=========================================================================
F U N C T I O N S
=========================================================================
>
xmlFunctionDecl
::
Decl
->
Doc
>
xmlFunctionDecl
(
NewtypeDecl
tc
arity
(
ConstrDecl
ident
ty
))
=
>
xmlFunctionDecl
(
FunctionDecl
ident
[
arg
]
ftype
(
Variable
arg
))
>
where
>
arg
=
mkIdent
"_1"
>
ftype
=
TypeArrow
ty
(
TypeConstructor
tc
(
map
TypeVariable
[
0
..
arity
-
1
]))
>
xmlFunctionDecl
(
FunctionDecl
ident
largs
fType
expr
)
=
>
heading
$$
nest
level
(
xmlRule
largs
expr
)
$$
xmlEndFunction
>
where
>
heading
=
xmlBeginFunction
ident
(
length
largs
)
fType
>
xmlFunctionDecl
(
ExternalDecl
ident
_callConv
internalName
fType
)
=
>
heading
$$
external
$$
xmlEndFunction
>
where
>
heading
=
xmlBeginFunction
ident
(
xmlFunctionArity
fType
)
fType
>
external
=
text
(
"<external>"
>
++
xmlFormat
internalName
>
++
"</external>"
)
>
xmlFunctionDecl
(
DataDecl
_
_
_
)
=
internalError
"IL.XML.xmlFunctionDecl: data declaration"
>
xmlBeginFunction
::
QualIdent
->
Int
->
Type
->
Doc
>
xmlBeginFunction
ident
n
fType
=
heading
$$
typeDecls
>
where
>
heading
=
xmlHeadingWithArity
"func"
ident
n
False
>
typeDecls
=
nest
level
(
xmlType
fType
)
>
xmlEndFunction
::
Doc
>
xmlEndFunction
=
text
"</func>"
>
xmlFunctionArity
::
Type
->
Int
>
xmlFunctionArity
(
TypeConstructor
_
_
)
=
0
>
xmlFunctionArity
(
TypeVariable
_
)
=
0
>
xmlFunctionArity
(
TypeArrow
_
b
)
=
1
+
(
xmlFunctionArity
b
)
>
xmlRule
::
[
Ident
]
->
Expression
->
Doc
>
xmlRule
lArgs
e
=
text
"<rule>"
$$
>
nest
level
(
xmlLhs
lArgs
)
$$
>
nest
level
(
xmlRhs
lArgs
e
)
$$
>
text
"</rule>"
>
xmlLhs
::
[
Ident
]
->
Doc
>
xmlLhs
l
=
xmlElement
"lhs"
xmlVar
[
0
..
((
length
l
)
-
1
)]
>
xmlRhs
::
[
Ident
]
->
Expression
->
Doc
>
xmlRhs
l
e
=
text
"<rhs>"
$$
nest
level
rhs
$$
text
"</rhs>"
>
where
>
varDicc
=
xmlBuildDicc
l
>
(
rhs
,
_
)
=
xmlExpr
varDicc
e
=========================================================================
E X P R E S S I O N S
=========================================================================
>
xmlExpr
::
[(
Int
,
Ident
)]
->
Expression
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlExpr
d
(
Literal
lit
)
=
(
xmlLiteral
(
xmlLit
lit
),
d
)
>
xmlExpr
d
(
Variable
ident
)
=
xmlExprVar
d
ident
>
xmlExpr
d
(
Function
ident
arity
)
=
(
xmlSingleApp
ident
arity
True
,
d
)
>
xmlExpr
d
(
Constructor
ident
arity
)
=
(
xmlSingleApp
ident
arity
False
,
d
)
>
xmlExpr
d
expr
@
(
Apply
_
_
)
=
xmlApply
d
expr
(
xmlAppArgs
expr
)
>
xmlExpr
d
(
Case
_
eval
expr
alt
)
=
xmlCase
d
eval
expr
alt
>
xmlExpr
d
(
Or
expr1
expr2
)
=
xmlOr
d
expr1
expr2
>
xmlExpr
d
(
Exist
ident
expr
)
=
xmlFree
d
ident
expr
>
xmlExpr
d
(
Let
binding
expr
)
=
xmlLet
d
binding
expr
>
xmlExpr
d
(
Letrec
lBinding
expr
)
=
xmlLetrec
d
lBinding
expr
>
xmlExpr
d
(
Typed
expr
ty
)
=
xmlTyped
d
expr
ty
>
xmlSingleApp
::
QualIdent
->
Int
->
Bool
->
Doc
>
xmlSingleApp
ident
arity
isFunction
=
>
if
arity
>
0
>
then
xmlCombHeading
identDoc
(
text
"PartCall"
)
True
>
else
xmlCombHeading
identDoc
(
text
totalApp
)
True
>
where
>
identDoc
=
xmlQualIdent
ident
>
totalApp
=
if
isFunction
then
"FuncCall"
else
"ConsCall"
>
xmlCombHeading
::
Doc
->
Doc
->
Bool
->
Doc
>
xmlCombHeading
cname
cType
single
=
>
if
single
>
then
prefix
<>
text
" />"
>
else
prefix
<>
text
">"
>
where
>
prefix
=
text
"<comb type=
\"
"
<>
cType
<>
text
"
\"
name=
\"
"
<>
cname
<>
text
"
\"
"
>
xmlExprVar
::
[(
Int
,
Ident
)]
->
Ident
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlExprVar
d
ident
=
>
if
isNew
>
then
(
xmlVar
newVar
,
(
newVar
,
ident
)
:
d
)
>
else
(
xmlVar
var
,
d
)
>
where
>
var
=
xmlLookUp
ident
d
>
isNew
=
var
==
-
1
>
newVar
=
xmlNewVar
d
>
xmlApply
::
[(
Int
,
Ident
)]
->
Expression
->
(
Expression
,[
Expression
])
->
>
(
Doc
,[(
Int
,
Ident
)])
>
xmlApply
d
_
((
Function
ident
arity
),
lExp
)
=
>
xmlApplyFunctor
d
ident
arity
lExp
True
>
xmlApply
d
_
((
Constructor
ident
arity
),
lExp
)
=
>
xmlApplyFunctor
d
ident
arity
lExp
False
>
xmlApply
d
(
Apply
expr1
expr2
)
_
=
>
(
text
"<apply>"
$$
nest
level
e1
$$
nest
level
e2
$$
text
"</apply>"
,
d2
)
>
where
>
(
e1
,
d1
)
=
xmlExpr
d
expr1
>
(
e2
,
d2
)
=
xmlExpr
d1
expr2
>
xmlApply
_
_
_
=
internalError
"IL.XML.xmlApply: no pattern match"
>
xmlApplyFunctor
::
[(
Int
,
Ident
)]
->
QualIdent
->
Int
->
[
Expression
]
->
>
Bool
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlApplyFunctor
d
ident
arity
lArgs
isFunction
=
>
xmlCombApply
d
(
xmlQualIdent
ident
)
(
text
cTypeS
)
n
lArgs
>
where
>
n
=
length
lArgs
>
cTypeS
>
|
n
/=
arity
=
"PartCall"
>
|
isFunction
=
"FuncCall"
>
|
otherwise
=
"ConsCall"
>
xmlCombApply
::
[(
Int
,
Ident
)]
->
Doc
->
Doc
->
Int
->
>
[
Expression
]
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlCombApply
d
cname
cType
0
_
=
>
(
xmlCombHeading
cname
cType
True
,
d
)
>
xmlCombApply
d
cname
cType
_
lArgs
=
>
(
xmlCombHeading
cname
cType
False
$$
xmlLines
id
lDocs
$$
text
"</comb>"
,
d1
)
>
where
>
(
lDocs
,
d1
)
=
xmlMapDicc
d
xmlExpr
lArgs
>
xmlAppArgs
::
Expression
->
(
Expression
,[
Expression
])
>
xmlAppArgs
(
Apply
e1
e2
)
=
(
e
,
lArgs
++
[
e2
])
>
where
>
(
e
,
lArgs
)
=
(
xmlAppArgs
e1
)
>
xmlAppArgs
e
=
(
e
,
[]
)
>
xmlCase
::
[(
Int
,
Ident
)]
->
Eval
->
Expression
->
[
Alt
]
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlCase
d
eval
expr
lAlt
=
>
(
heading
$$
nest
level
e1
$$
xmlLines
id
lDocs
$$
end
,
d2
)
>
where
>
sEval
=
if
eval
==
Rigid
then
"
\"
Rigid
\"
"
else
"
\"
Flex
\"
"
>
heading
=
text
"<case type="
<>
text
sEval
<>
text
">"
>
end
=
text
"</case>"
>
(
e1
,
_
)
=
xmlExpr
d
expr
>
(
lDocs
,
d2
)
=
xmlMapDicc
d
xmlBranch
lAlt
>
xmlOr
::
[(
Int
,
Ident
)]
->
Expression
->
Expression
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlOr
d
expr1
expr2
=
>
(
text
"<or>"
$$
nest
level
e1
$$
nest
level
e2
$$
text
"</or>"
,
d2
)
>
where
>
(
e1
,
d1
)
=
xmlExpr
d
expr1
>
(
e2
,
d2
)
=
xmlExpr
d1
expr2
>
xmlBranch
::
[(
Int
,
Ident
)]
->
Alt
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlBranch
d
(
Alt
pattern
expr
)
=
>
(
text
"<branch>"
$$
nest
level
e1
$$
nest
level
e2
$$
text
"</branch>"
,
d2
)
>
where
>
(
e1
,
d1
)
=
xmlPattern
d
pattern
>
(
e2
,
d2
)
=
xmlExpr
d1
expr
>
xmlPattern
::
[(
Int
,
Ident
)]
->
ConstrTerm
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlPattern
d
(
LiteralPattern
lit
)
=
(
xmlLitPattern
(
xmlLit
lit
),
d
)
>
xmlPattern
d
(
ConstructorPattern
ident
lArgs
)
=
xmlConsPattern
d
ident
lArgs
>
xmlPattern
_
(
VariablePattern
_
)
=
internalError
"Variable patterns not allowed in Flat Curry"
>
xmlConsPattern
::
[(
Int
,
Ident
)]
->
QualIdent
->
[
Ident
]
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlConsPattern
d
ident
lArgs
=
>
(
heading
$$
xmlLines
id
lDocs
$$
end
,
d2
)
>
where
>
heading
=
text
"<pattern name=
\"
"
<>
(
xmlQualIdent
ident
)
<>
>
text
"
\"
"
<>
endh
>
endh
=
if
(
length
lArgs
)
>
0
then
text
">"
else
text
"/>"
>
end
=
if
(
length
lArgs
)
>
0
then
text
"</pattern>"
else
empty
>
(
lDocs
,
d2
)
=
xmlMapDicc
d
xmlExprVar
lArgs
>
xmlFree
::
[(
Int
,
Ident
)]
->
Ident
->
Expression
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlFree
d
ident
expr
=
>
(
text
"<freevars>"
$$
nest
level
v
$$
nest
level
e
$$
text
"</freevars>"
,
d2
)
>
where
>
(
v
,
d1
)
=
xmlExprVar
d
ident
>
(
e
,
d2
)
=
xmlExpr
d1
expr
>
xmlLet
::
[(
Int
,
Ident
)]
->
Binding
->
Expression
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlLet
d
binding
expr
=
>
(
text
"<let>"
$$
nest
level
b
$$
nest
level
e
$$
text
"</let>"
,
d2
)
>
where
>
(
b
,
d1
)
=
xmlBinding
d
binding
>
(
e
,
d2
)
=
xmlExpr
d1
expr
>
xmlBinding
::
[(
Int
,
Ident
)]
->
Binding
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlBinding
d
(
Binding
ident
expr
)
=
>
(
text
"<binding>"
$$
nest
level
v
$$
nest
level
e
$$
text
"</binding>"
,
d2
)
>
where
>
(
v
,
_
)
=
xmlExprVar
d
ident
>
(
e
,
d2
)
=
xmlExpr
d
expr
>
xmlLetrec
::
[(
Int
,
Ident
)]
->
[
Binding
]
->
Expression
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlLetrec
d
lB
expr
=
>
(
text
"<letrec>"
$$
xmlLines
id
b
$$
nest
level
e
$$
text
"</letrec>"
,
d2
)
>
where
>
(
b
,
d1
)
=
xmlMapDicc
d
xmlBinding
lB
>
(
e
,
d2
)
=
xmlExpr
d1
expr
>
xmlTyped
::
[(
Int
,
Ident
)]
->
Expression
->
Type
->
(
Doc
,[(
Int
,
Ident
)])
>
xmlTyped
d
expr
ty
=
>
(
text
"<typed>"
$$
nest
level
e1
$$
nest
level
(
xmlType
ty
)
$$
text
"</typed>"
,
d1
)
>
where
(
e1
,
d1
)
=
xmlExpr
d
expr
=========================================================================
A U X I L I A R Y F U N C T I O N S
=========================================================================
>
splitDecls
::
[
Decl
]
->
([
Decl
],[
Decl
])
>
splitDecls
[]
=
(
[]
,
[]
)
>
splitDecls
(
x
:
xs
)
=
case
x
of
>
DataDecl
_
_
_
->
(
functionDecl
,
x
:
typeDecl
)
>
NewtypeDecl
_
_
_
->
(
x
:
functionDecl
,
typeDecl
)
>
FunctionDecl
_
_
_
_
->
(
x
:
functionDecl
,
typeDecl
)
>
ExternalDecl
_
_
_
_
->
(
x
:
functionDecl
,
typeDecl
)
>
where
>
(
functionDecl
,
typeDecl
)
=
splitDecls
xs
>
xmlElement
::
Eq
a
=>
String
->
(
a
->
Doc
)
->
[
a
]
->
Doc
>
xmlElement
n
_
[]
=
text
(
"<"
++
n
++
" />"
)
>
xmlElement
n
f
lDecls
=
beginElement
$$
xmlLines
f
lDecls
$$
endElement
>
where
>
beginElement
=
text
(
"<"
++
n
++
">"
)
>
endElement
=
text
(
"</"
++
n
++
">"
)
>
>
xmlLines
::
(
a
->
Doc
)
->
[
a
]
->
Doc
>
xmlLines
f
=
(
nest
level
)
.
vcat
.
(
map
f
)
>
xmlMapDicc
::
[(
Int
,
Ident
)]
->
([(
Int
,
Ident
)]
->
a
->
(
Doc
,[(
Int
,
Ident
)]))
->
>
[
a
]
->
([
Doc
],[(
Int
,
Ident
)])
>
xmlMapDicc
d
f
lArgs
=
foldl
newArg
(
[]
,
d
)
lArgs
>
where
>
newArg
(
l
,
d'
)
e
=
(
l
++
[
v'
],
d''
)
>
where
(
v'
,
d''
)
=
f
d'
e
>
>
-- The dictionary identifies var names with integers
>
-- it will be ordered starting at the greatest integer
>
xmlBuildDicc
::
[
Ident
]
->
[(
Int
,
Ident
)]
>
xmlBuildDicc
l
=
reverse
(
zip
[
0
..
((
length
l
)
-
1
)]
l
)
>
-- looks for a ident in the dictorionary. If it appears returns its
>
-- associated value. Otherwise, -1 is returned
>
xmlLookUp
::
Ident
->
[(
Int
,
Ident
)]
->
Int
>
xmlLookUp
_
[]
=
-
1
>
xmlLookUp
ident
((
n
,
name
)
:
xs
)
=
if
ident
==
name
>
then
n
>
else
xmlLookUp
ident
xs
>
-- generates a integer corresponding to a new var
>
xmlNewVar
::
[(
Int
,
Ident
)]
->
Int
>
xmlNewVar
[]
=
0
>
xmlNewVar
((
n
,
_
)
:
_
)
=
n
+
1
>
xmlVar
::
Int
->
Doc
>
xmlVar
n
=
text
"<var>"
<>
xmlInt
n
<>
text
"</var>"
>
xmlLiteral
::
Doc
->
Doc
>
xmlLiteral
d
=
text
"<lit>"
$$
nest
level
d
$$
text
"</lit>"
>
xmlLitPattern
::
Doc
->
Doc
>
xmlLitPattern
d
=
text
"<lpattern>"
$$
nest
level
d
$$
text
"</lpattern>"
>
xmlLit
::
Literal
->
Doc
>
xmlLit
(
Char
_
c
)
=
text
"<charc>"
<>
xmlInt
(
fromEnum
c
)
<>
text
"</charc>"
>
xmlLit
(
Int
_
n
)
=
text
"<intc>"
<>
xmlInteger
n
<>
text
"</intc>"
>
xmlLit
(
Float
_
n
)
=
text
"<floatc>"
<>
xmlFloat
n
<>
text
"</floatc>"
>
xmlFixity
::
CS
.
Infix
->
Doc
>
xmlFixity
CS
.
InfixL
=
text
"InfixlOp"
>
xmlFixity
CS
.
InfixR
=
text
"InfixrOp"
>
xmlFixity
CS
.
Infix
=
text
"InfixOp"
>
xmlTranslationDecl
::
QualIdent
->
Doc
>
xmlTranslationDecl
expId
=
>
text
"<trans>"
>
$$
nest
level
(
text
"<name>"
<>
xmlIdent
(
unqualify
expId
)
<>
text
"</name>"
>
$$
text
"<intname>"
<>
xmlQualIdent
expId
<>
text
"</intname>"
)
>
$$
text
"</trans>"
>
xmlIdent
::
Ident
->
Doc
>
xmlIdent
=
text
.
xmlFormat
.
idName
>
xmlInt
::
Int
->
Doc
>
xmlInt
=
text
.
show
>
xmlInteger
::
Integer
->
Doc
>
xmlInteger
=
text
.
show
>
xmlFloat
::
Double
->
Doc
>
xmlFloat
=
text
.
show
>
xmlQualIdent
::
QualIdent
->
Doc
>
xmlQualIdent
=
text
.
xmlFormat
.
qualName
>
xmlModuleIdent
::
ModuleIdent
->
Doc
>
xmlModuleIdent
=
text
.
xmlFormat
.
moduleName
>
xmlFormat
::
String
->
String
>
xmlFormat
[]
=
[]
>
xmlFormat
(
'>'
:
xs
)
=
">"
++
xmlFormat
xs
>
xmlFormat
(
'<'
:
xs
)
=
"<"
++
xmlFormat
xs
>
xmlFormat
(
'&'
:
xs
)
=
"&"
++
xmlFormat
xs
>
xmlFormat
(
x
:
xs
)
=
x
:
(
xmlFormat
xs
)
>
xmlOperatorDecl
::
CS
.
IDecl
->
Doc
>
xmlOperatorDecl
(
CS
.
IInfixDecl
_
fixity
prec
qident
)
=
>
text
"<op fixity=
\"
"
<>
xmlFixity
fixity
>
<>
text
"
\"
prec=
\"
"
<>
xmlInteger
prec
<>
text
"
\"
>"
>
<>
xmlIdent
(
unqualify
qident
)
>
<>
text
"</op>"
>
xmlOperatorDecl
_
=
empty
>
qualIDeclId
::
ModuleIdent
->
[
QualIdent
]
->
CS
.
IDecl
->
[
QualIdent
]
>
qualIDeclId
mid
qids
(
CS
.
IDataDecl
_
qid
_
mcdecls
)
>
=
foldl
(
qualConstrDeclId
mid
)
(
qid
:
qids
)
(
catMaybes
mcdecls
)
>
qualIDeclId
mid
qids
(
CS
.
INewtypeDecl
_
qid
_
ncdecl
)
>
=
qualNewConstrDeclId
mid
(
qid
:
qids
)
ncdecl
>
qualIDeclId
_
qids
(
CS
.
ITypeDecl
_
qid
_
_
)
>
=
qid
:
qids
>
qualIDeclId
_
qids
(
CS
.
IFunctionDecl
_
qid
_
_
)
>
=
qid
:
qids
>
qualIDeclId
_
qids
_
=
qids
>
qualConstrDeclId
::
ModuleIdent
->
[
QualIdent
]
->
CS
.
ConstrDecl
->
[
QualIdent
]
>
qualConstrDeclId
mid
qids
(
CS
.
ConstrDecl
_
_
ident
_
)
>
=
(
qualifyWith
mid
ident
)
:
qids
>
qualConstrDeclId
mid
qids
(
CS
.
ConOpDecl
_
_
_
ident
_
)
>
=
(
qualifyWith
mid
ident
)
:
qids
>
qualNewConstrDeclId
::
ModuleIdent
->
[
QualIdent
]
->
CS
.
NewConstrDecl
> -
>
[
QualIdent
]
>
qualNewConstrDeclId
mid
qids
(
CS
.
NewConstrDecl
_
_
ident
_
)
>
=
(
qualifyWith
mid
ident
)
:
qids
\end{verbatim}
src/Modules.hs
View file @
61f6804a
...
...
@@ -61,14 +61,13 @@ import Transformations
-- The function 'compileModule' is the main entry-point of this
-- module for compiling a Curry source module. Depending on the command
-- line options, it will emit either FlatCurry code (standard or in XML
-- representation) or AbstractCurry code (typed, untyped or with type
-- signatures) for the module
-- line options, it will emit either FlatCurry code or AbstractCurry code
-- (typed, untyped or with type signatures) for the module.
-- Usually, the first step is to check the module.
-- Then the code is translated into the intermediate
-- language. If necessary, this phase will also update the module's
-- interface file. The resulting code then is written out
(in
--
FlatCurry or XML format)
to the corresponding file.
-- interface file. The resulting code then is written out
-- to the corresponding file.
-- The untyped AbstractCurry representation is written
-- out directly after parsing and simple checking the source file.
-- The typed AbstractCurry code is written out after checking the module.
...
...
@@ -216,7 +215,7 @@ checkModule opts (env, mdl) = do
where
debugOpts
=
optDebugOpts
opts
withTypeCheck
=
any
(`
elem
`
optTargetTypes
opts
)
[
FlatCurry
,
ExtendedFlatCurry
,
FlatXml
,
AbstractCurry
]
[
FlatCurry
,
ExtendedFlatCurry
,
AbstractCurry
]
-- ---------------------------------------------------------------------------
-- Translating a module
...
...
@@ -266,8 +265,7 @@ writeOutput opts fn (env, modul) = do
let
modSum
=
summarizeModule
(
tyConsEnv
env2
)
intf
qlfd
writeFlat
opts
fn
env2
modSum
il
where
withFlat
=
any
(`
elem
`
optTargetTypes
opts
)
[
FlatCurry
,
FlatXml
,
ExtendedFlatCurry
]
withFlat
=
any
(`
elem
`
optTargetTypes
opts
)
[
FlatCurry
,
ExtendedFlatCurry
]
-- The functions \texttt{genFlat} and \texttt{genAbstract} generate
-- flat and abstract curry representations depending on the specified option.
...
...
@@ -313,11 +311,9 @@ writeFlat opts fn env modSum il = do
when
(
extTarget
||
fcyTarget
)
$
do
writeFlatCurry
opts
fn
env
modSum
il
writeFlatIntf
opts
fn
env
modSum
il
when
(
xmlTarget
)
$
writeFlatXml
opts
fn
modSum
il
where
extTarget
=
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
fcyTarget
=
FlatCurry
`
elem
`
optTargetTypes
opts
xmlTarget
=
FlatXml
`
elem
`
optTargetTypes
opts
-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
...
...
@@ -332,13 +328,6 @@ writeFlatCurry opts fn env modSum il = do
useSubDir
=
optUseSubdir
opts
(
prog
,
msgs
)
=
genFlatCurry
opts
modSum
env
il
-- |Export an 'IL.Module' into an XML file
writeFlatXml
::
Options
->
FilePath
->
ModuleSummary
->
IL
.
Module
->
IO
()
writeFlatXml
opts
fn
modSum
il
=
writeModule
useSubDir
(
xmlName
fn
)
curryXml
where
useSubDir
=
optUseSubdir
opts
curryXml
=
shows
(
IL
.
xmlModule
(
interface
modSum
)
(
infixDecls
modSum
)
il
)
"
\n
"
writeFlatIntf
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
->
IL
.
Module
->
IO
()
writeFlatIntf
opts
fn
env
modSum
il
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment