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
fd408993
Commit
fd408993
authored
May 17, 2011
by
Björn Peemöller
Browse files
Compiler options improved
parent
6675c3f1
Changes
9
Hide whitespace changes
Inline
Side-by-side
curry-frontend.cabal
View file @
fd408993
...
...
@@ -74,7 +74,7 @@ Executable cymake
, Html.CurryHtml
, Html.SyntaxColoring
, CurryBuilder
,
Curry
CompilerOpts
, CompilerOpts
, CurryDeps
, CurryToIL
, Exports
...
...
src/
Curry
CompilerOpts.hs
→
src/CompilerOpts.hs
View file @
fd408993
{- |
Curry
CompilerOpts - Defines data structures containing options for
{- |CompilerOpts - Defines data structures containing options for
compiling Curry programs (see module "CurryCompiler")
September 2005, Martin Engelke (men@informatik.uni-kiel.de)
March 2007 , extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
May 2011 , refinements by Bj
ö
rn Peem
ö
ller (bjp@informatik.uni-kiel.de)
May 2011 , refinements by Bj
oe
rn Peem
oe
ller (bjp@informatik.uni-kiel.de)
-}
module
CurryCompilerOpts
(
Options
(
..
),
Dump
(
..
),
defaultOptions
,
compilerOpts
,
usage
)
where
module
CompilerOpts
(
Options
(
..
),
Verbosity
(
..
),
TargetType
(
..
),
Extension
(
..
)
,
DumpLevel
(
..
),
defaultOptions
,
compilerOpts
,
usage
)
where
import
Data.List
(
nub
)
import
Data.Maybe
(
isJust
)
...
...
@@ -17,33 +19,66 @@ import Curry.Files.Filenames (currySubdir)
-- |Data type for recording compiler options
data
Options
=
Options
{
help
::
Bool
-- ^ show help
,
version
::
Bool
-- ^ show the version
,
force
::
Bool
-- ^ force compilation
,
html
::
Bool
-- ^ generate Html code
,
importPaths
::
[
FilePath
]
-- ^ directories for imports
,
output
::
Maybe
FilePath
-- ^ name of output file
,
noInterface
::
Bool
-- ^ do not create an interface file
,
noVerb
::
Bool
-- ^ verbosity on/off
,
noWarn
::
Bool
-- ^ warnings on/off
,
noOverlapWarn
::
Bool
-- ^ "overlap" warnings on/off
,
flat
::
Bool
-- ^ generate FlatCurry code
,
extendedFlat
::
Bool
-- ^ generate FlatCurry code with extensions
,
flatXml
::
Bool
-- ^ generate flat XML code
,
abstract
::
Bool
-- ^ generate typed AbstracCurry code
,
untypedAbstract
::
Bool
-- ^ generate untyped AbstractCurry code
,
parseOnly
::
Bool
-- ^ generate source representation
,
withExtensions
::
Bool
-- ^ enable extended functionalities
,
dump
::
[
Dump
]
-- ^ dumps
,
writeToSubdir
::
Bool
-- ^ should the output be written to the subdir?
,
xNoImplicitPrelude
::
Bool
-- ^ extension: no implicit import Prelude
}
deriving
Show
-- general
{
optHelp
::
Bool
-- ^ show help
,
optVersion
::
Bool
-- ^ show the version
,
optHtml
::
Bool
-- ^ generate Html code
,
optVerbosity
::
Verbosity
-- ^ verbosity level
-- compilation
,
optForce
::
Bool
-- ^ force compilation
,
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
,
optTargetTypes
::
[
TargetType
]
-- ^ what to generate
,
optExtensions
::
[
Extension
]
-- ^ language extensions
,
optDumps
::
[
DumpLevel
]
-- ^ dumps
}
-- deriving Show
-- | Default compiler options
defaultOptions
::
Options
defaultOptions
=
Options
{
optHelp
=
False
,
optVersion
=
False
,
optHtml
=
False
,
optVerbosity
=
Verbose
,
optForce
=
False
,
optImportPaths
=
[]
,
optOutput
=
Nothing
,
optUseSubdir
=
True
,
optInterface
=
True
,
optWarn
=
True
,
optOverlapWarn
=
True
,
optTargetTypes
=
[]
,
optExtensions
=
[]
,
optDumps
=
[]
}
data
TargetType
=
Parsed
|
FlatCurry
|
ExtendedFlatCurry
|
FlatXml
|
AbstractCurry
|
UntypedAbstractCurry
deriving
Eq
data
Verbosity
=
Quiet
|
Verbose
deriving
Eq
classifyVerbosity
::
String
->
Verbosity
classifyVerbosity
"0"
=
Quiet
classifyVerbosity
_
=
Verbose
-- TODO: dump FlatCurry code, dump AbstractCurry code, dump after 'case'
-- expansion
-- |Data type for representing code dumps
data
Dump
data
Dump
Level
=
DumpRenamed
-- ^ dump source after renaming
|
DumpTypes
-- ^ dump types after typechecking
|
DumpDesugared
-- ^ dump source after desugaring
...
...
@@ -53,117 +88,114 @@ data Dump
|
DumpCase
-- ^ dump IL code after case elimination
deriving
(
Eq
,
Bounded
,
Enum
,
Show
)
-- | Default compiler options
defaultOptions
::
Options
defaultOptions
=
Options
{
help
=
False
,
version
=
False
,
force
=
False
,
html
=
False
,
importPaths
=
[]
,
output
=
Nothing
,
noInterface
=
False
,
noVerb
=
False
,
noWarn
=
False
,
noOverlapWarn
=
False
,
flat
=
False
,
extendedFlat
=
False
,
flatXml
=
False
,
abstract
=
False
,
untypedAbstract
=
False
,
parseOnly
=
False
,
withExtensions
=
False
,
dump
=
[]
,
writeToSubdir
=
True
,
xNoImplicitPrelude
=
False
}
dumpAll
::
[
DumpLevel
]
dumpAll
=
[
minBound
..
maxBound
]
-- |Data type representing language extensions
data
Extension
=
BerndExtension
-- TODO: Give it a more concise name
|
NoImplicitPrelude
|
AnonymousFreeVariables
|
UnknownExtension
String
deriving
(
Eq
,
Read
,
Show
)
classifyExtension
::
String
->
Extension
classifyExtension
str
=
case
readsPrec
0
str
of
[(
e
,
""
)]
->
e
_
->
UnknownExtension
str
-- | All available compiler options
options
::
[
OptDescr
(
Options
->
Options
)]
options
=
-- general
[
Option
"h?"
[
"help"
]
(
NoArg
(
\
opts
->
opts
{
h
elp
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optH
elp
=
True
}))
"display this help and exit"
,
Option
"V"
[
"version"
]
(
NoArg
(
\
opts
->
opts
{
v
ersion
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optV
ersion
=
True
}))
"show the version number"
,
Option
"f"
[
"force"
]
(
NoArg
(
\
opts
->
opts
{
force
=
True
}))
"force compilation of dependent files"
,
Option
""
[
"html"
]
(
NoArg
(
\
opts
->
opts
{
h
tml
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optH
tml
=
True
}))
"generate html code"
,
Option
"v"
[
"verbosity"
]
(
ReqArg
(
\
arg
opts
->
opts
{
optVerbosity
=
classifyVerbosity
arg
})
"<n>"
)
"set verbosity level to <n>"
-- compilation
,
Option
"f"
[
"force"
]
(
NoArg
(
\
opts
->
opts
{
optForce
=
True
}))
"force compilation of dependent files"
,
Option
"i"
[
"import-dir"
]
(
ReqArg
(
\
arg
opts
->
opts
{
i
mportPaths
=
nub
$
arg
:
i
mportPaths
opts
})
"DIR"
)
(
ReqArg
(
\
arg
opts
->
opts
{
optI
mportPaths
=
nub
$
arg
:
optI
mportPaths
opts
})
"DIR"
)
"search for imports in DIR"
,
Option
"o"
[
"output"
]
(
ReqArg
(
\
arg
opts
->
opts
{
output
=
Just
arg
})
"FILE"
)
(
ReqArg
(
\
arg
opts
->
opts
{
o
ptO
utput
=
Just
arg
})
"FILE"
)
"write code to FILE"
,
Option
""
[
"no-subdir"
]
(
NoArg
(
\
opts
->
opts
{
optUseSubdir
=
False
}))
(
"disable writing to '"
++
currySubdir
++
"' subdirectory"
)
,
Option
""
[
"no-intf"
]
(
NoArg
(
\
opts
->
opts
{
n
oInterface
=
Tru
e
}))
(
NoArg
(
\
opts
->
opts
{
o
pt
Interface
=
Fals
e
}))
"do not create an interface file"
,
Option
""
[
"no-verb"
]
(
NoArg
(
\
opts
->
opts
{
noVerb
=
True
}))
"do not print compiler messages"
,
Option
""
[
"no-warn"
]
(
NoArg
(
\
opts
->
opts
{
n
oWarn
=
Tru
e
}))
(
NoArg
(
\
opts
->
opts
{
o
pt
Warn
=
Fals
e
}))
"do not print warnings"
,
Option
""
[
"no-overlap-warn"
]
(
NoArg
(
\
opts
->
opts
{
n
oOverlapWarn
=
Tru
e
}))
(
NoArg
(
\
opts
->
opts
{
o
pt
OverlapWarn
=
Fals
e
}))
"do not print warnings for overlapping rules"
-- target types
,
Option
""
[
"parse-only"
]
(
NoArg
(
\
opts
->
opts
{
optTargetTypes
=
nub
$
Parsed
:
optTargetTypes
opts
}))
"generate source representation"
,
Option
""
[
"flat"
]
(
NoArg
(
\
opts
->
opts
{
flat
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optTargetTypes
=
nub
$
FlatCurry
:
optTargetTypes
opts
}))
"generate FlatCurry code"
,
Option
""
[
"extended-flat"
]
(
NoArg
(
\
opts
->
opts
{
extendedFlat
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optTargetTypes
=
nub
$
ExtendedFlatCurry
:
optTargetTypes
opts
}))
"generate FlatCurry code with source references"
,
Option
""
[
"xml"
]
(
NoArg
(
\
opts
->
opts
{
flatXml
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optTargetTypes
=
nub
$
FlatXml
:
optTargetTypes
opts
}))
"generate flat xml code"
,
Option
""
[
"acy"
]
(
NoArg
(
\
opts
->
opts
{
abstract
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optTargetTypes
=
nub
$
AbstractCurry
:
optTargetTypes
opts
}))
"generate (type infered) AbstractCurry code"
,
Option
""
[
"uacy"
]
(
NoArg
(
\
opts
->
opts
{
untypedAbstract
=
True
}))
(
NoArg
(
\
opts
->
opts
{
optTargetTypes
=
nub
$
UntypedAbstractCurry
:
optTargetTypes
opts
}))
"generate untyped AbstractCurry code"
,
Option
""
[
"parse-only"
]
(
NoArg
(
\
opts
->
opts
{
parseOnly
=
True
}))
"generate source representation"
-- extensions
,
Option
"e"
[
"extended"
]
(
NoArg
(
\
opts
->
opts
{
with
Extensions
=
True
}))
(
NoArg
(
\
opts
->
opts
{
opt
Extensions
=
nub
$
BerndExtension
:
optExtensions
opts
}))
"enable extended Curry functionalities"
,
Option
"X"
[]
(
ReqArg
(
\
arg
opts
->
opts
{
optExtensions
=
nub
$
classifyExtension
arg
:
optExtensions
opts
})
"EXT"
)
(
"enable language extension EXT"
)
-- dump
,
Option
""
[
"dump-all"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
[
minBound
..
maxBound
]
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
dumpAll
}))
"dump everything"
,
Option
""
[
"dump-renamed"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
nub
$
DumpRenamed
:
d
ump
opts
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
nub
$
DumpRenamed
:
optD
ump
s
opts
}))
"dump source code after renaming"
,
Option
""
[
"dump-types"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
nub
$
DumpTypes
:
d
ump
opts
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
nub
$
DumpTypes
:
optD
ump
s
opts
}))
"dump types after type-checking"
,
Option
""
[
"dump-desugared"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
nub
$
DumpDesugared
:
d
ump
opts
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
nub
$
DumpDesugared
:
optD
ump
s
opts
}))
"dump source code after desugaring"
,
Option
""
[
"dump-simplified"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
nub
$
DumpSimplified
:
d
ump
opts
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
nub
$
DumpSimplified
:
optD
ump
s
opts
}))
"dump source code after simplification"
,
Option
""
[
"dump-lifted"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
nub
$
DumpLifted
:
d
ump
opts
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
nub
$
DumpLifted
:
optD
ump
s
opts
}))
"dump source code after lambda-lifting"
,
Option
""
[
"dump-il"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
nub
$
DumpIL
:
d
ump
opts
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
nub
$
DumpIL
:
optD
ump
s
opts
}))
"dump intermediate language before lifting"
,
Option
""
[
"dump-case"
]
(
NoArg
(
\
opts
->
opts
{
d
ump
=
nub
$
DumpCase
:
d
ump
opts
}))
(
NoArg
(
\
opts
->
opts
{
optD
ump
s
=
nub
$
DumpCase
:
optD
ump
s
opts
}))
"dump intermediate language after case simplification"
,
Option
""
[
"no-hidden-subdir"
]
(
NoArg
(
\
opts
->
opts
{
writeToSubdir
=
False
}))
(
"disable writing to hidden '"
++
currySubdir
++
"' subdirectory"
)
,
Option
""
[
"x-no-implicit-prelude"
]
(
NoArg
(
\
opts
->
opts
{
xNoImplicitPrelude
=
True
}))
(
"do not implicitly 'import Prelude'"
)
]
-- |Parse the command line arguments
parseOpts
::
[
String
]
->
(
Options
,
[
String
],
[
String
])
parseOpts
args
=
(
foldl
(
flip
(
$
))
defaultOptions
opts
,
files
,
errs
)
where
(
opts
,
files
,
errs
)
=
getOpt
Permute
options
args
...
...
@@ -171,16 +203,17 @@ parseOpts args = (foldl (flip ($)) defaultOptions opts, files, errs) where
-- |Check options and files and return a list of error messages
checkOpts
::
Options
->
[
String
]
->
[
String
]
checkOpts
opts
files
|
isJust
(
output
opts
)
&&
length
files
>
1
|
isJust
(
o
ptO
utput
opts
)
&&
length
files
>
1
=
[
"cannot specify -o with multiple targets"
]
|
otherwise
=
[]
-- |Print the usage information of the command line tool.
usage
::
String
->
String
usage
prog
=
usageInfo
header
options
where
header
=
"usage: "
++
prog
++
" [OPTION] ... MODULE ..."
-- |Retrieve the compiler 'Options'
compilerOpts
::
IO
(
String
,
Options
,
[
String
],
[
String
])
compilerOpts
=
do
args
<-
getArgs
...
...
src/CurryBuilder.hs
View file @
fd408993
...
...
@@ -3,6 +3,7 @@
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
CurryBuilder
(
buildCurry
,
smake
)
where
...
...
@@ -15,7 +16,7 @@ import Curry.Files.Filenames
import
Curry.Files.PathUtils
(
dropExtension
,
doesModuleExist
,
getCurryPath
,
getModuleModTime
,
tryGetModuleModTime
)
import
Curry
CompilerOpts
(
Options
(
..
))
import
CompilerOpts
(
Options
(
..
),
Extension
(
..
),
TargetType
(
..
))
import
CurryDeps
(
Source
(
..
),
flatDeps
)
import
Messages
(
status
,
abortWith
)
import
Modules
(
compileModule
)
...
...
@@ -32,11 +33,14 @@ buildCurry opts file = do
Just
f
->
do
(
deps
,
errs
)
<-
flatDeps
implicitPrelude
paths
[]
f
unless
(
null
errs
)
(
abortWith
errs
)
makeCurry
opts
deps
f
makeCurry
(
defaultToFlatCurry
opts
)
deps
f
where
paths
=
i
mportPaths
opts
implicitPrelude
=
not
$
x
NoImplicitPrelude
opts
paths
=
optI
mportPaths
opts
implicitPrelude
=
NoImplicitPrelude
`
notElem
`
optExtensions
opts
missingModule
f
=
"Error: missing module
\"
"
++
f
++
"
\"
"
defaultToFlatCurry
opt
|
null
$
optTargetTypes
opt
=
opt
{
optTargetTypes
=
[
FlatCurry
]
}
|
otherwise
=
opt
makeCurry
::
Options
->
[(
ModuleIdent
,
Source
)]
->
FilePath
->
IO
()
makeCurry
opts
deps1
targetFile
=
mapM_
(
compile
.
snd
)
deps1
where
...
...
@@ -47,7 +51,7 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
-- target file
|
dropExtension
targetFile
==
dropExtension
file
=
do
flatIntfExists
<-
doesModuleExist
(
flatIntName
file
)
if
flatIntfExists
&&
not
(
f
orce
opts
)
&&
null
(
d
ump
opts
)
if
flatIntfExists
&&
not
(
optF
orce
opts
)
&&
null
(
optD
ump
s
opts
)
then
smake
(
targetNames
file
)
(
targetFile
:
(
catMaybes
(
map
flatInterface
mods
)))
(
generateFile
file
)
...
...
@@ -73,11 +77,12 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
compileModule
(
compOpts
False
)
f
>>
return
()
targetNames
fn
|
flat
opts
=
[
flatName'
opts
fn
]
-- , flatIntName fn]
|
flatXml
opts
=
[
xmlName
fn
]
|
abstract
opts
=
[
acyName
fn
]
|
untypedAbstract
opts
=
[
uacyName
fn
]
|
parseOnly
opts
=
[
fromMaybe
(
sourceRepName
fn
)
(
output
opts
)]
|
FlatCurry
`
elem
`
optTargetTypes
opts
=
[
flatName'
opts
fn
]
-- , flatIntName fn]
|
FlatXml
`
elem
`
optTargetTypes
opts
=
[
xmlName
fn
]
|
AbstractCurry
`
elem
`
optTargetTypes
opts
=
[
acyName
fn
]
|
UntypedAbstractCurry
`
elem
`
optTargetTypes
opts
=
[
uacyName
fn
]
|
Parsed
`
elem
`
optTargetTypes
opts
=
[
fromMaybe
(
sourceRepName
fn
)
(
optOutput
opts
)]
|
otherwise
=
[
flatName'
opts
fn
]
-- , flatIntName fn]
flatInterface
mod1
=
case
(
lookup
mod1
deps1
)
of
...
...
@@ -86,18 +91,13 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
_
->
Nothing
compOpts
isImport
|
isImport
=
opts
{
flat
=
True
,
flatXml
=
False
,
abstract
=
False
,
untypedAbstract
=
False
,
parseOnly
=
False
,
dump
=
[]
}
|
isImport
=
opts
{
optTargetTypes
=
[
FlatCurry
],
optDumps
=
[]
}
|
otherwise
=
opts
flatName'
::
Options
->
FilePath
->
FilePath
flatName'
opts
=
if
extendedFlat
opts
then
extFlatName
else
flatName
flatName'
opts
|
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
=
extFlatName
|
otherwise
=
flatName
{- |A simple make function
...
...
@@ -118,30 +118,18 @@ smake dests deps cmd alt = do
|
outOfDate
destTimes
depTimes
=
cmd
|
otherwise
=
alt
abortOnError
::
IO
a
->
IO
a
abortOnError
act
=
catch
act
(
\
err
->
abortWith
[
show
err
])
--
getDestTimes
::
[
FilePath
]
->
IO
[
ClockTime
]
getDestTimes
=
liftM
catMaybes
.
mapM
tryGetModuleModTime
-- getDestTimes [] = return []
-- getDestTimes (file:files) = catch
-- (do time <- getModuleModTime file
-- times <- getDestTimes files
-- return (time:times))
-- (const (getDestTimes files))
--
getDepTimes
::
[
String
]
->
IO
[
ClockTime
]
getDepTimes
=
mapM
(
abortOnError
.
getModuleModTime
)
-- getDepTimes [] = return []
-- getDepTimes (file:files) = catch
-- (do time <- getModuleModTime file
-- times <- getDepTimes files
-- return (time:times))
-- (\err -> abortWith [show err])
--
outOfDate
::
[
ClockTime
]
->
[
ClockTime
]
->
Bool
outOfDate
tgtimes
dptimes
=
or
[
tg
<
dp
|
tg
<-
tgtimes
,
dp
<-
dptimes
]
-- outOfDate tgtimes dptimes = or (map (\t -> or (map ((<) t) dptimes)) tgtimes)
abortOnError
::
IO
a
->
IO
a
abortOnError
act
=
catch
act
(
\
err
->
abortWith
[
show
err
])
src/Frontend.hs
View file @
fd408993
...
...
@@ -16,10 +16,10 @@ import Curry.Files.Filenames
import
Curry.Files.PathUtils
import
qualified
Curry.Syntax
as
CS
(
Module
(
..
),
Decl
(
..
),
parseModule
)
import
CompilerOpts
(
Options
(
..
),
Verbosity
(
..
),
TargetType
(
..
),
defaultOptions
)
import
Modules
(
checkModule
,
simpleCheckModule
,
compileModule
,
importPrelude
,
patchModuleId
,
loadInterfaces
)
import
CurryBuilder
(
smake
)
import
CurryCompilerOpts
(
Options
(
..
),
defaultOptions
)
import
CurryDeps
(
flattenDeps
,
moduleDeps
,
Source
(
..
))
import
Base.Module
(
ModuleEnv
)
...
...
@@ -102,8 +102,8 @@ makeInterfaces paths (CS.Module mid _ decls) = do
opts
::
[
FilePath
]
->
Options
opts
paths
=
defaultOptions
{
i
mportPaths
=
paths
,
n
oVerb
=
True
,
n
oWarn
=
Tru
e
,
abstract
=
True
{
optI
mportPaths
=
paths
,
o
pt
Verb
osity
=
Quiet
,
o
pt
Warn
=
Fals
e
,
optTargetTypes
=
[
AbstractCurry
]
}
src/Gen/GenFlatCurry.hs
View file @
fd408993
...
...
@@ -10,7 +10,7 @@
module
Gen.GenFlatCurry
(
genFlatCurry
,
genFlatInterface
)
where
-- Haskell libraries
import
Control.Monad
(
filterM
,
liftM
,
mplus
,
unless
)
import
Control.Monad
(
filterM
,
liftM
,
mplus
,
when
)
import
Control.Monad.State
(
State
,
runState
,
gets
,
modify
)
import
Data.List
(
nub
)
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
,
fromList
,
toList
)
...
...
@@ -29,7 +29,7 @@ import Base.Module (ModuleEnv)
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
import
Curry
CompilerOpts
(
Options
(
..
))
import
CompilerOpts
(
Options
(
..
))
import
qualified
CurryToIL
as
IL
import
Env.TopEnv
(
topEnvMap
)
import
Env.CurryEnv
(
CurryEnv
)
...
...
@@ -804,18 +804,17 @@ flattenRecordTypeFields
--
checkOverlapping
::
Expr
->
Expr
->
FlatState
()
checkOverlapping
expr1
expr2
=
do
opts
<-
compilerOpts
unless
(
noOverlapWarn
opts
)
(
checkOverlap
expr1
expr2
)
where
checkOverlap
(
Case
_
_
_
_
)
_
=
do
qid
<-
functionId
genWarning
(
overlappingRules
qid
)
checkOverlap
_
(
Case
_
_
_
_
)
=
do
qid
<-
functionId
genWarning
(
overlappingRules
qid
)
checkOverlap
_
_
=
return
()
checkOverlapping
expr1
expr2
=
do
opts
<-
compilerOpts
when
(
optOverlapWarn
opts
)
$
checkOverlap
expr1
expr2
where
checkOverlap
(
Case
_
_
_
_
)
_
=
do
qid
<-
functionId
genWarning
(
overlappingRules
qid
)
checkOverlap
_
(
Case
_
_
_
_
)
=
do
qid
<-
functionId
genWarning
(
overlappingRules
qid
)
checkOverlap
_
_
=
return
()
-------------------------------------------------------------------------------
...
...
src/Html/CurryHtml.hs
View file @
fd408993
...
...
@@ -9,7 +9,7 @@ import Curry.Files.PathUtils
(
readModule
,
writeModule
,
getCurryPath
,
dropExtension
,
takeFileName
)
import
Curry.Syntax
(
lexFile
)
import
Curry
CompilerOpts
(
Options
(
..
))
import
CompilerOpts
(
Options
(
..
))
import
Frontend
(
parse
,
typingParse
,
fullParse
)
import
Html.SyntaxColoring
...
...
@@ -18,8 +18,8 @@ import Html.SyntaxColoring
--- @param sourcefilename
source2html
::
Options
->
String
->
IO
()
source2html
opts
sourcefilename
=
do
let
imports
=
i
mportPaths
opts
outputfilename
=
fromMaybe
""
$
output
opts
let
imports
=
optI
mportPaths
opts
outputfilename
=
fromMaybe
""
$
o
ptO
utput
opts
sourceprogname
=
dropExtension
sourcefilename
output'
=
if
null
outputfilename
then
sourceprogname
++
"_curry.html"
...
...
src/Messages.hs
View file @
fd408993
...
...
@@ -10,10 +10,10 @@ import System.Exit (ExitCode (..), exitWith)
import
Curry.Base.Position
(
Position
)
import
Curry
CompilerOpts
(
Options
(
n
oVerb
))
import
CompilerOpts
(
Options
(
o
pt
Verb
osity
),
Verbosity
(
..
))
info
::
Options
->
String
->
IO
()
info
opts
msg
=
unless
(
n
oVerb
opts
)
(
putStrLn
msg
)
info
opts
msg
=
unless
(
o
pt
Verb
osity
opts
==
Quiet
)
(
putStrLn
msg
)
status
::
Options
->
String
->
IO
()
status
opts
msg
=
info
opts
(
msg
++
" ..."
)
...
...
src/Modules.lhs
View file @
fd408993
...
...
@@ -61,7 +61,8 @@ This module controls the compilation of modules.
>
import
Transform.Qual
(
qual
)
>
import
Transform.Simplify
(
simplify
)
>
import
CurryCompilerOpts
(
Options
(
..
),
Dump
(
..
))
>
import
CompilerOpts
(
Options
(
..
),
TargetType
(
..
),
Extension
(
..
)
>
,
DumpLevel
(
..
))
>
import
CurryToIL
(
ilTrans
)
>
import
Exports
(
expandInterface
,
exportInterface
)
>
import
Imports
(
importInterface
,
importInterfaceIntf
,
importUnifyData
)
...
...
@@ -102,7 +103,7 @@ code are obsolete and commented out.
>
-- check whether module identifier and file name fit together
>
checkModuleId
fn
m
>
-- load the imported interfaces into a 'ModuleEnv'
>
mEnv
<-
loadInterfaces
(
i
mportPaths
opts
)
m
>
mEnv
<-
loadInterfaces
(
optI
mportPaths
opts
)
m
>
if
uacy
||
src
>
then
do
>
(
tyEnv
,
tcEnv
,
_
,
m'
,
_
,
_
)
<-
simpleCheckModule
opts
mEnv
m
...
...
@@ -111,9 +112,9 @@ code are obsolete and commented out.
>
then
genAbstract
opts
fn
tyEnv
tcEnv
m'
>
-- just output the parsed source
>
else
do
>
let
outputFile
=
fromMaybe
(
sourceRepName
fn
)
(
output
opts
)
>
let
outputFile
=
fromMaybe
(
sourceRepName
fn
)
(
o
ptO
utput
opts
)
>
outputMod
=
showModule
m'
>
writeModule
(
writeTo
Subdir
opts
)
outputFile
outputMod
>
writeModule
(
optUse
Subdir
opts
)
outputFile
outputMod
>
return
Nothing
>
else
do
>
-- checkModule checks types, and then transModule introduces new
...
...
@@ -124,12 +125,12 @@ code are obsolete and commented out.
>
mEnv
tyEnv
tcEnv
aEnv
m'
>
mapM_
(
doDump
opts
)
dumps
>
genCode
opts
fn
mEnv
tyEnv
tcEnv
aEnv'
intf
m'
il
>
where
acy
=
a
bstract
opts
>
uacy
=
u
ntypedAbstract
opts
>
fcy
=
f
lat
opts
>
xml
=
f
latXml
opts
>
src
=
p
arse
Only
opts
>
likeFlat
=
f
cy
||
xml
||
a
cy
||
uacy
||
src
>
where
acy
=
A
bstract
Curry
`
elem
`
optTargetTypes
opts
>
uacy
=
U
ntypedAbstract
Curry
`
elem
`
optTargetTypes
opts
>
fcy
=
F
lat
Curry
`
elem
`
optTargetTypes
opts
>
xml
=
F
latXml
`
elem
`
optTargetTypes
opts
>
src
=
P
arse
d
`
elem
`
optTargetTypes
opts
>
likeFlat
=
a
cy
||
uacy
||
f
cy
||
xml
||
src
>
>
genCode
opts'
fn'
mEnv
tyEnv
tcEnv
aEnv
intf
m'
il
>
|
fcy
||
xml
=
genFlat
opts'
fn'
mEnv
tyEnv
tcEnv
aEnv
intf
m'
il
...
...
@@ -168,15 +169,17 @@ only a qualified import is added.
>
importPrelude
::
Options
->
FilePath
->
Module
->
Module
>
importPrelude
opts
fn
(
Module
m
es
ds
)
>
|
m
==
preludeMIdent
=
Module
m
es
ds
>
|
xNoImplicitPrelude
opts
=
Module
m
es
ds
>
|
otherwise
=
Module
m
es
ds'
>
where
ids
=
[
decl
|
decl
@
(
ImportDecl
_
_
_
_
_
)
<-
ds
]
>
ds'
=
ImportDecl
(
first
fn
)
preludeMIdent
>
(
preludeMIdent
`
elem
`
map
importedModule
ids
)
>
Nothing
Nothing
:
ds
>
importedModule
(
ImportDecl
_
m'
_
asM
_
)
=
fromMaybe
m'
asM
>
importedModule
_
=
error
"Modules.importPrelude.importedModule: no pattern match"
>
|
m
==
preludeMIdent
=
Module
m
es
ds
>
|
noImpPrelude
=
Module
m
es
ds