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
a6d58b10
Commit
a6d58b10
authored
Sep 24, 2012
by
Björn Peemöller
Browse files
Warnings improved
parent
b5a5bf65
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/Base/Messages.hs
View file @
a6d58b10
module
Base.Messages
(
-- * Output of user information
info
,
status
,
putErrLn
,
putErrsLn
info
,
status
,
warn
,
putErrLn
,
putErrsLn
-- * program abortion
,
abortWith
,
abortWithMessage
,
abortWithMessages
,
internalError
,
errorMessage
,
errorMessages
...
...
@@ -8,14 +8,14 @@ module Base.Messages
,
Message
,
message
,
posMessage
)
where
import
Control.Monad
(
unless
)
import
Control.Monad
(
unless
,
when
)
import
System.IO
(
hPutStrLn
,
stderr
)
import
System.Exit
(
exitFailure
)
import
Curry.Base.Message
(
Message
,
message
,
posMessage
,
ppMessage
,
ppMessages
)
import
CompilerOpts
(
Options
(
optVerbosity
),
Verbosity
(
..
))
import
CompilerOpts
(
Options
(
optVerbosity
,
optWarn
),
Verbosity
(
..
))
info
::
Options
->
String
->
IO
()
info
opts
msg
=
unless
(
optVerbosity
opts
<
VerbInfo
)
...
...
@@ -25,6 +25,9 @@ status :: Options -> String -> IO ()
status
opts
msg
=
unless
(
optVerbosity
opts
<
VerbStatus
)
(
putStrLn
$
msg
++
" ..."
)
warn
::
Options
->
[
Message
]
->
IO
()
warn
opts
msgs
=
when
(
optWarn
opts
)
$
putErrLn
(
show
$
ppMessages
msgs
)
-- |Print an error message on 'stderr'
putErrLn
::
String
->
IO
()
putErrLn
=
hPutStrLn
stderr
...
...
src/Generators/GenFlatCurry.hs
View file @
a6d58b10
...
...
@@ -134,7 +134,7 @@ data IdentExport
-- Runs a 'FlatState' action and returns the result
run
::
Options
->
ModuleSummary
.
ModuleSummary
->
InterfaceEnv
->
ValueEnv
->
TCEnv
->
Bool
->
FlatState
a
->
(
a
,
[
Message
])
run
opts
modSum
mEnv
tyEnv
tcEnv
genIntf
f
=
(
result
,
messagesE
env
)
run
opts
modSum
mEnv
tyEnv
tcEnv
genIntf
f
=
(
result
,
reverse
$
messagesE
env
)
where
(
result
,
env
)
=
runState
f
env0
env0
=
FlatEnv
...
...
src/Modules.hs
View file @
a6d58b10
...
...
@@ -22,14 +22,15 @@ import Control.Monad (unless, when)
import
Data.Maybe
(
fromMaybe
)
import
Text.PrettyPrint
import
Curry.Base.Message
import
Curry.Base.Position
import
Curry.Base.Ident
import
Curry.Base.Message
(
runMsg
)
import
Curry.Base.Position
import
Curry.ExtendedFlat.InterfaceEquality
(
eqInterface
)
import
Curry.Files.Filenames
import
Curry.Files.PathUtils
import
Base.Messages
(
abortWith
,
abortWithMessages
,
putErrsLn
)
import
Base.Messages
(
Message
,
message
,
posMessage
,
warn
,
abortWithMessages
)
-- source representations
import
qualified
Curry.AbstractCurry
as
AC
...
...
@@ -75,7 +76,7 @@ compileModule opts fn = do
case
checkModule
opts
loaded
of
CheckFailed
errs
->
abortWithMessages
errs
CheckSuccess
(
env
,
mdl
,
dumps
)
->
do
showWarnings
opts
$
warnCheck
env
mdl
warn
opts
$
warnCheck
env
mdl
mapM_
(
doDump
opts
)
dumps
writeOutput
opts
fn
(
env
,
mdl
)
...
...
@@ -107,7 +108,7 @@ loadModule opts fn = do
-- read module
mbSrc
<-
readModule
fn
case
mbSrc
of
Nothing
->
abortWith
[
"Missing file: "
++
fn
]
-- TODO
Nothing
->
abortWith
Messages
[
message
$
text
$
"Missing file: "
++
fn
]
-- TODO
Just
src
->
do
-- parse module
case
runMsg
$
CS
.
parseModule
True
fn
src
of
...
...
@@ -251,7 +252,7 @@ writeFlat opts fn env modSum il = do
writeFlatCurry
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
->
IL
.
Module
->
IO
()
writeFlatCurry
opts
fn
env
modSum
il
=
do
showWarnings
opts
msgs
warn
opts
msgs
when
extTarget
$
EF
.
writeExtendedFlat
useSubDir
(
extFlatName
fn
)
prog
when
fcyTarget
$
EF
.
writeFlatCurry
useSubDir
(
flatName
fn
)
prog
where
...
...
@@ -282,7 +283,7 @@ writeInterface opts fn env modSum il
emptyIntf
=
EF
.
Prog
""
[]
[]
[]
[]
(
newInterface
,
intMsgs
)
=
genFlatInterface
opts
modSum
env
il
outputInterface
=
do
showWarnings
opts
intMsgs
warn
opts
intMsgs
EF
.
writeFlatCurry
(
optUseSubdir
opts
)
targetFile
newInterface
writeAbstractCurry
::
Options
->
FilePath
->
CompilerEnv
->
CS
.
Module
->
IO
()
...
...
@@ -296,10 +297,6 @@ writeAbstractCurry opts fname env modul = do
uacyTarget
=
UntypedAbstractCurry
`
elem
`
optTargetTypes
opts
useSubDir
=
optUseSubdir
opts
showWarnings
::
Options
->
[
Message
]
->
IO
()
showWarnings
opts
msgs
=
when
(
optWarn
opts
)
$
putErrsLn
$
map
showWarning
msgs
-- |The 'dump' function writes the selected information to standard output.
doDump
::
Options
->
Dump
->
IO
()
doDump
opts
(
level
,
env
,
dump
)
=
when
(
level
`
elem
`
optDumps
opts
)
$
do
...
...
src/Transformations/CurryToIL.lhs
View file @
a6d58b10
...
...
@@ -259,7 +259,7 @@ uses flexible matching.
>
flat
<-
isFlat
>
let
vs
=
if
not
flat
&&
isFpSelectorId
f
then
trArgs
eqs
funVars
else
funVars
>
alts
<-
mapM
(
trEquation
vs
addVars
)
eqs
>
let
expr
=
m
atch
(
srcRefOf
p
)
IL
.
Flex
vs
alts
>
let
expr
=
flexM
atch
(
srcRefOf
p
)
vs
alts
>
return
$
IL
.
FunctionDecl
f'
vs
ty'
expr
>
where
>
-- funVars are the variables needed for the function: _1, _2, etc.
...
...
@@ -347,11 +347,12 @@ instance, if one of the alternatives contains an \texttt{@}-pattern.
>
trBinding
(
PatternDecl
_
(
VariablePattern
v
)
rhs
)
>
=
IL
.
Binding
v
`
liftM
`
trRhs
vs
env'
rhs
>
trBinding
p
=
error
$
"unexpected binding: "
++
show
p
>
trExpr
(
v
:
vs
)
env
(
Case
r
_
e
alts
)
=
do
>
trExpr
(
v
:
vs
)
env
(
Case
r
ct
e
alts
)
=
do
>
-- the ident v is used for the case expression subject, as this could
>
-- be referenced in the case alternatives by a variable pattern
>
e'
<-
trExpr
vs
env
e
>
expr
<-
caseMatch
r
IL
.
Rigid
[
v
]
`
liftM
`
mapM
(
trAlt
vs
env
)
alts
>
let
matcher
=
if
ct
==
Flex
then
flexMatch
else
rigidMatch
>
expr
<-
matcher
r
[
v
]
`
liftM
`
mapM
(
trAlt
vs
env
)
alts
>
return
$
case
expr
of
>
IL
.
Case
r'
mode
(
IL
.
Variable
v'
)
alts'
>
-- subject is not referenced -> forget v and insert subject
...
...
@@ -422,80 +423,78 @@ hand sides of the remaining rules, eventually combining them using
\texttt{or} expressions.
Actually, the algorithm below combines the search for inductive and
demanded positions. The function \texttt{
m
atch} scans the argument
demanded positions. The function \texttt{
flexM
atch} scans the argument
lists for the left-most demanded position. If this turns out to be
also an inductive position, the function \texttt{matchInductive} is
called in order to generate a \texttt{case} expression. Otherwise, the
function \texttt{optMatch} is called that tries to find an inductive
function \texttt{opt
Flex
Match} is called that tries to find an inductive
position in the remaining arguments. If one is found,
\texttt{matchInductive} is called, otherwise the function
\texttt{optMatch} uses the demanded argument position found by
\texttt{opt
Flex
Match} uses the demanded argument position found by
\texttt{match}.
\begin{verbatim}
>
type
Match
=
([
NestedTerm
],
IL
.
Expression
)
>
type
Match'
=
([
NestedTerm
]
->
[
NestedTerm
],
[
NestedTerm
],
IL
.
Expression
)
>
match
::
SrcRef
-- source reference
>
->
IL
.
Eval
-- evaluation mode (flex)
>
->
[
Ident
]
-- new function variables
>
->
[
Match
]
-- translated equations, list of: nested pattern+RHS
>
->
IL
.
Expression
-- result expression
>
match
_
_
[]
alts
=
foldl1
IL
.
Or
(
map
snd
alts
)
>
match
r
ev
(
v
:
vs
)
alts
>
flexMatch
::
SrcRef
-- source reference
>
->
[
Ident
]
-- new function variables
>
->
[
Match
]
-- translated equations, list of: nested pattern+RHS
>
->
IL
.
Expression
-- result expression
>
flexMatch
_
[]
alts
=
foldl1
IL
.
Or
(
map
snd
alts
)
>
flexMatch
r
(
v
:
vs
)
alts
>
|
isInductive
=
e1
>
|
notDemanded
=
e2
>
|
otherwise
=
optMatch
r
ev
(
IL
.
Or
e1
e2
)
(
v
:
)
vs
(
map
skipArg
alts
)
>
|
otherwise
=
opt
Flex
Match
r
(
IL
.
Or
e1
e2
)
(
v
:
)
vs
(
map
skipArg
alts
)
>
where
>
isInductive
=
null
vars
>
notDemanded
=
null
nonVars
>
-- seperate variable and inductive patterns
>
(
vars
,
nonVars
)
=
partition
isVarMatch
(
map
tagAlt
alts
)
>
e1
=
m
atchInductive
r
ev
id
v
vs
(
map
prep
nonVars
)
>
e1
=
flexM
atchInductive
r
id
v
vs
(
map
prep
nonVars
)
>
-- match next variables
>
e2
=
m
atch
r
ev
vs
(
map
snd
vars
)
>
e2
=
flexM
atch
r
vs
(
map
snd
vars
)
>
prep
(
p
,(
ts
,
e
))
=
(
p
,
(
id
,
ts
,
e
))
>
-- tagAlt extracts the constructor of the first pattern
>
tagAlt
(
t
:
ts
,
e
)
=
(
pattern
t
,
(
arguments
t
++
ts
,
e
))
>
tagAlt
(
[]
,
_
)
=
error
"CurryToIL.
m
atch.tagAlt: empty list"
>
tagAlt
(
[]
,
_
)
=
error
"CurryToIL.
flexM
atch.tagAlt: empty list"
>
-- skipArg skips the current argument for later matching
>
skipArg
(
t
:
ts
,
e
)
=
((
t
:
),
ts
,
e
)
>
skipArg
(
[]
,
_
)
=
error
"CurryToIL.match.skipArg: empty list"
>
optMatch
::
SrcRef
-- source reference
>
->
IL
.
Eval
-- evaluation mode (flex)
>
->
IL
.
Expression
-- default expression
>
->
([
Ident
]
->
[
Ident
])
-- variables to be matched next
>
->
[
Ident
]
-- variables to be matched afterwards
>
->
[
Match'
]
-- translated equations, list of: nested pattern+RHS
>
->
IL
.
Expression
>
skipArg
(
[]
,
_
)
=
error
"CurryToIL.flexMatch.skipArg: empty list"
>
optFlexMatch
::
SrcRef
-- source reference
>
->
IL
.
Expression
-- default expression
>
->
([
Ident
]
->
[
Ident
])
-- variables to be matched next
>
->
[
Ident
]
-- variables to be matched afterwards
>
->
[
Match'
]
-- translated equations, list of: nested pattern+RHS
>
->
IL
.
Expression
>
-- if there are no variables left: return the default expression
>
optMatch
_
_
def
_
[]
_
=
def
>
optMatch
r
ev
def
prefix
(
v
:
vs
)
alts
>
|
isInductive
=
m
atchInductive
r
ev
prefix
v
vs
alts'
>
|
otherwise
=
optMatch
r
ev
def
(
prefix
.
(
v
:
))
vs
(
map
skipArg
alts
)
>
opt
Flex
Match
_
def
_
[]
_
=
def
>
opt
Flex
Match
r
def
prefix
(
v
:
vs
)
alts
>
|
isInductive
=
flexM
atchInductive
r
prefix
v
vs
alts'
>
|
otherwise
=
opt
Flex
Match
r
def
(
prefix
.
(
v
:
))
vs
(
map
skipArg
alts
)
>
where
>
isInductive
=
not
(
any
isVarMatch
alts'
)
>
alts'
=
map
tagAlt
alts
>
-- tagAlt extracts the next pattern and reinserts the skipped ones
>
tagAlt
(
pref
,
t
:
ts
,
e'
)
=
(
pattern
t
,
(
pref
,
arguments
t
++
ts
,
e'
))
>
tagAlt
(
_
,
[]
,
_
)
=
error
"CurryToIL.optMatch.tagAlt: empty list"
>
tagAlt
(
_
,
[]
,
_
)
=
error
"CurryToIL.opt
Flex
Match.tagAlt: empty list"
>
-- again, skipArg skips the current argument for later matching
>
skipArg
(
pref
,
t
:
ts
,
e'
)
=
(
pref
.
(
t
:
),
ts
,
e'
)
>
skipArg
(
_
,
[]
,
_
)
=
error
"CurryToIL.optMatch.skipArg: empty list"
>
skipArg
(
_
,
[]
,
_
)
=
error
"CurryToIL.opt
Flex
Match.skipArg: empty list"
>
-- Generate a case expression matching the inductive position
>
m
atchInductive
::
SrcRef
->
IL
.
Eval
->
([
Ident
]
->
[
Ident
])
->
Ident
>
flexM
atchInductive
::
SrcRef
->
([
Ident
]
->
[
Ident
])
->
Ident
>
->
[
Ident
]
->
[(
IL
.
ConstrTerm
,
Match'
)]
->
IL
.
Expression
>
m
atchInductive
r
ev
prefix
v
vs
as
=
IL
.
Case
r
ev
(
IL
.
Variable
v
)
$
>
m
atchAlts
as
>
flexM
atchInductive
r
prefix
v
vs
as
=
IL
.
Case
r
IL
.
Flex
(
IL
.
Variable
v
)
$
>
flexM
atchAlts
as
>
where
>
-- create alternatives for the different constructors
>
m
atchAlts
[]
=
[]
>
m
atchAlts
((
t
,
e
)
:
alts
)
=
IL
.
Alt
t
expr
:
m
atchAlts
others
>
flexM
atchAlts
[]
=
[]
>
flexM
atchAlts
((
t
,
e
)
:
alts
)
=
IL
.
Alt
t
expr
:
flexM
atchAlts
others
>
where
>
-- match nested patterns for same constructors
>
expr
=
m
atch
(
srcRefOf
t
)
ev
(
prefix
$
vars
t
++
vs
)
matchingCases
>
expr
=
flexM
atch
(
srcRefOf
t
)
(
prefix
$
vars
t
++
vs
)
matchingCases
>
matchingCases
=
map
expandVars
(
e
:
map
snd
same
)
>
expandVars
(
pref
,
ts1
,
e'
)
=
(
pref
ts1
,
e'
)
>
-- split into same and other constructors
...
...
@@ -514,43 +513,42 @@ to detect total matches and immediately discard all alternatives which
cannot be reached.}
\begin{verbatim}
>
case
Match
::
SrcRef
->
IL
.
Eval
->
[
Ident
]
->
[
Match
]
->
IL
.
Expression
>
case
Match
r
ev
vs
alts
=
case
OptMatch
r
ev
(
snd
$
head
alts
)
id
vs
>
(
map
prepare
alts
)
>
rigid
Match
::
SrcRef
->
[
Ident
]
->
[
Match
]
->
IL
.
Expression
>
rigid
Match
r
vs
alts
=
rigid
OptMatch
r
(
snd
$
head
alts
)
id
vs
>
(
map
prepare
alts
)
>
where
prepare
(
ts
,
e
)
=
(
id
,
ts
,
e
)
>
caseOptMatch
::
SrcRef
-- source reference
>
->
IL
.
Eval
-- evaluation mode (rigid)
>
->
IL
.
Expression
-- default expression
>
->
([
Ident
]
->
[
Ident
])
-- variables to be matched next
>
->
[
Ident
]
-- variables to be matched afterwards
>
->
[
Match'
]
-- translated equations, list of: nested pattern+RHS
>
->
IL
.
Expression
>
rigidOptMatch
::
SrcRef
-- source reference
>
->
IL
.
Expression
-- default expression
>
->
([
Ident
]
->
[
Ident
])
-- variables to be matched next
>
->
[
Ident
]
-- variables to be matched afterwards
>
->
[
Match'
]
-- translated equations, list of: nested pattern+RHS
>
->
IL
.
Expression
>
-- if there are no variables left: return the default expression
>
case
OptMatch
_
_
def
_
[]
_
=
def
>
case
OptMatch
r
ev
def
prefix
(
v
:
vs
)
alts
>
|
isInductive
=
case
MatchInductive
r
ev
prefix
v
vs
alts'
>
|
otherwise
=
case
OptMatch
r
ev
def
(
prefix
.
(
v
:
))
vs
(
map
skipArg
alts
)
>
rigid
OptMatch
_
def
_
[]
_
=
def
>
rigid
OptMatch
r
def
prefix
(
v
:
vs
)
alts
>
|
isInductive
=
rigid
MatchInductive
r
prefix
v
vs
alts'
>
|
otherwise
=
rigid
OptMatch
r
def
(
prefix
.
(
v
:
))
vs
(
map
skipArg
alts
)
>
where
>
isInductive
=
not
$
isVarMatch
(
head
alts'
)
>
alts'
=
map
tagAlt
alts
>
-- tagAlt extracts the next pattern
>
tagAlt
(
pref
,
t
:
ts
,
e'
)
=
(
pattern
t
,
(
pref
,
arguments
t
++
ts
,
e'
))
>
tagAlt
(
_
,
[]
,
_
)
=
error
"CurryToIL.
case
OptMatch.tagAlt: empty list"
>
tagAlt
(
_
,
[]
,
_
)
=
error
"CurryToIL.
rigid
OptMatch.tagAlt: empty list"
>
-- skipArg skips the current argument for later matching
>
skipArg
(
pref
,
t
:
ts
,
e'
)
=
(
pref
.
(
t
:
),
ts
,
e'
)
>
skipArg
(
_
,
[]
,
_
)
=
error
"CurryToIL.
case
OptMatch.skipArg: empty list"
>
skipArg
(
_
,
[]
,
_
)
=
error
"CurryToIL.
rigid
OptMatch.skipArg: empty list"
>
-- Generate a case expression matching the inductive position
>
case
MatchInductive
::
SrcRef
->
IL
.
Eval
->
([
Ident
]
->
[
Ident
])
->
Ident
>
rigid
MatchInductive
::
SrcRef
->
([
Ident
]
->
[
Ident
])
->
Ident
>
->
[
Ident
]
->
[(
IL
.
ConstrTerm
,
Match'
)]
->
IL
.
Expression
>
case
MatchInductive
r
ev
prefix
v
vs
alts
=
IL
.
Case
r
ev
(
IL
.
Variable
v
)
$
>
map
caseAlt
(
nonVarPats
++
varPats
)
>
rigid
MatchInductive
r
prefix
v
vs
alts
=
IL
.
Case
r
IL
.
Rigid
(
IL
.
Variable
v
)
>
$
map
caseAlt
(
nonVarPats
++
varPats
)
>
where
>
(
varPats
,
nonVarPats
)
=
partition
isVarPattern
$
nub
$
map
fst
alts
>
caseAlt
t
=
IL
.
Alt
t
expr
>
where
>
expr
=
case
Match
(
srcRefOf
t
)
ev
(
prefix
$
vars
t
++
vs
)
(
matchingCases
alts
)
>
expr
=
rigid
Match
(
srcRefOf
t
)
(
prefix
$
vars
t
++
vs
)
(
matchingCases
alts
)
>
-- matchingCases selects the matching branches and recursively
>
-- matches the remaining patterns
>
matchingCases
=
map
(
expandVars
$
vars
t
)
.
filter
(
matches
.
fst
)
...
...
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