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
1b277857
Commit
1b277857
authored
May 20, 2011
by
Björn Peemöller
Browse files
Refinements
parent
c039d19f
Changes
7
Expand all
Hide whitespace changes
Inline
Side-by-side
src/Curry/Syntax/Parser.lhs
View file @
1b277857
...
...
@@ -83,9 +83,8 @@ parseIface = Interface <$-> token Id_interface
>
topDecl
::
Bool
->
Parser
Token
Decl
a
>
topDecl
flat
>
|
flat
=
infixDecl
<|>
dataDecl
flat
<|>
typeDecl
<|>
functionDecl
flat
>
|
otherwise
=
infixDecl
>
<|>
dataDecl
flat
<|>
newtypeDecl
<|>
typeDecl
>
|
flat
=
infixDecl
<|>
dataDecl
flat
<|>
typeDecl
<|>
functionDecl
flat
>
|
otherwise
=
infixDecl
<|>
dataDecl
flat
<|>
newtypeDecl
<|>
typeDecl
>
<|>
functionDecl
flat
<|>
externalDecl
>
localDefs
::
Bool
->
Parser
Token
[
Decl
]
a
...
...
src/CurryBuilder.hs
View file @
1b277857
...
...
@@ -8,7 +8,7 @@
module
CurryBuilder
(
buildCurry
,
smake
)
where
import
Control.Monad
(
liftM
,
unless
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
,
mapMaybe
)
import
System.Time
(
ClockTime
)
import
Curry.Base.Ident
...
...
@@ -27,16 +27,14 @@ import Modules (compileModule)
-}
buildCurry
::
Options
->
FilePath
->
IO
()
buildCurry
opts
file
=
do
f
ile
'
<-
lookupCurryFile
importPaths
file
case
f
ile
'
of
mbF
ile
<-
lookupCurryFile
importPaths
file
case
mbF
ile
of
Nothing
->
abortWith
[
missingModule
file
]
Just
f
->
do
(
deps
,
errs
)
<-
flatDeps
implicitlyAddPrelude
importPaths
[]
f
(
deps
,
errs
)
<-
flatDeps
opts
f
unless
(
null
errs
)
$
abortWith
errs
makeCurry
(
defaultToFlatCurry
opts
)
deps
f
where
importPaths
=
optImportPaths
opts
implicitlyAddPrelude
=
NoImplicitPrelude
`
notElem
`
optExtensions
opts
missingModule
f
=
"Error: missing module
\"
"
++
f
++
"
\"
"
defaultToFlatCurry
opt
|
null
$
optTargetTypes
opt
=
opt
{
optTargetTypes
=
[
FlatCurry
]
}
...
...
@@ -53,7 +51,7 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
flatIntfExists
<-
doesModuleExist
(
flatIntName
file
)
if
flatIntfExists
&&
not
(
optForce
opts
)
&&
null
(
optDumps
opts
)
then
smake
(
targetNames
file
)
(
targetFile
:
(
cat
Maybe
s
(
map
flatInterface
mods
)
))
(
targetFile
:
map
Maybe
flatInterface
mods
)
(
generateFile
file
)
(
skipFile
file
)
else
generateFile
file
...
...
@@ -61,44 +59,45 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
flatIntfExists
<-
doesModuleExist
(
flatIntName
file
)
if
flatIntfExists
then
smake
[
flatName'
opts
file
]
(
file
:
(
cat
Maybe
s
(
map
flatInterface
mods
)
))
(
file
:
map
Maybe
flatInterface
mods
)
(
compileFile
file
)
(
skipFile
file
)
else
compileFile
file
compileFile
f
=
do
status
opts
$
"compiling "
++
f
compileModule
(
compOpts
True
)
f
>>
return
()
skipFile
f
=
status
opts
$
"skipping "
++
f
generateFile
f
=
do
status
opts
$
"generating "
++
head
(
targetNames
f
)
compileModule
(
compOpts
False
)
f
>>
return
()
targetNames
fn
=
map
((
$
fn
)
.
snd
)
targetNames
fn
=
map
((
$
fn
)
.
snd
)
$
filter
((`
elem
`
optTargetTypes
opts
)
.
fst
)
$
nameGens
nameGens
where
nameGens
=
[
(
FlatCurry
,
flatName
)
,
(
ExtendedFlatCurry
,
extFlatName
)
,
(
FlatXml
,
xmlName
)
,
(
AbstractCurry
,
acyName
)
,
(
UntypedAbstractCurry
,
uacyName
)
,
(
Parsed
,
\
f
->
fromMaybe
(
sourceRepName
f
)
(
optOutput
opts
))
,
(
Parsed
,
\
f
->
fromMaybe
(
sourceRepName
f
)
(
optOutput
opts
))
,
(
FlatXml
,
xmlName
)
]
flatInterface
mod1
=
case
(
lookup
mod1
deps1
)
of
flatInterface
mod1
=
case
lookup
mod1
deps1
of
Just
(
Source
file
_
)
->
Just
$
flatIntName
file
Just
(
Interface
file
)
->
Just
$
flatIntName
file
_
->
Nothing
compileFile
f
=
do
status
opts
$
"compiling "
++
f
compileModule
(
compOpts
True
)
f
>>
return
()
skipFile
f
=
status
opts
$
"skipping "
++
f
generateFile
f
=
do
status
opts
$
"generating "
++
head
(
targetNames
f
)
compileModule
(
compOpts
False
)
f
>>
return
()
compOpts
isImport
|
isImport
=
opts
{
optTargetTypes
=
[
FlatCurry
],
optDumps
=
[]
}
|
otherwise
=
opts
flatName'
::
Options
->
FilePath
->
FilePath
flatName'
opts
|
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
=
extFlatName
...
...
@@ -115,26 +114,22 @@ smake :: [FilePath] -> [FilePath] -> IO a -> IO a -> IO a
smake
dests
deps
cmd
alt
=
do
destTimes
<-
getDestTimes
dests
depTimes
<-
getDepTimes
deps
abortOnError
(
make
destTimes
depTimes
)
abortOnError
$
make
destTimes
depTimes
where
make
destTimes
depTimes
|
(
length
destTimes
)
<
(
length
dests
)
=
cmd
|
null
depTimes
=
abortWith
[
"unknown dependencies"
]
|
outOfDate
destTimes
depTimes
=
cmd
|
otherwise
=
alt
|
length
destTimes
<
length
dests
=
cmd
|
null
depTimes
=
abortWith
[
"unknown dependencies"
]
|
outOfDate
destTimes
depTimes
=
cmd
|
otherwise
=
alt
--
getDestTimes
::
[
FilePath
]
->
IO
[
ClockTime
]
getDestTimes
=
liftM
catMaybes
.
mapM
tryGetModuleModTime
--
getDepTimes
::
[
String
]
->
IO
[
ClockTime
]
getDepTimes
=
mapM
(
abortOnError
.
getModuleModTime
)
--
outOfDate
::
[
ClockTime
]
->
[
ClockTime
]
->
Bool
outOfDate
tgtimes
dptimes
=
or
[
tg
<
dp
|
tg
<-
tgtimes
,
dp
<-
dptimes
]
abortOnError
::
IO
a
->
IO
a
abortOnError
act
=
catch
act
(
\
err
->
abortWith
[
show
err
])
abortOnError
act
=
catch
act
(
\
err
->
abortWith
[
show
err
])
src/CurryDeps.lhs
View file @
1b277857
...
...
@@ -5,7 +5,7 @@
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
% Extended by Sebastian Fischer (sebf@informatik.uni-kiel.de)
% Modified by Bj
ö
rn Peem
ö
ller
(bjp@informatik.uni-kiel.de)
% Modified by Bj
oe
rn Peem
oe
ller (bjp@informatik.uni-kiel.de)
%
\nwfilename{CurryDeps.lhs}
\section{Building Programs}
...
...
@@ -26,21 +26,27 @@ dependencies and to update programs composed of multiple modules.
>
import
Curry.Files.Filenames
>
import
Curry.Files.PathUtils
>
import
Curry.Syntax
hiding
(
Interface
(
..
))
>
import
CompilerOpts
(
Options
(
..
),
Extension
(
..
))
>
import
SCC
(
scc
)
>
data
Source
=
Source
FilePath
[
ModuleIdent
]
>
|
Interface
FilePath
>
|
Unknown
>
deriving
(
Eq
,
Ord
,
Show
)
>
data
Source
>
=
Source
FilePath
[
ModuleIdent
]
>
|
Interface
FilePath
>
|
Unknown
>
deriving
(
Eq
,
Ord
,
Show
)
>
type
SourceEnv
=
Map
.
Map
ModuleIdent
Source
>
flatDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
FilePath
>
->
IO
([(
ModuleIdent
,
Source
)],
[
String
])
>
flatDeps
implicitPrelude
paths
libPaths
fn
=
do
>
mEnv
<-
deps
implicitPrelude
paths
libPaths
Map
.
empty
fn
>
flatDeps
::
Options
->
FilePath
->
IO
([(
ModuleIdent
,
Source
)],
[
String
])
>
flatDeps
opts
fn
=
do
>
mEnv
<-
deps
implicitPrelude
[]
libPaths
Map
.
empty
fn
>
return
$
flattenDeps
mEnv
>
where
>
implicitPrelude
=
NoImplicitPrelude
`
notElem
`
optExtensions
otps
>
libPaths
=
optImportPaths
opts
>
deps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
FilePath
->
IO
SourceEnv
>
deps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
FilePath
>
->
IO
SourceEnv
>
deps
implicitPrelude
paths
libPaths
mEnv
fn
>
|
e
`
elem
`
sourceExts
>
=
sourceDeps
implicitPrelude
paths
libPaths
(
mkMIdent
[
r
])
mEnv
fn
...
...
@@ -53,7 +59,8 @@ dependencies and to update programs composed of multiple modules.
>
where
r
=
dropExtension
fn
>
e
=
takeExtension
fn
>
targetDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
FilePath
->
IO
SourceEnv
>
targetDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
FilePath
>
->
IO
SourceEnv
>
targetDeps
implicitPrelude
paths
libraryPaths
mEnv
fn
=
>
lookupFile
[
""
]
sourceExts
fn
>>=
>
maybe
(
return
(
Map
.
insert
m
Unknown
mEnv
))
...
...
@@ -84,7 +91,8 @@ is added implicitly to the list of imported modules except for the
prelude itself. Any errors reported by the parser are ignored.
\begin{verbatim}
>
moduleDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
ModuleIdent
->
IO
SourceEnv
>
moduleDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
ModuleIdent
>
->
IO
SourceEnv
>
moduleDeps
implicitPrelude
paths
libraryPaths
mEnv
m
=
>
case
Map
.
lookup
m
mEnv
of
>
Just
_
->
return
mEnv
...
...
@@ -109,6 +117,8 @@ prelude itself. Any errors reported by the parser are ignored.
>
(
Map
.
insert
m
(
Source
fn
ms
)
mEnv
)
ms
>
Left
_
->
return
(
Map
.
insert
m
(
Source
fn
[]
)
mEnv
)
>
-- |Retrieve the imported modules and add the import of the Prelude
>
-- according to the flag.
>
imports
::
Bool
->
ModuleIdent
->
[
Decl
]
->
[
ModuleIdent
]
>
imports
implicitPrelude
m
ds
=
nub
$
>
[
preludeMIdent
|
m
/=
preludeMIdent
&&
implicitPrelude
]
...
...
@@ -125,21 +135,22 @@ that the dependency graph should not contain any cycles.
>
>
modules
(
m
,
_
)
=
[
m
]
>
>
imports'
(
_
,
Source
_
ms
)
=
ms
>
imports'
(
_
,
Interface
_
)
=
[]
>
imports'
(
_
,
Unknown
)
=
[]
>
imports'
(
_
,
Source
_
ms
)
=
ms
>
imports'
(
_
,
Interface
_
)
=
[]
>
imports'
(
_
,
Unknown
)
=
[]
>
>
fdeps
::
[[(
ModuleIdent
,
Source
)]]
->
([(
ModuleIdent
,
Source
)],
[
String
])
>
fdeps
=
foldr
checkdep
(
[]
,
[]
)
>
>
checkdep
[]
(
ms'
,
es'
)
=
(
ms'
,
es'
)
>
checkdep
[
m
]
(
ms'
,
es'
)
=
(
m
:
ms'
,
es'
)
>
checkdep
dep
(
ms'
,
es'
)
=
(
ms'
,
cyclicError
(
map
fst
dep
)
:
es'
)
>
checkdep
[]
(
ms'
,
es'
)
=
(
ms'
,
es'
)
>
checkdep
[
m
]
(
ms'
,
es'
)
=
(
m
:
ms'
,
es'
)
>
checkdep
dep
(
ms'
,
es'
)
=
(
ms'
,
cyclicError
(
map
fst
dep
)
:
es'
)
>
cyclicError
::
[
ModuleIdent
]
->
String
>
cyclicError
ms
=
"Cylic import dependency between modules "
++
>
intercalate
", "
inits
++
" and "
++
lastm
where
>
(
inits
,
lastm
)
=
splitLast
$
map
moduleName
ms
>
splitLast
[]
=
error
"CurryDeps.splitLast: empty list"
>
splitLast
(
x
:
[]
)
=
(
[]
,
x
)
>
splitLast
(
x
:
y
:
ys
)
=
(
x
:
xs
,
z
)
where
(
xs
,
z
)
=
splitLast
(
y
:
ys
)
>
(
inits
,
lastm
)
=
splitLast
$
map
moduleName
ms
>
splitLast
[]
=
error
"CurryDeps.splitLast: empty list"
>
splitLast
(
x
:
[]
)
=
(
[]
,
x
)
>
splitLast
(
x
:
y
:
ys
)
=
(
x
:
xs
,
z
)
>
where
(
xs
,
z
)
=
splitLast
(
y
:
ys
)
src/Gen/GenAbstractCurry.hs
View file @
1b277857
...
...
@@ -22,112 +22,105 @@ import Env.TopEnv
import
Messages
(
internalError
,
errorAt
)
import
Types
-------------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
-- Interface
-- ---------------------------------------------------------------------------
-- Generates standard (type infered) AbstractCurry code from a CurrySyntax
-- module. The function needs the type environment 'tyEnv' to determin the
-- infered function types.
--
|
Generates standard (type infered) AbstractCurry code from a CurrySyntax
--
module. The function needs the type environment 'tyEnv' to determin the
--
infered function types.
genTypedAbstract
::
ValueEnv
->
TCEnv
->
Module
->
CurryProg
genTypedAbstract
tyEnv
tcEnv
modul
=
genAbstract
(
genAbstractEnv
TypedAcy
tyEnv
tcEnv
modul
)
modul
-- Generates untyped AbstractCurry code from a CurrySyntax module. The type
-- signature takes place in every function type annotation, if it exists,
-- otherwise the dummy type "Prelude.untyped" is used.
-- |Generates untyped AbstractCurry code from a CurrySyntax module. The type
-- signature takes place in every function type annotation, if it exists,
-- otherwise the dummy type "Prelude.untyped" is used.
genUntypedAbstract
::
ValueEnv
->
TCEnv
->
Module
->
CurryProg
genUntypedAbstract
tyEnv
tcEnv
modul
=
genAbstract
(
genAbstractEnv
UntypedAcy
tyEnv
tcEnv
modul
)
modul
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Private...
-- Generates an AbstractCurry program term from the syntax tree
-- |Generate an AbstractCurry program term from the syntax tree
genAbstract
::
AbstractEnv
->
Module
->
CurryProg
genAbstract
env
(
Module
mid
_
decls
)
=
let
partitions
=
foldl
partitionDecl
emptyPartitions
decl
s
modname
=
moduleName
mid
(
imps
,
_
)
=
mapfoldl
genImportDecl
env
(
reverse
(
importDecls
p
artitions
))
(
types
,
_
)
=
mapfoldl
genTypeDecl
env
(
reverse
(
typeDecls
partitions
))
(
_
,
funcs
)
=
Map
.
mapAccumWithKey
(
genFuncDecl
False
)
env
(
funcDecls
partitions
)
(
ops
,
_
)
=
mapfoldl
genOpDecl
env
(
reverse
(
opDecls
p
artitions
))
in
CurryProg
modname
imps
types
(
Map
.
elems
funcs
)
ops
=
CurryProg
modname
imps
types
(
Map
.
elems
funcs
)
op
s
where
modname
=
moduleName
mid
partitions
=
foldl
partitionDecl
emptyP
artitions
decls
(
imps
,
_
)
=
mapfoldl
genImportDecl
env
(
reverse
(
importDecls
partitions
)
)
(
types
,
_
)
=
mapfoldl
genTypeDecl
env
(
reverse
(
typeDecls
partitions
))
(
_
,
funcs
)
=
Map
.
mapAccumWithKey
(
genFuncDecl
False
)
env
(
funcDecls
partitions
)
(
ops
,
_
)
=
mapfoldl
genOpDecl
env
(
reverse
(
opDecls
partitions
))
-- ---------------------------------------------------------------------------
-- P
artitions
-- ---------------------------------------------------------------------------
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- The following types and functions can be used to spread a list of
-- CurrySyntax declarations into four parts: a list of imports, a list of
-- type declarations (data types and type synonyms), a table of function
-- declarations and a list of fixity declarations.
{- |Data type for representing partitions of CurrySyntax declarations
(according to the definition of the AbstractCurry program
representation; type 'CurryProg').
Since a complete function declaration usually consist of more than one
declaration (e.g. rules, type signature etc.), it is necessary
to collect them within an association list
-}
data
Partitions
=
Partitions
{
importDecls
::
[
Decl
]
,
typeDecls
::
[
Decl
]
,
funcDecls
::
Map
.
Map
Ident
[
Decl
]
,
opDecls
::
[
Decl
]
}
deriving
Show
-- |Generate initial partitions
emptyPartitions
::
Partitions
emptyPartitions
=
Partitions
{
importDecls
=
[]
,
typeDecls
=
[]
,
funcDecls
=
Map
.
empty
,
opDecls
=
[]
}
-- Inserts a CurrySyntax top level declaration into a partition.
-- Note: declarations are collected in reverse order.
partitionDecl
::
Partitions
->
Decl
->
Partitions
partitionDecl
partitions
(
TypeSig
pos
ids
typeexpr
)
=
partitionFuncDecls
(
\
ident
->
TypeSig
pos
[
ident
]
typeexpr
)
partitions
ids
partitionDecl
partitions
(
EvalAnnot
pos
ids
annot
)
=
partitionFuncDecls
(
\
ident
->
EvalAnnot
pos
[
ident
]
annot
)
partitions
ids
partitionDecl
partitions
(
FunctionDecl
pos
ident
equs
)
=
partitionFuncDecls
(
const
(
FunctionDecl
pos
ident
equs
))
partitions
[
ident
]
partitionDecl
partitions
(
ExternalDecl
pos
conv
dname
ident
typeexpr
)
=
partitionFuncDecls
(
const
(
ExternalDecl
pos
conv
dname
ident
typeexpr
))
partitions
[
ident
]
partitionDecl
partitions
(
FlatExternalDecl
pos
ids
)
=
partitionFuncDecls
(
\
ident
->
FlatExternalDecl
pos
[
ident
])
partitions
ids
partitionDecl
partitions
(
InfixDecl
pos
fix
prec
idents
)
=
partitions
{
opDecls
=
map
(
\
ident
->
(
InfixDecl
pos
fix
prec
[
ident
]))
idents
++
opDecls
partitions
}
partitionDecl
partitions
decl
=
case
decl
of
ImportDecl
_
_
_
_
_
->
partitions
{
importDecls
=
decl
:
importDecls
partitions
}
DataDecl
_
_
_
_
->
partitions
{
typeDecls
=
decl
:
typeDecls
partitions
}
TypeDecl
_
_
_
_
->
partitions
{
typeDecls
=
decl
:
typeDecls
partitions
}
_
->
partitions
-- import decls
partitionDecl
parts
decl
@
(
ImportDecl
_
_
_
_
_
)
=
parts
{
importDecls
=
decl
:
importDecls
parts
}
-- type decls
partitionDecl
parts
decl
@
(
DataDecl
_
_
_
_
)
=
parts
{
importDecls
=
decl
:
typeDecls
parts
}
partitionDecl
parts
decl
@
(
TypeDecl
_
_
_
_
)
=
parts
{
importDecls
=
decl
:
typeDecls
parts
}
-- func decls
partitionDecl
parts
(
TypeSig
pos
ids
tyexpr
)
=
partitionFuncDecls
(
\
ident
->
TypeSig
pos
[
ident
]
tyexpr
)
parts
ids
partitionDecl
parts
(
EvalAnnot
pos
ids
annot
)
=
partitionFuncDecls
(
\
ident
->
EvalAnnot
pos
[
ident
]
annot
)
parts
ids
partitionDecl
parts
(
FunctionDecl
pos
ident
equs
)
=
partitionFuncDecls
(
const
(
FunctionDecl
pos
ident
equs
))
parts
[
ident
]
partitionDecl
parts
(
ExternalDecl
pos
conv
dname
ident
tyexpr
)
=
partitionFuncDecls
(
const
(
ExternalDecl
pos
conv
dname
ident
tyexpr
))
parts
[
ident
]
partitionDecl
parts
(
FlatExternalDecl
pos
ids
)
=
partitionFuncDecls
(
\
ident
->
FlatExternalDecl
pos
[
ident
])
parts
ids
-- op decls
partitionDecl
parts
(
InfixDecl
pos
fix
prec
idents
)
=
partitions
{
opDecls
=
map
(
\
ident
->
(
InfixDecl
pos
fix
prec
[
ident
]))
idents
++
opDecls
parts
}
-- default
partitionDecl
parts
_
=
parts
--
partitionFuncDecls
::
(
Ident
->
Decl
)
->
Partitions
->
[
Ident
]
->
Partitions
partitionFuncDecls
genDecl
partitions
ids
=
partitions
{
funcDecls
=
foldl
partitionFuncDecl
(
funcDecls
partitions
)
ids
}
where
partitionFuncDecl
funcs'
ident
=
Map
.
insert
ident
(
genDecl
ident
:
fromMaybe
[]
(
Map
.
lookup
ident
funcs'
))
funcs'
-- Data type for representing partitions of CurrySyntax declarations
-- (according to the definition of the AbstractCurry program
-- representation; type 'CurryProg').
-- Since a complete function declaration usually consist of more than one
-- declaration (e.g. rules, type signature etc.), it is necessary
-- to collect them within an association list
data
Partitions
=
Partitions
{
importDecls
::
[
Decl
],
typeDecls
::
[
Decl
],
funcDecls
::
Map
.
Map
Ident
[
Decl
],
opDecls
::
[
Decl
]
}
deriving
Show
-- Generates initial partitions
emptyPartitions
::
Partitions
emptyPartitions
=
Partitions
{
importDecls
=
[]
,
typeDecls
=
[]
,
funcDecls
=
Map
.
empty
,
opDecls
=
[]
}
partitionFuncDecls
genDecl
parts
ids
=
parts
{
funcDecls
=
foldl
partitionFuncDecl
(
funcDecls
parts
)
ids
}
where
partitionFuncDecl
funcs'
ident
=
Map
.
insert
ident
(
genDecl
ident
:
fromMaybe
[]
(
Map
.
lookup
ident
funcs'
))
funcs'
-------------------------------------------------------------------------------
-- The following functions convert CurrySyntax terms to AbstractCurry
...
...
src/Gen/GenFlatCurry.hs
View file @
1b277857
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
--
-- GenFlatCurry - Generates FlatCurry program terms and FlatCurry interfaces
-- (type 'FlatCurry.Prog')
...
...
@@ -7,6 +6,7 @@
-- November 2005,
-- Martin Engelke (men@informatik.uni-kiel.de)
--
-- ---------------------------------------------------------------------------
module
Gen.GenFlatCurry
(
genFlatCurry
,
genFlatInterface
)
where
-- Haskell libraries
...
...
@@ -55,6 +55,13 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
prog'
=
-- eraseTypes $
adjustTypeInfo
$
adjustTypeInfo
$
patchPreludeFCY
prog
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
WarnMsg
])
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
patchPreludeFCY
intf
,
messages
)
where
(
intf
,
messages
)
=
run
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
True
(
visitModule
modul
)
patchPreludeFCY
::
Prog
->
Prog
patchPreludeFCY
p
@
(
Prog
n
_
types
funcs
ops
)
...
...
@@ -87,56 +94,42 @@ prelude = "Prelude"
maxTupleArity
::
Int
maxTupleArity
=
15
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
WarnMsg
])
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
patchPreludeFCY
intf
,
messages
)
where
(
intf
,
messages
)
=
run
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
True
(
visitModule
modul
)
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
-- The environment 'FlatEnv' is embedded in the monadic representation
-- 'FlatState' which allows the usage of 'do' expressions.
type
FlatState
a
=
State
FlatEnv
a
-- Data type for representing an environment which contains information needed
-- for generating FlatCurry code.
data
FlatEnv
=
FlatEnv
{
moduleIdE
::
ModuleIdent
,
functionIdE
::
(
QualIdent
,
[(
Ident
,
IL
.
Type
)]),
compilerOptsE
::
Options
,
moduleEnvE
::
ModuleEnv
,
arityEnvE
::
ArityEnv
,
typeEnvE
::
ValueEnv
,
-- types of defined values
tConsEnvE
::
TCEnv
,
publicEnvE
::
Map
.
Map
Ident
IdentExport
,
fixitiesE
::
[
CS
.
IDecl
],
typeSynonymsE
::
[
CS
.
IDecl
],
importsE
::
[
CS
.
IDecl
],
exportsE
::
[
CS
.
Export
],
interfaceE
::
[
CS
.
IDecl
],
varIndexE
::
Int
,
varIdsE
::
ScopeEnv
Ident
VarIndex
,
tvarIndexE
::
Int
,
messagesE
::
[
WarnMsg
],
genInterfaceE
::
Bool
,
localTypes
::
Map
.
Map
QualIdent
IL
.
Type
,
constrTypes
::
Map
.
Map
QualIdent
IL
.
Type
}
data
FlatEnv
=
FlatEnv
{
moduleIdE
::
ModuleIdent
,
functionIdE
::
(
QualIdent
,
[(
Ident
,
IL
.
Type
)])
,
compilerOptsE
::
Options
,
moduleEnvE
::
ModuleEnv
,
arityEnvE
::
ArityEnv
,
typeEnvE
::
ValueEnv
-- types of defined values
,
tConsEnvE
::
TCEnv
,
publicEnvE
::
Map
.
Map
Ident
IdentExport
,
fixitiesE
::
[
CS
.
IDecl
]
,
typeSynonymsE
::
[
CS
.
IDecl
]
,
importsE
::
[
CS
.
IDecl
]
,
exportsE
::
[
CS
.
Export
]
,
interfaceE
::
[
CS
.
IDecl
]
,
varIndexE
::
Int
,
varIdsE
::
ScopeEnv
Ident
VarIndex
,
tvarIndexE
::
Int
,
messagesE
::
[
WarnMsg
]
,
genInterfaceE
::
Bool
,
localTypes
::
Map
.
Map
QualIdent
IL
.
Type
,
constrTypes
::
Map
.
Map
QualIdent
IL
.
Type
}
data
IdentExport
=
NotConstr
-- function, type-constructor
|
OnlyConstr
-- constructor
|
NotOnlyConstr
-- constructor, function, type-constructor
-- Runs a 'FlatState' action and returns the result
run
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
Bool
->
FlatState
a
->
(
a
,
[
WarnMsg
])
...
...
src/Modules.lhs
View file @
1b277857
This diff is collapsed.
Click to expand it.
src/Utils.lhs
View file @
1b277857
...
...
@@ -25,28 +25,28 @@ here.
\begin{verbatim}
>
fst3
::
(
a
,
b
,
c
)
->
a
>
fst3
(
x
,
_
,
_
)
=
x
>
fst3
(
x
,
_
,
_
)
=
x
>
snd3
::
(
a
,
b
,
c
)
->
b
>
snd3
(
_
,
y
,
_
)
=
y
>
snd3
(
_
,
y
,
_
)
=
y
>
thd3
::
(
a
,
b
,
c
)
->
c
>
thd3
(
_
,
_
,
z
)
=
z
>
thd3
(
_
,
_
,
z
)
=
z
>
apFst3
::
(
a
->
d
)
->
(
a
,
b
,
c
)
->
(
d
,
b
,
c
)
>
apFst3
f
(
x
,
y
,
z
)
=
(
f
x
,
y
,
z
)
>
apFst3
f
(
x
,
y
,
z
)
=
(
f
x
,
y
,
z
)
>
apSnd3
::
(
b
->
d
)
->
(
a
,
b
,
c
)
->
(
a
,
d
,
c
)
>
apSnd3
f
(
x
,
y
,
z
)
=
(
x
,
f
y
,
z
)
>
apSnd3
f
(
x
,
y
,
z
)
=
(
x
,
f
y
,
z
)
>
apThd3
::
(
c
->
d
)
->
(
a
,
b
,
c
)
->
(
a
,
b
,
d
)
>
apThd3
f
(
x
,
y
,
z
)
=
(
x
,
y
,
f
z
)
>
apThd3
f
(
x
,
y
,
z
)
=
(
x
,
y
,
f
z
)
>
curry3
::
((
a
,
b
,
c
)
->
d
)
->
a
->
b
->
c
->
d
>
curry3
f
x
y
z
=
f
(
x
,
y
,
z
)
>
curry3
f
x
y
z
=
f
(
x
,
y
,
z
)
>
uncurry3
::
(
a
->
b
->
c
->
d
)
->
(
a
,
b
,
c
)
->
d
>
uncurry3
f
(
x
,
y
,
z
)
=
f
x
y
z
>
uncurry3
f
(
x
,
y
,
z
)
=
f
x
y
z
\end{verbatim}
\paragraph{Lists}
...
...
@@ -80,14 +80,14 @@ definitions are unfolded for efficiency reasons.
\begin{verbatim}
>
foldl2
::
(
a
->
b
->
c
->
a
)
->
a
->
[
b
]
->
[
c
]
->
a
>
foldl2
_
z
[]
_
=
z
>
foldl2
_
z
_
[]
=
z
>
foldl2
f
z
(
x
:
xs
)
(
y
:
ys
)
=
foldl2
f
(
f
z
x
y
)
xs
ys
>
foldl2
_
z
[]
_
=
z
>
foldl2
_
z
_
[]
=
z
>
foldl2
f
z
(
x
:
xs
)
(
y
:
ys
)
=
foldl2
f
(
f
z
x