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
6387b29b
Commit
6387b29b
authored
Apr 16, 2014
by
Björn Peemöller
Browse files
Improved CurryBuilder
* Code refactoring * Extended status output
parent
2ea95c75
Changes
2
Hide whitespace changes
Inline
Side-by-side
src/Base/Messages.hs
View file @
6387b29b
...
...
@@ -45,7 +45,7 @@ warn opts msgs = when (wnWarn opts && not (null msgs)) $ do
-- |Print a message on 'stdout'
putMsg
::
MonadIO
m
=>
String
->
m
()
putMsg
msg
=
liftIO
$
putStrLn
$
msg
++
" ..."
putMsg
=
liftIO
.
putStrLn
-- |Print an error message on 'stderr'
putErrLn
::
MonadIO
m
=>
String
->
m
()
...
...
src/CurryBuilder.hs
View file @
6387b29b
...
...
@@ -3,7 +3,7 @@
Description : Build tool for compiling multiple Curry modules
Copyright : (c) 2005 Martin Engelke
2007 Sebastian Fischer
2011 - 201
3
Björn Peemöller
2011 - 201
4
Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -32,16 +32,15 @@ import CurryDeps (Source (..), flatDeps)
import
Modules
(
compileModule
)
-- |Compile the Curry module in the given source file including all imported
-- modules
, depending on the
'Options'.
-- modules
w.r.t. the given
'Options'.
buildCurry
::
Options
->
String
->
CYIO
()
buildCurry
opts
s
=
do
fn
<-
findCurry
opts
s
src
s
<-
flatDeps
opts
fn
makeCurry
(
defaultToFlatCurry
opts
)
srcs
fn
dep
s
<-
flatDeps
opts
fn
makeCurry
opts'
deps
where
defaultToFlatCurry
opt
|
null
$
optTargetTypes
opt
=
opt
{
optTargetTypes
=
[
FlatCurry
]
}
|
otherwise
=
opt
opts'
|
null
$
optTargetTypes
opts
=
opts
{
optTargetTypes
=
[
FlatCurry
]
}
|
otherwise
=
opts
-- |Search for a compilation target identified by the given 'String'.
findCurry
::
Options
->
String
->
CYIO
FilePath
...
...
@@ -72,65 +71,73 @@ findCurry opts s = do
Nothing
->
second
justFn
->
return
justFn
-- |Compiles the given source modules, which must be in topological order
makeCurry
::
Options
->
[(
ModuleIdent
,
Source
)]
->
FilePath
->
CYIO
()
makeCurry
opts
srcs
targetFile
=
mapM_
(
process
.
snd
)
srcs
-- |Compiles the given source modules, which must be in topological order
.
makeCurry
::
Options
->
[(
ModuleIdent
,
Source
)]
->
CYIO
()
makeCurry
opts
srcs
=
mapM_
process
'
(
zip
[
1
..
]
srcs
)
where
process
::
Source
->
CYIO
()
process
(
Source
fn
deps
)
=
do
let
isFinalFile
=
dropExtension
targetFile
==
dropExtension
fn
isDump
=
not
$
null
$
dbDumpLevels
$
optDebugOpts
opts
isEnforced
=
optForce
opts
||
isDump
destFiles
=
if
isFinalFile
then
destNames
fn
else
[
getFlatName
fn
]
depFiles
=
fn
:
mapMaybe
curryInterface
deps
actOutdated
=
if
isFinalFile
then
compileFinal
else
compile
actUpToDate
=
if
isFinalFile
then
skipFinal
else
skip
interfaceExists
<-
liftIO
$
doesModuleExist
$
interfName
fn
if
interfaceExists
&&
not
(
isEnforced
&&
isFinalFile
)
then
smake
destFiles
depFiles
(
actOutdated
fn
)
(
actUpToDate
fn
)
else
actOutdated
fn
process
_
=
return
()
compileFinal
f
=
do
status
opts
$
"generating "
++
(
normalise
$
head
$
destNames
f
)
compileModule
opts
f
compile
f
=
do
status
opts
$
"compiling "
++
normalise
f
compileModule
(
opts
{
optTargetTypes
=
[
FlatCurry
]
,
optDebugOpts
=
defaultDebugOpts
})
f
skipFinal
f
=
status
opts
$
"skipping "
++
normalise
f
skip
f
=
info
opts
$
"skipping "
++
normalise
f
destNames
fn
=
[
gen
fn
|
(
tgt
,
gen
)
<-
nameGens
,
tgt
`
elem
`
optTargetTypes
opts
]
where
nameGens
=
[
(
FlatCurry
,
flatName
)
,
(
ExtendedFlatCurry
,
extFlatName
)
,
(
FlatXml
,
xmlName
)
,
(
AbstractCurry
,
acyName
)
,
(
UntypedAbstractCurry
,
uacyName
)
,
(
Parsed
,
sourceRepName
)
]
curryInterface
m
=
case
lookup
m
srcs
of
Just
(
Source
fn
_
)
->
Just
$
interfName
fn
Just
(
Interface
fn
)
->
Just
$
interfName
fn
_
->
Nothing
getFlatName
=
if
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
then
extFlatName
else
flatName
total
=
length
srcs
process'
::
(
Int
,
(
ModuleIdent
,
Source
))
->
CYIO
()
process'
(
n
,
(
m
,
Source
fn
is
))
=
process
opts'
(
n
,
total
)
m
fn
deps
where
opts'
|
n
==
total
=
opts
{
optForce
=
optForce
opts
||
isDump
}
|
otherwise
=
opts
{
optTargetTypes
=
[
flatTarget
]
,
optForce
=
False
,
optDebugOpts
=
defaultDebugOpts
}
isDump
=
not
$
null
$
dbDumpLevels
$
optDebugOpts
opts
flatTarget
=
if
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
then
ExtendedFlatCurry
else
FlatCurry
deps
=
fn
:
mapMaybe
curryInterface
is
curryInterface
i
=
case
lookup
i
srcs
of
Just
(
Source
fn'
_
)
->
Just
$
interfName
fn'
Just
(
Interface
fn'
)
->
Just
$
interfName
fn'
_
->
Nothing
process'
_
=
return
()
-- |Compile a single source module.
process
::
Options
->
(
Int
,
Int
)
->
ModuleIdent
->
FilePath
->
[
FilePath
]
->
CYIO
()
process
opts
idx
m
fn
deps
|
optForce
opts
=
compile
|
otherwise
=
smake
(
interfName
fn
:
destFiles
)
deps
compile
skip
where
skip
=
status
opts
$
compMessage
idx
"Skipping"
m
(
fn
,
head
destFiles
)
compile
=
do
status
opts
$
compMessage
idx
"Compiling"
m
(
fn
,
head
destFiles
)
compileModule
opts
fn
destFiles
=
[
addCurrySubdir
(
optUseSubdir
opts
)
(
gen
fn
)
|
(
tgt
,
gen
)
<-
nameGens
,
tgt
`
elem
`
optTargetTypes
opts
]
nameGens
=
[
(
FlatCurry
,
flatName
)
,
(
ExtendedFlatCurry
,
extFlatName
)
,
(
FlatXml
,
xmlName
)
,
(
AbstractCurry
,
acyName
)
,
(
UntypedAbstractCurry
,
uacyName
)
,
(
Parsed
,
sourceRepName
)
]
-- |Create a status message like
-- @[m of n] Compiling Module ( M.curry, .curry/M.fcy )@
compMessage
::
(
Int
,
Int
)
->
String
->
ModuleIdent
->
(
FilePath
,
FilePath
)
->
String
compMessage
(
curNum
,
maxNum
)
what
m
(
src
,
dst
)
=
'['
:
lpad
(
length
sMaxNum
)
(
show
curNum
)
++
" of "
++
sMaxNum
++
"]"
++
' '
:
rpad
9
what
++
' '
:
rpad
16
(
show
m
)
++
" ( "
++
normalise
src
++
", "
++
normalise
dst
++
" )"
where
sMaxNum
=
show
maxNum
lpad
n
s
=
replicate
(
n
-
length
s
)
' '
++
s
rpad
n
s
=
s
++
replicate
(
n
-
length
s
)
' '
-- |A simple make function
smake
::
[
FilePath
]
-- ^ destination files
->
[
FilePath
]
-- ^ dependency files
->
CYIO
a
-- ^ action to perform if depedency files are newer
->
CYIO
a
-- ^ action to perform if destination files are newer
->
CYIO
a
-- ^ action to perform if depedency files are newer
->
CYIO
a
-- ^ action to perform if destination files are newer
->
CYIO
a
smake
dests
deps
actOutdated
actUpToDate
=
do
destTimes
<-
catMaybes
`
liftM
`
mapM
(
liftIO
.
getModuleModTime
)
dests
...
...
Write
Preview
Markdown
is supported
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