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
146865c7
Commit
146865c7
authored
Aug 23, 2011
by
Björn Peemöller
Browse files
Many different changes
parent
d63b8fd7
Changes
46
Hide whitespace changes
Inline
Side-by-side
curry-frontend.cabal
View file @
146865c7
...
...
@@ -63,16 +63,16 @@ Executable cymake
, Base.TypeSubst
, Base.Typing
, Base.Utils
, Check.KindCheck
, Check.PrecCheck
, Check.SyntaxCheck
, Check.TypeCheck
, Check.WarnCheck
, Check
s
.KindCheck
, Check
s
.PrecCheck
, Check
s
.SyntaxCheck
, Check
s
.TypeCheck
, Check
s
.WarnCheck
, Env.Arity
, Env.Eval
, Env.Interface
s
, Env.Interface
, Env.Label
, Env.ModuleAlias
es
, Env.ModuleAlias
, Env.NestEnv
, Env.OldScopeEnv
, Env.OpPrec
...
...
@@ -80,19 +80,19 @@ Executable cymake
, Env.TopEnv
, Env.TypeConstructors
, Env.Value
, Gen.GenAbstractCurry
, Gen.GenFlatCurry
, Gen
erators
.GenAbstractCurry
, Gen
erators
.GenFlatCurry
, Html.CurryHtml
, Html.SyntaxColoring
, IL.Pretty
, IL.Type
, IL.XML
, Transform.CaseCompletion
, Transform.CurryToIL
, Transform.Desugar
, Transform.Lift
, Transform.Qual
, Transform.Simplify
, Transform
ations
.CaseCompletion
, Transform
ations
.CurryToIL
, Transform
ations
.Desugar
, Transform
ations
.Lift
, Transform
ations
.Qual
, Transform
ations
.Simplify
Library
hs-source-dirs: src
Build-Depends: filepath
...
...
src/Base/Expr.hs
View file @
146865c7
...
...
@@ -16,7 +16,6 @@ import qualified Data.Set as Set (fromList, notMember)
import
Curry.Base.Ident
import
Curry.Syntax
import
qualified
IL
class
Expr
e
where
fv
::
e
->
[
Ident
]
...
...
@@ -200,21 +199,3 @@ bvFuncPatt = bvfp []
bvfp
bvs
(
InfixFuncPattern
t1
_
t2
)
=
foldl
bvfp
bvs
[
t1
,
t2
]
bvfp
bvs
(
RecordPattern
fs
r
)
=
foldl
bvfp
(
maybe
bvs
(
bvfp
bvs
)
r
)
(
map
fieldTerm
fs
)
-- intermediate language
instance
Expr
IL
.
Expression
where
fv
(
IL
.
Variable
v
)
=
[
v
]
fv
(
IL
.
Apply
e1
e2
)
=
fv
e1
++
fv
e2
fv
(
IL
.
Case
_
_
e
alts
)
=
fv
e
++
fv
alts
fv
(
IL
.
Or
e1
e2
)
=
fv
e1
++
fv
e2
fv
(
IL
.
Exist
v
e
)
=
filter
(
/=
v
)
(
fv
e
)
fv
(
IL
.
Let
(
IL
.
Binding
v
e1
)
e2
)
=
fv
e1
++
filter
(
/=
v
)
(
fv
e2
)
fv
(
IL
.
Letrec
bds
e
)
=
filter
(`
notElem
`
vs
)
(
fv
es
++
fv
e
)
where
(
vs
,
es
)
=
unzip
[(
v
,
e'
)
|
IL
.
Binding
v
e'
<-
bds
]
fv
_
=
[]
instance
Expr
IL
.
Alt
where
fv
(
IL
.
Alt
(
IL
.
ConstructorPattern
_
vs
)
e
)
=
filter
(`
notElem
`
vs
)
(
fv
e
)
fv
(
IL
.
Alt
(
IL
.
VariablePattern
v
)
e
)
=
filter
(
v
/=
)
(
fv
e
)
fv
(
IL
.
Alt
_
e
)
=
fv
e
src/Base/TypeSubst.lhs
View file @
146865c7
...
...
@@ -16,12 +16,11 @@ This module implements substitutions on types.
>
import
Data.List
(
nub
)
>
import
Data.Maybe
(
fromJust
,
isJust
)
>
import
Env.TopEnv
>
import
Env.Value
(
ValueInfo
(
..
))
>
import
Base.Subst
>
import
Base.Types
>
import
Env.TopEnv
>
import
Env.Value
(
ValueInfo
(
..
))
>
type
TypeSubst
=
Subst
Int
Type
...
...
src/Checks.hs
View file @
146865c7
{- |
Module : $Header$
Description : Different checks on a Curry module
Copyright : (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module subsumes the different checks to be performed on a Curry
module during compilation, e.g. type checking.
-}
module
Checks
where
import
Curry.Base.MessageMonad
(
Message
)
import
Curry.Syntax
import
qualified
Check.KindCheck
as
KC
(
kindCheck
)
import
qualified
Check.PrecCheck
as
PC
(
precCheck
)
import
qualified
Check.SyntaxCheck
as
SC
(
syntaxCheck
)
import
qualified
Check.TypeCheck
as
TC
(
typeCheck
)
import
qualified
Check.WarnCheck
as
WC
(
warnCheck
)
import
qualified
Check
s
.KindCheck
as
KC
(
kindCheck
)
import
qualified
Check
s
.PrecCheck
as
PC
(
precCheck
)
import
qualified
Check
s
.SyntaxCheck
as
SC
(
syntaxCheck
)
import
qualified
Check
s
.TypeCheck
as
TC
(
typeCheck
)
import
qualified
Check
s
.WarnCheck
as
WC
(
warnCheck
)
import
CompilerEnv
import
CompilerOpts
-- TODO: More documentation
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck
::
[
Decl
]
->
CompilerEnv
->
([
Decl
],
CompilerEnv
)
kindCheck
decls
env
=
(
decls'
,
env
)
where
decls'
=
KC
.
kindCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
decls
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck
::
[
Decl
]
->
CompilerEnv
->
([
Decl
],
CompilerEnv
)
precCheck
decls
env
=
(
decls'
,
env
{
opPrecEnv
=
pEnv'
})
where
(
pEnv'
,
decls'
)
=
PC
.
precCheck
(
moduleIdent
env
)
(
opPrecEnv
env
)
decls
-- |Apply the syntax check.
syntaxCheck
::
Options
->
[
Decl
]
->
CompilerEnv
->
([
Decl
],
CompilerEnv
)
syntaxCheck
opts
decls
env
=
(
decls'
,
env
)
where
decls'
=
SC
.
syntaxCheck
withExt
(
moduleIdent
env
)
(
aliasEnv
env
)
(
arityEnv
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
decls
withExt
=
BerndExtension
`
elem
`
optExtensions
opts
-- |Apply the type check.
typeCheck
::
[
Decl
]
->
CompilerEnv
->
([
Decl
],
CompilerEnv
)
typeCheck
decls
env
=
(
decls
,
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
})
where
(
tcEnv'
,
tyEnv'
)
=
TC
.
typeCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
decls
-- TODO: Which one?
-- |Check for warnings.
warnCheck
::
CompilerEnv
->
([
Decl
],
[
Decl
])
->
[
Message
]
warnCheck
env
=
uncurry
$
WC
.
warnCheck
(
moduleIdent
env
)
(
valueEnv
env
)
src/Check/KindCheck.lhs
→
src/Check
s
/KindCheck.lhs
View file @
146865c7
...
...
@@ -22,7 +22,7 @@ hand side of a type declaration are actually defined and no identifier
is defined more than once.
\begin{verbatim}
>
module
Check.KindCheck
(
kindCheck
)
where
>
module
Check
s
.KindCheck
(
kindCheck
)
where
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
...
...
src/Check/PrecCheck.lhs
→
src/Check
s
/PrecCheck.lhs
View file @
146865c7
...
...
@@ -15,7 +15,7 @@ and rearrange infix applications according to the relative precedences
of the operators involved.
\begin{verbatim}
>
module
Check.PrecCheck
(
precCheck
)
where
>
module
Check
s
.PrecCheck
(
precCheck
)
where
>
import
Data.List
(
partition
,
mapAccumL
)
...
...
src/Check/SyntaxCheck.lhs
→
src/Check
s
/SyntaxCheck.lhs
View file @
146865c7
...
...
@@ -19,7 +19,7 @@ the same key.} Finally, all (adjacent) equations of a function are
merged into a single definition.
\begin{verbatim}
>
module
Check.SyntaxCheck
(
syntaxCheck
)
where
>
module
Check
s
.SyntaxCheck
(
syntaxCheck
)
where
>
import
Control.Monad.State
as
S
(
State
,
evalState
,
get
,
liftM
,
modify
)
>
import
Data.List
((
\\
),
find
,
insertBy
,
partition
)
...
...
@@ -36,7 +36,7 @@ merged into a single definition.
>
import
Base.Utils
((
++!
),
findDouble
,
mapAccumM
)
>
import
Env.Arity
(
ArityEnv
,
ArityInfo
(
..
),
lookupArity
,
qualLookupArity
)
>
import
Env.ModuleAlias
es
(
AliasEnv
,
lookupAlias
)
>
import
Env.ModuleAlias
(
AliasEnv
,
lookupAlias
)
>
import
Env.NestEnv
>
import
Env.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
))
...
...
@@ -72,12 +72,12 @@ A global state transformer is used for generating fresh integer keys
by which the variables get renamed.
\begin{verbatim}
>
type
RenameState
a
=
S
.
State
Int
a
>
type
RenameState
a
=
S
.
State
Int
eger
a
>
run
::
RenameState
a
->
a
>
run
m
=
S
.
evalState
m
(
globalKey
+
1
)
>
newId
::
RenameState
Int
>
newId
::
RenameState
Int
eger
>
newId
=
S
.
modify
succ
>>
S
.
get
\end{verbatim}
...
...
@@ -108,7 +108,7 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
>
|
RecordLabel
QualIdent
[
Ident
]
>
deriving
(
Eq
,
Show
)
>
globalKey
::
Int
>
globalKey
::
Int
eger
>
globalKey
=
uniqueId
(
mkIdent
""
)
>
renameInfo
::
TCEnv
->
AliasEnv
->
ArityEnv
->
ValueInfo
->
RenameInfo
...
...
@@ -253,7 +253,7 @@ local declarations.
>
checkModule
withExt
m
env
ds
=
liftM
snd
(
checkTopDecls
withExt
m
env
ds
)
>
checkTopDecls
::
Bool
->
ModuleIdent
->
RenameEnv
->
[
Decl
]
>
->
RenameState
(
RenameEnv
,[
Decl
])
>
->
RenameState
(
RenameEnv
,
[
Decl
])
>
checkTopDecls
withExt
m
env
ds
=
>
checkDeclGroup
(
bindFuncDecl
m
)
withExt
m
globalKey
env
ds
...
...
@@ -288,14 +288,14 @@ top-level.
>
newId
>>=
\
k
->
checkDeclGroup
bindVarDecl
withExt
m
k
(
nestEnv
env
)
ds
>
checkDeclGroup
::
(
Decl
->
RenameEnv
->
RenameEnv
)
->
Bool
->
ModuleIdent
>
->
Int
->
RenameEnv
->
[
Decl
]
>
->
Int
eger
->
RenameEnv
->
[
Decl
]
>
->
RenameState
(
RenameEnv
,[
Decl
])
>
checkDeclGroup
bindDecl
withExt
m
k
env
ds
=
>
mapM
(
checkDeclLhs
withExt
k
m
env
)
ds'
>>=
>
checkDecls
bindDecl
withExt
m
env
.
joinEquations
>
where
ds'
=
sortFuncDecls
ds
>
checkDeclLhs
::
Bool
->
Int
->
ModuleIdent
->
RenameEnv
->
Decl
->
RenameState
Decl
>
checkDeclLhs
::
Bool
->
Int
eger
->
ModuleIdent
->
RenameEnv
->
Decl
->
RenameState
Decl
>
checkDeclLhs
_
k
_
_
(
InfixDecl
p
fix'
pr
ops
)
=
>
return
(
InfixDecl
p
fix'
pr
(
map
(
flip
renameIdent
k
)
ops
))
>
checkDeclLhs
_
k
_
env
(
TypeSig
p
vs
ty
)
=
...
...
@@ -318,7 +318,7 @@ top-level.
>
(
map
(
checkVar
"free variables declaration"
k
env
)
vs
))
>
checkDeclLhs
_
_
_
_
d
=
return
d
>
checkEquationLhs
::
Bool
->
Int
->
ModuleIdent
->
RenameEnv
->
Position
>
checkEquationLhs
::
Bool
->
Int
eger
->
ModuleIdent
->
RenameEnv
->
Position
> -
>
[
Equation
]
->
RenameState
Decl
>
checkEquationLhs
withExt
k
m
env
p
[
Equation
p'
lhs
rhs
]
=
>
either
(
return
.
funDecl
)
(
checkDeclLhs
withExt
k
m
env
.
patDecl
)
...
...
@@ -329,7 +329,7 @@ top-level.
>
|
otherwise
=
PatternDecl
p'
t
rhs
>
checkEquationLhs
_
_
_
_
_
_
=
internalError
"checkEquationLhs"
>
checkEqLhs
::
ModuleIdent
->
Int
->
RenameEnv
->
Position
->
Lhs
>
checkEqLhs
::
ModuleIdent
->
Int
eger
->
RenameEnv
->
Position
->
Lhs
>
->
Either
(
Ident
,
Lhs
)
ConstrTerm
>
checkEqLhs
m
k
env
_
(
FunLhs
f
ts
)
>
|
isDataConstr
f
env
...
...
@@ -358,7 +358,7 @@ top-level.
>
Right
_
->
errorAt'
$
nonVariable
"curried definition"
f
>
where
(
f
,
_
)
=
flatLhs
lhs
>
checkOpLhs
::
Int
->
RenameEnv
->
(
ConstrTerm
->
ConstrTerm
)
->
ConstrTerm
>
checkOpLhs
::
Int
eger
->
RenameEnv
->
(
ConstrTerm
->
ConstrTerm
)
->
ConstrTerm
>
->
Either
(
Ident
,
Lhs
)
ConstrTerm
>
checkOpLhs
k
env
f
(
InfixPattern
t1
op
t2
)
>
|
isJust
m
||
isDataConstr
op'
env
=
...
...
@@ -368,14 +368,14 @@ top-level.
>
op''
=
renameIdent
op'
k
>
checkOpLhs
_
_
f
t
=
Right
(
f
t
)
>
checkVar
::
String
->
Int
->
RenameEnv
->
Ident
->
Ident
>
checkVar
::
String
->
Int
eger
->
RenameEnv
->
Ident
->
Ident
>
checkVar
what
k
env
v
>
|
False
&&
isDataConstr
v
env
=
errorAt'
(
nonVariable
what
v
)
---------------
>
|
otherwise
=
renameIdent
v
k
>
checkDecls
::
(
Decl
->
RenameEnv
->
RenameEnv
)
->
Bool
->
ModuleIdent
> -
>
RenameEnv
->
[
Decl
]
->
RenameState
(
RenameEnv
,[
Decl
])
> -
>
RenameEnv
->
[
Decl
]
->
RenameState
(
RenameEnv
,
[
Decl
])
>
checkDecls
bindDecl
withExt
m
env
ds
=
>
case
findDouble
bvs
of
>
Nothing
->
...
...
@@ -441,7 +441,7 @@ top-level.
>
checkLhsTerm
withExt
k
p
m
env
lhs
>>=
>
return
.
checkConstrTerms
withExt
(
nestEnv
env
)
>
checkLhsTerm
::
Bool
->
Int
->
Position
->
ModuleIdent
->
RenameEnv
->
Lhs
>
checkLhsTerm
::
Bool
->
Int
eger
->
Position
->
ModuleIdent
->
RenameEnv
->
Lhs
>
->
RenameState
Lhs
>
checkLhsTerm
withExt
k
p
m
env
(
FunLhs
f
ts
)
=
>
do
...
...
@@ -479,7 +479,7 @@ top-level.
>
Just
v
->
errorAt'
(
duplicateVariable
v
)
>
where
bvs
=
bv
ts
>
checkConstrTerm
::
Bool
->
Int
->
Position
->
ModuleIdent
->
RenameEnv
>
checkConstrTerm
::
Bool
->
Int
eger
->
Position
->
ModuleIdent
->
RenameEnv
> -
>
ConstrTerm
->
RenameState
ConstrTerm
>
checkConstrTerm
_
_
_
_
_
(
LiteralPattern
l
)
=
>
liftM
LiteralPattern
(
renameLiteral
l
)
...
...
@@ -613,7 +613,7 @@ top-level.
>
checkConstrTerm
_
_
_
_
_
(
InfixFuncPattern
_
_
_
)
=
error
$
>
"SyntaxCheck.checkConstrTerm: infix function pattern not defined"
>
checkFieldPatt
::
Bool
->
Int
->
ModuleIdent
->
QualIdent
->
RenameEnv
>
checkFieldPatt
::
Bool
->
Int
eger
->
ModuleIdent
->
QualIdent
->
RenameEnv
> -
>
Field
ConstrTerm
->
RenameState
(
Field
ConstrTerm
)
>
checkFieldPatt
withExt
k
m
r
env
(
Field
p
l
t
)
>
=
case
(
lookupVar
l
env
)
of
...
...
src/Check/TypeCheck.lhs
→
src/Check
s
/TypeCheck.lhs
View file @
146865c7
...
...
@@ -21,7 +21,7 @@ unannotated declarations, but allows for polymorphic recursion when a
type annotation is present.
\begin{verbatim}
>
module
Check.TypeCheck
(
typeCheck
)
where
>
module
Check
s
.TypeCheck
(
typeCheck
)
where
>
import
Control.Monad.State
as
S
>
import
Data.List
(
nub
,
partition
)
...
...
src/Check/WarnCheck.hs
→
src/Check
s
/WarnCheck.hs
View file @
146865c7
...
...
@@ -4,7 +4,7 @@
February 2006,
Martin Engelke (men@informatik.uni-kiel.de)
-}
module
Check.WarnCheck
(
warnCheck
)
where
module
Check
s
.WarnCheck
(
warnCheck
)
where
import
Control.Monad.State
(
State
,
execState
,
filterM
,
gets
,
modify
,
unless
,
when
)
import
qualified
Data.Map
as
Map
(
empty
,
insert
,
lookup
)
...
...
src/CompilerEnv.hs
View file @
146865c7
{- |
Module : $Header$
Description : Environment containing the module's information
Copyright : (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module defines an environment for a module containing the information
needed throughout the compilation of the module.
-}
-- TODO: rename to Base.ModuleEnv ?
module
CompilerEnv
where
import
Curry.Base.Ident
(
ModuleIdent
)
import
Env.Arity
import
Env.Eval
import
Env.Interface
s
import
Env.Interface
import
Env.Label
import
Env.ModuleAlias
es
import
Env.ModuleAlias
import
Env.OpPrec
import
Env.TypeConstructors
import
Env.Value
-- |A compiler environment
-- |A compiler environment contains information about the module currently
-- compiled. The information is updated during the different stages of
-- compilation.
data
CompilerEnv
=
CompilerEnv
{
moduleIdent
::
ModuleIdent
,
aliasEnv
::
AliasEnv
,
arityEnv
::
ArityEnv
,
evalAnnotEnv
::
EvalEnv
,
interfaceEnv
::
InterfaceEnv
,
labelEnv
::
LabelEnv
,
opPrecEnv
::
PEnv
,
tyConsEnv
::
TCEnv
,
valueEnv
::
ValueEnv
{
moduleIdent
::
ModuleIdent
-- ^ identifier of the module
,
aliasEnv
::
AliasEnv
-- ^ aliases for imported modules
,
arityEnv
::
ArityEnv
-- ^ arity of functions and data constructors
,
evalAnnotEnv
::
EvalEnv
-- ^ evaluation annotations
,
interfaceEnv
::
InterfaceEnv
-- ^ declarations of imported interfaces
,
labelEnv
::
LabelEnv
-- ^ record labels
,
opPrecEnv
::
PEnv
-- ^ operator precedences
,
tyConsEnv
::
TCEnv
-- ^ type constructors
,
valueEnv
::
ValueEnv
-- ^ functions, ...
}
initCompilerEnv
::
ModuleIdent
->
CompilerEnv
...
...
@@ -31,7 +49,7 @@ initCompilerEnv mid = CompilerEnv
,
arityEnv
=
initAEnv
,
evalAnnotEnv
=
initEEnv
,
interfaceEnv
=
initInterfaceEnv
,
labelEnv
=
initLEnv
,
labelEnv
=
initL
abel
Env
,
opPrecEnv
=
initPEnv
,
tyConsEnv
=
initTCEnv
,
valueEnv
=
initDCEnv
...
...
src/CompilerOpts.hs
View file @
146865c7
...
...
@@ -37,13 +37,13 @@ data Options = Options
,
optImportPaths
::
[
FilePath
]
-- ^ directories for imports
,
optOutput
::
Maybe
FilePath
-- ^ name of output file
,
optUseSubdir
::
Bool
-- ^ use subdir for output?
,
optInterface
::
Bool
-- ^
do not
create an interface file
,
optWarn
::
Bool
-- ^ warnings
on/off
,
optOverlapWarn
::
Bool
-- ^ "overlap" warnings
on/off
,
optInterface
::
Bool
-- ^ create an interface file
,
optWarn
::
Bool
-- ^
show
warnings
,
optOverlapWarn
::
Bool
-- ^
show
"overlap" warnings
,
optTargetTypes
::
[
TargetType
]
-- ^ what to generate
,
optExtensions
::
[
Extension
]
-- ^ language extensions
,
optExtensions
::
[
Extension
]
-- ^
enabled
language extensions
,
optDumps
::
[
DumpLevel
]
-- ^ dumps
}
-- deriving Show
}
-- | Default compiler options
defaultOptions
::
Options
...
...
@@ -64,14 +64,14 @@ defaultOptions = Options
,
optDumps
=
[]
}
-- |
Data type representing the t
ype of the target file
-- |
T
ype of the target file
data
TargetType
=
Parsed
|
FlatCurry
|
ExtendedFlatCurry
|
FlatXml
|
AbstractCurry
|
UntypedAbstractCurry
=
Parsed
-- ^ Parsed source code
|
FlatCurry
-- ^ FlatCurry
|
ExtendedFlatCurry
-- ^ Extended FlatCurry
|
FlatXml
-- ^ FlatCurry as XML
|
AbstractCurry
-- ^ AbstractCurry
|
UntypedAbstractCurry
-- ^ UntypedAbstractCurry
deriving
Eq
-- |Data type representing the verbosity level
...
...
@@ -90,11 +90,11 @@ classifyVerbosity _ = Verbose
-- |Data type for representing code dumps
data
DumpLevel
=
DumpRenamed
-- ^ dump source after renaming
|
DumpTypes
-- ^ dump types after typechecking
|
DumpDesugared
-- ^ dump source after desugaring
|
DumpSimplified
-- ^ dump source after simplification
|
DumpLifted
-- ^ dump source after lambda-lifting
=
DumpRenamed
-- ^ dump source
after renaming
|
DumpTypes
-- ^ dump types
after typechecking
|
DumpDesugared
-- ^ dump source
after desugaring
|
DumpSimplified
-- ^ dump source
after simplification
|
DumpLifted
-- ^ dump source
after lambda-lifting
|
DumpIL
-- ^ dump IL code after translation
|
DumpCase
-- ^ dump IL code after case elimination
deriving
(
Eq
,
Bounded
,
Enum
,
Show
)
...
...
src/CurryBuilder.hs
View file @
146865c7
{- |CurryBuilder - Generates Curry representations for a Curry source file
including all imported modules.
September 2005, Martin Engelke (men@informatik.uni-kiel.de)
March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
May 2011, refinements b Bjoern Peemoeller (bjp@informatik.uni-kiel.de)
{- |
Module : $Header$
Description : Build tool for compiling multiple Curry modules
Copyright : (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
2007, Sebastian Fischer (sebf@informatik.uni-kiel.de)
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module contains functions to generate Curry representations for a
Curry source file including all imported modules.
-}
module
CurryBuilder
(
buildCurry
,
smake
)
where
...
...
@@ -23,45 +31,53 @@ import CompilerOpts (Options (..), TargetType (..))
import
CurryDeps
(
Source
(
..
),
flatDeps
)
import
Modules
(
compileModule
)
{- |Compile the Curry program 'file' including all imported modules,
depending on the 'Options'. The compilation was successful if the
returned list is empty, otherwise it contains error messages.
-}
-- |Compile the Curry module in the given source file including all imported
-- modules, depending on the 'Options'.
buildCurry
::
Options
->
FilePath
->
IO
()
buildCurry
opts
file
=
do
mbFile
<-
lookupCurryFile
(
optImportPaths
opts
)
file
case
mbFile
of
Nothing
->
abortWith
[
errMissingFile
file
]
Just
f
->
do
(
mods
,
errs
)
<-
flatDeps
opts
f
if
null
errs
then
makeCurry
(
defaultToFlatCurry
opts
)
mods
f
else
abortWith
errs
where
defaultToFlatCurry
opt
|
null
$
optTargetTypes
opt
=
opt
{
optTargetTypes
=
[
FlatCurry
]
}
|
otherwise
=
opt
Just
fn
->
do
(
srcs
,
depErrs
)
<-
flatDeps
opts
fn
if
not
$
null
depErrs
then
abortWith
depErrs
else
makeCurry
(
defaultToFlatCurry
opts
)
srcs
fn
where
defaultToFlatCurry
opt
|
null
$
optTargetTypes
opt
=
opt
{
optTargetTypes
=
[
FlatCurry
]
}
|
otherwise
=
opt
-- |Compiles the given source modules, which must be in topological order
makeCurry
::
Options
->
[(
ModuleIdent
,
Source
)]
->
FilePath
->
IO
()
makeCurry
opts
mods
targetFile
=
mapM_
(
compile
.
snd
)
mods
where
compile
(
Source
file
deps
)
=
do
interfaceExists
<-
doesModuleExist
$
flatIntName
file
if
dropExtension
targetFile
==
dropExtension
file
then
if
interfaceExists
&&
not
(
optForce
opts
)
&&
null
(
optDumps
opts
)
then
smake
(
targetNames
file
)
-- dest files
(
file
:
mapMaybe
flatInterface
deps
)
-- dep files
(
generateFile
file
)
-- action on changed
(
skipFile
file
)
-- action on unchanged
else
generateFile
file
else
if
interfaceExists
then
smake
[
flatName'
file
]
(
file
:
mapMaybe
flatInterface
deps
)
(
compileFile
file
)
(
skipFile
file
)
else
compileFile
file
makeCurry
opts
srcs
targetFile
=
mapM_
(
compile
.
snd
)
srcs
where
compile
(
Source
fn
deps
)
=
do
interfaceExists
<-
doesModuleExist
$
flatIntName
fn
let
isFinalFile
=
dropExtension
targetFile
==
dropExtension
fn
isEnforced
=
optForce
opts
||
(
not
$
null
$
optDumps
opts
)
destFiles
=
if
isFinalFile
then
destNames
fn
else
[
flatName'
fn
]
depFiles
=
fn
:
mapMaybe
flatInterface
deps
actOutdated
=
if
isFinalFile
then
generateFile
fn
else
compileFile
fn
actUpToDate
=
skipFile
fn
if
interfaceExists
&&
not
(
isEnforced
&&
isFinalFile
)
then
smake
destFiles
depFiles
actOutdated
actUpToDate
else
actOutdated
compile
_
=
return
()
targetNames
fn
=
[
gen
fn
|
(
tgt
,
gen
)
<-
nameGens
,
tgt
`
elem
`
optTargetTypes
opts
]
compileFile
f
=
do
status
opts
$
"compiling "
++
f
compileModule
(
opts
{
optTargetTypes
=
[
FlatCurry
],
optDumps
=
[]
})
f
skipFile
f
=
status
opts
$
"skipping "
++
f
generateFile
f
=
do
status
opts
$
"generating "
++
head
(
destNames
f
)
compileModule
opts
f
destNames
fn
=
[
gen
fn
|
(
tgt
,
gen
)
<-
nameGens
,
tgt
`
elem
`
optTargetTypes
opts
]
where
nameGens
=
[
(
FlatCurry
,
flatName
)
,
(
ExtendedFlatCurry
,
extFlatName
)
...
...
@@ -72,52 +88,38 @@ makeCurry opts mods targetFile = mapM_ (compile . snd) mods where
,
(
FlatXml
,
xmlName
)
]
flatInterface
mod1
=
case
lookup
mod1
mods
of
Just
(
Source
file
_
)
->
Just
$
flatIntName
file
Just
(
Interface
file
)
->
Just
$
flatIntName
file
_
->
Nothing
flatName'
|
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
=
extFlatName
|
otherwise
=
flatName
compileFile
f
=
do
status
opts
$
"compiling "
++
f
compileModule
(
opts
{
optTargetTypes
=
[
FlatCurry
],
optDumps
=
[]
})
f
generateFile
f
=
do
status
opts
$
"generating "
++
head
(
targetNames
f
)
compileModule
opts
f
skipFile
f
=
status
opts
$
"skipping "
++
f
{- |A simple make function
smake <destination files>
<dependencies>
<io action, if dependencies are newer than destination files>
<io action, if destination files are newer than dependencies>
-}
smake
::
[
FilePath
]
->
[
FilePath
]
->
IO
a
->
IO
a
->
IO
a
smake
dests
deps
cmd
alt
=
do
flatInterface
m
=
case
lookup
m
srcs
of
Just
(
Source
fn
_
)
->
Just
$
flatIntName
fn
Just
(
Interface
fn
)
->
Just
$
flatIntName
fn
_
->
Nothing
extTarget
=
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
flatName'
=
if
extTarget
then
extFlatName
else
flatName
-- |A simple make function
smake
::
[
FilePath
]
-- ^ destination files
->
[
FilePath
]
-- ^ dependency files
->
IO
a
-- ^ action to perform if depedency files are newer
->
IO
a
-- ^ action to perform if destination files are newer