Skip to content
GitLab
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
8e625838
Commit
8e625838
authored
Aug 08, 2014
by
Björn Peemöller
Browse files
Completely refactored warnings for non-eshaustive and overlapping patterns
Fixed #1048
parent
a37fcbd5
Changes
5
Expand all
Hide whitespace changes
Inline
Side-by-side
src/Checks/WarnCheck.hs
View file @
8e625838
This diff is collapsed.
Click to expand it.
src/CompilerOpts.hs
View file @
8e625838
...
...
@@ -157,15 +157,14 @@ data WarnFlag
|
WarnNameShadowing
-- ^ Warn for name shadowing
|
WarnOverlapping
-- ^ Warn for overlapping rules/alternatives
|
WarnIncompletePatterns
-- ^ Warn for incomplete pattern matching
|
Warn
IdleAlternatives
-- ^ Warn for
idle case alternatives
|
Warn
NondetPatterns
-- ^ Warn for
non-deterministic pattern matching
deriving
(
Eq
,
Bounded
,
Enum
,
Show
)
-- |Warning flags enabled by default
stdWarnFlags
::
[
WarnFlag
]
stdWarnFlags
=
[
WarnMultipleImports
,
WarnDisjoinedRules
,
WarnUnusedBindings
,
WarnNameShadowing
,
WarnOverlapping
-- , WarnIncompletePatterns
,
WarnIdleAlternatives
,
WarnNameShadowing
,
WarnOverlapping
,
WarnIncompletePatterns
]
-- |Description and flag of warnings flags
...
...
@@ -183,8 +182,8 @@ warnFlags =
,
"overlapping function rules"
)
,
(
WarnIncompletePatterns
,
"incomplete-patterns"
,
"incomplete pattern matching"
)
,
(
Warn
IdleAlternative
s
,
"
idle-alternative
s"
,
"
idle case alternatives"
)
,
(
Warn
NondetPattern
s
,
"
nondet-pattern
s"
,
"
Nondeterministic patterns"
)
]
-- |Dump level
...
...
src/Generators.hs
View file @
8e625838
...
...
@@ -12,17 +12,14 @@
-}
module
Generators
where
import
Curry.Base.Message
(
Message
)
import
qualified
Curry.AbstractCurry
as
AC
(
CurryProg
)
import
qualified
Curry.ExtendedFlat.Type
as
EF
(
Prog
)
import
qualified
Curry.Syntax
as
CS
(
Module
)
import
qualified
Curry.AbstractCurry
as
AC
(
CurryProg
)
import
qualified
Curry.ExtendedFlat.Type
as
EF
(
Prog
)
import
qualified
Curry.Syntax
as
CS
(
Module
)
import
qualified
Generators.GenAbstractCurry
as
GAC
import
qualified
Generators.GenFlatCurry
as
GFC
import
CompilerEnv
import
CompilerOpts
import
IL
(
Module
)
import
ModuleSummary
...
...
@@ -35,13 +32,11 @@ genUntypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genUntypedAbstractCurry
=
GAC
.
genUntypedAbstract
-- |Generate FlatCurry
genFlatCurry
::
Options
->
ModuleSummary
->
CompilerEnv
->
IL
.
Module
->
(
EF
.
Prog
,
[
Message
])
genFlatCurry
opts
ms
env
=
GFC
.
genFlatCurry
opts
ms
genFlatCurry
::
ModuleSummary
->
CompilerEnv
->
IL
.
Module
->
EF
.
Prog
genFlatCurry
ms
env
=
GFC
.
genFlatCurry
ms
(
interfaceEnv
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
-- |Generate a FlatCurry interface
genFlatInterface
::
Options
->
ModuleSummary
->
CompilerEnv
->
IL
.
Module
->
(
EF
.
Prog
,
[
Message
])
genFlatInterface
opts
ms
env
=
GFC
.
genFlatInterface
opts
ms
genFlatInterface
::
ModuleSummary
->
CompilerEnv
->
IL
.
Module
->
EF
.
Prog
genFlatInterface
ms
env
=
GFC
.
genFlatInterface
ms
(
interfaceEnv
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
src/Generators/GenFlatCurry.hs
View file @
8e625838
...
...
@@ -10,16 +10,14 @@
module
Generators.GenFlatCurry
(
genFlatCurry
,
genFlatInterface
)
where
-- Haskell libraries
import
Control.Monad
(
filterM
,
liftM
,
liftM2
,
liftM3
,
mplus
,
when
)
import
Control.Monad.State
(
State
,
run
State
,
gets
,
modify
)
import
Control.Monad
(
filterM
,
liftM
,
liftM2
,
liftM3
,
mplus
)
import
Control.Monad.State
(
State
,
eval
State
,
gets
,
modify
)
import
Data.List
(
mapAccumL
,
nub
)
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
,
fromList
,
toList
)
import
Data.Maybe
(
catMaybes
,
fromJust
,
fromMaybe
,
isJust
)
-- curry-base
import
Curry.Base.Ident
as
Id
import
Curry.Base.Message
import
Curry.Base.Pretty
import
Curry.ExtendedFlat.Type
import
qualified
Curry.Syntax
as
CS
...
...
@@ -39,7 +37,6 @@ import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
-- other
import
CompilerOpts
(
Options
(
..
),
WarnOpts
(
..
),
WarnFlag
(
..
))
import
qualified
IL
as
IL
import
qualified
ModuleSummary
import
Transformations
(
transType
)
...
...
@@ -50,20 +47,16 @@ trace' _ x = x
-------------------------------------------------------------------------------
-- transforms intermediate language code (IL) to FlatCurry code
genFlatCurry
::
Options
->
ModuleSummary
.
ModuleSummary
->
InterfaceEnv
->
ValueEnv
->
TCEnv
->
IL
.
Module
->
(
Prog
,
[
Message
])
genFlatCurry
opts
modSum
mEnv
tyEnv
tcEnv
mdl
=
(
prog'
,
messages
)
where
(
prog
,
messages
)
=
run
opts
modSum
mEnv
tyEnv
tcEnv
False
(
visitModule
mdl
)
prog'
=
patchPrelude
prog
-- eraseTypes $ adjustTypeInfo $
genFlatCurry
::
ModuleSummary
.
ModuleSummary
->
InterfaceEnv
->
ValueEnv
->
TCEnv
->
IL
.
Module
->
Prog
genFlatCurry
modSum
mEnv
tyEnv
tcEnv
mdl
=
patchPrelude
$
run
modSum
mEnv
tyEnv
tcEnv
False
(
visitModule
mdl
)
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface
::
Options
->
ModuleSummary
.
ModuleSummary
->
InterfaceEnv
->
ValueEnv
->
TCEnv
->
IL
.
Module
->
(
Prog
,
[
Message
])
genFlatInterface
opts
modSum
mEnv
tyEnv
tcEnv
mdl
=
(
intf'
,
messages
)
where
(
intf
,
messages
)
=
run
opts
modSum
mEnv
tyEnv
tcEnv
True
(
visitModule
mdl
)
intf'
=
patchPrelude
intf
genFlatInterface
::
ModuleSummary
.
ModuleSummary
->
InterfaceEnv
->
ValueEnv
->
TCEnv
->
IL
.
Module
->
Prog
genFlatInterface
modSum
mEnv
tyEnv
tcEnv
mdl
=
patchPrelude
$
run
modSum
mEnv
tyEnv
tcEnv
True
(
visitModule
mdl
)
patchPrelude
::
Prog
->
Prog
patchPrelude
p
@
(
Prog
n
_
types
funcs
ops
)
...
...
@@ -108,7 +101,6 @@ type FlatState a = State FlatEnv a
data
FlatEnv
=
FlatEnv
{
moduleIdE
::
ModuleIdent
,
functionIdE
::
(
QualIdent
,
[(
Ident
,
IL
.
Type
)])
,
compilerOptsE
::
Options
,
interfaceEnvE
::
InterfaceEnv
,
typeEnvE
::
ValueEnv
-- types of defined values
,
tConsEnvE
::
TCEnv
...
...
@@ -121,7 +113,6 @@ data FlatEnv = FlatEnv
,
varIndexE
::
Int
,
varIdsE
::
ScopeEnv
Ident
VarIndex
,
tvarIndexE
::
Int
,
messagesE
::
[
Message
]
,
genInterfaceE
::
Bool
,
localTypes
::
Map
.
Map
QualIdent
IL
.
Type
,
constrTypes
::
Map
.
Map
QualIdent
IL
.
Type
...
...
@@ -133,15 +124,13 @@ data IdentExport
|
NotOnlyConstr
-- constructor, function, type-constructor
-- 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
,
reverse
$
messagesE
env
)
run
::
ModuleSummary
.
ModuleSummary
->
InterfaceEnv
->
ValueEnv
->
TCEnv
->
Bool
->
FlatState
a
->
a
run
modSum
mEnv
tyEnv
tcEnv
genIntf
f
=
evalState
f
env
0
where
(
result
,
env
)
=
runState
f
env0
env0
=
FlatEnv
{
moduleIdE
=
ModuleSummary
.
moduleId
modSum
,
functionIdE
=
(
qualify
(
mkIdent
""
),
[]
)
,
compilerOptsE
=
opts
,
interfaceEnvE
=
mEnv
,
typeEnvE
=
tyEnv
,
tConsEnvE
=
tcEnv
...
...
@@ -155,7 +144,6 @@ run opts modSum mEnv tyEnv tcEnv genIntf f = (result, reverse $ messagesE env)
,
varIndexE
=
0
,
varIdsE
=
ScopeEnv
.
new
,
tvarIndexE
=
0
,
messagesE
=
[]
,
genInterfaceE
=
genIntf
,
localTypes
=
Map
.
empty
,
constrTypes
=
Map
.
fromList
$
getConstrTypes
tcEnv
tyEnv
...
...
@@ -297,7 +285,7 @@ visitExpression (IL.Case r ea e bs) =
visitExpression
(
IL
.
Or
e1
e2
)
=
do
e1'
<-
visitExpression
e1
e2'
<-
visitExpression
e2
checkOverlapping
e1'
e2'
--
checkOverlapping e1' e2'
return
$
Or
e1'
e2'
visitExpression
(
IL
.
Exist
v
e
)
=
do
idx
<-
newVarIndex
v
...
...
@@ -758,15 +746,6 @@ matchTypeVars fs ms (l,ty) = maybe ms (match ms ty) (lookup l fs)
flattenRecordTypeFields
::
[([
Ident
],
CS
.
TypeExpr
)]
->
[(
Ident
,
CS
.
TypeExpr
)]
flattenRecordTypeFields
=
concatMap
(
\
(
ls
,
ty
)
->
map
(
\
l
->
(
l
,
ty
))
ls
)
checkOverlapping
::
Expr
->
Expr
->
FlatState
()
checkOverlapping
e1
e2
=
do
warnOpts
<-
optWarnOpts
`
liftM
`
compilerOpts
when
(
WarnOverlapping
`
elem
`
wnWarnFlags
warnOpts
)
$
checkOverlap
e1
e2
where
checkOverlap
(
Case
_
_
_
_
)
_
=
functionId
>>=
genWarning
.
overlappingRules
checkOverlap
_
(
Case
_
_
_
_
)
=
functionId
>>=
genWarning
.
overlappingRules
checkOverlap
_
_
=
return
()
cs2ilType
::
[(
Ident
,
Int
)]
->
CS
.
TypeExpr
->
([(
Ident
,
Int
)],
IL
.
Type
)
cs2ilType
ids
(
CS
.
ConstructorType
qident
typeexprs
)
=
let
(
ids'
,
ilTypeexprs
)
=
mapAccumL
cs2ilType
ids
typeexprs
...
...
@@ -806,11 +785,6 @@ consArity qid = "GenFlatCurry: missing arity for constructor \""
missingVarIndex
::
Show
a
=>
a
->
[
Char
]
missingVarIndex
ident
=
"GenFlatCurry: missing index for
\"
"
++
show
ident
++
"
\"
"
overlappingRules
::
QualIdent
->
Message
overlappingRules
qid
=
posMessage
qid
$
hsep
$
map
text
[
"Function"
,
'"'
:
qualName
qid
++
"
\"
"
,
"is non-deterministic due to non-trivial overlapping rules"
]
-------------------------------------------------------------------------------
--
...
...
@@ -866,18 +840,10 @@ bindingIdent (IL.Binding ident _) = ident
moduleId
::
FlatState
ModuleIdent
moduleId
=
gets
moduleIdE
--
functionId
::
FlatState
QualIdent
functionId
=
gets
(
fst
.
functionIdE
)
--
setFunctionId
::
(
QualIdent
,
[(
Ident
,
IL
.
Type
)])
->
FlatState
()
setFunctionId
qid
=
modify
$
\
s
->
s
{
functionIdE
=
qid
}
--
compilerOpts
::
FlatState
Options
compilerOpts
=
gets
compilerOptsE
--
exports
::
FlatState
[
CS
.
Export
]
exports
=
gets
exportsE
...
...
@@ -1017,10 +983,6 @@ lookupVarIndex ident = do
clearVarIndices
::
FlatState
()
clearVarIndices
=
modify
$
\
s
->
s
{
varIndexE
=
0
,
varIdsE
=
ScopeEnv
.
new
}
--
genWarning
::
Message
->
FlatState
()
genWarning
msg
=
modify
$
\
s
->
s
{
messagesE
=
msg
:
messagesE
s
}
--
genInterface
::
FlatState
Bool
genInterface
=
gets
genInterfaceE
...
...
src/Modules.hs
View file @
8e625838
...
...
@@ -319,14 +319,13 @@ writeFlat opts fn env modSum il = do
writeFlatCurry
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
->
IL
.
Module
->
IO
()
writeFlatCurry
opts
fn
env
modSum
il
=
do
warn
(
optWarnOpts
opts
)
msgs
when
extTarget
$
EF
.
writeExtendedFlat
useSubDir
(
extFlatName
fn
)
prog
when
fcyTarget
$
EF
.
writeFlatCurry
useSubDir
(
flatName
fn
)
prog
where
extTarget
=
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
fcyTarget
=
FlatCurry
`
elem
`
optTargetTypes
opts
useSubDir
=
optUseSubdir
opts
(
prog
,
msgs
)
=
genFlatCurry
opts
modSum
env
il
extTarget
=
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
fcyTarget
=
FlatCurry
`
elem
`
optTargetTypes
opts
useSubDir
=
optUseSubdir
opts
prog
=
genFlatCurry
modSum
env
il
writeFlatIntf
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
->
IL
.
Module
->
IO
()
...
...
@@ -337,14 +336,12 @@ writeFlatIntf opts fn env modSum il
mfint
<-
EF
.
readFlatInterface
targetFile
let
oldInterface
=
fromMaybe
emptyIntf
mfint
when
(
mfint
==
mfint
)
$
return
()
-- necessary to close file -- TODO
unless
(
oldInterface
`
eqInterface
`
newInterface
)
$
outputInterface
unless
(
oldInterface
`
eqInterface
`
intf
)
$
outputInterface
where
targetFile
=
flatIntName
fn
emptyIntf
=
EF
.
Prog
""
[]
[]
[]
[]
(
newInterface
,
intMsgs
)
=
genFlatInterface
opts
modSum
env
il
outputInterface
=
do
warn
(
optWarnOpts
opts
)
intMsgs
EF
.
writeFlatCurry
(
optUseSubdir
opts
)
targetFile
newInterface
intf
=
genFlatInterface
modSum
env
il
outputInterface
=
EF
.
writeFlatCurry
(
optUseSubdir
opts
)
targetFile
intf
writeAbstractCurry
::
Options
->
FilePath
->
CompilerEnv
->
CS
.
Module
->
IO
()
writeAbstractCurry
opts
fname
env
modul
=
do
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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