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
4e12c0a6
Commit
4e12c0a6
authored
Aug 12, 2014
by
Björn Peemöller
Browse files
Fixed some bugs in WarnCheck
parent
57825e5f
Changes
1
Hide whitespace changes
Inline
Side-by-side
src/Checks/WarnCheck.hs
View file @
4e12c0a6
...
...
@@ -21,7 +21,7 @@ import Control.Monad.State.Strict (State, execState, gets, modify)
import
qualified
Data.IntSet
as
IntSet
(
IntSet
,
empty
,
insert
,
notMember
,
singleton
,
union
,
unions
)
import
qualified
Data.Map
as
Map
(
empty
,
insert
,
lookup
)
import
Data.Maybe
(
catMaybes
,
isJust
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
,
isJust
)
import
Data.List
(
intersect
,
intersectBy
,
nub
,
sort
,
unionBy
)
...
...
@@ -275,7 +275,7 @@ checkFunctionPatternMatch :: Position -> Ident -> [Equation] -> WCM ()
checkFunctionPatternMatch
p
f
eqs
=
do
let
pats
=
map
(
\
(
Equation
_
lhs
_
)
->
snd
(
flatLhs
lhs
))
eqs
let
loc
=
"an equation for "
++
escName
f
(
nonExhaustive
,
overlapped
,
nondet
)
<-
checkPatternMatching
pats
(
nonExhaustive
,
overlapped
,
_
)
<-
checkPatternMatching
pats
unless
(
null
nonExhaustive
)
$
warnFor
WarnNondetPatterns
$
report
$
warnMissingPattern
p
loc
nonExhaustive
unless
(
null
overlapped
)
$
warnFor
WarnNondetPatterns
$
report
$
...
...
@@ -468,7 +468,7 @@ checkCaseAlts _ [] = ok
checkCaseAlts
ct
alts
@
(
Alt
p
_
_
:
_
)
=
do
let
pats
=
map
(
\
(
Alt
_
pat
_
)
->
[
pat
])
alts
let
loc
=
"a fcase alternative"
(
nonExhaustive
,
overlapped
,
nondet
)
<-
checkPatternMatching
pats
(
nonExhaustive
,
overlapped
,
_
)
<-
checkPatternMatching
pats
case
ct
of
Flex
->
do
unless
(
null
nonExhaustive
)
$
warnFor
WarnNondetPatterns
$
report
$
...
...
@@ -503,7 +503,7 @@ checkPatternMatching :: [[Pattern]] -> WCM ([ExhaustivePats], [[Pattern]], Bool)
checkPatternMatching
pats
=
do
-- 1. We simplify the patterns by removing syntactic sugar temporarily
-- for a simpler implementation.
let
simplePats
=
map
(
map
simplifyPat
)
pats
simplePats
<-
map
M
(
map
M
simplifyPat
)
pats
-- 2. We compute missing and used pattern matching alternatives
(
missing
,
used
,
nondet
)
<-
processEqs
(
zip
[
1
..
]
simplePats
)
-- 3. If any, we report the missing patterns, whereby we re-add the syntactic
...
...
@@ -516,29 +516,49 @@ checkPatternMatching pats = do
-- * Variables
-- * Integer, Float or Char literals
-- * Constructors
-- * record pattern (currently ignored)
-- All other patterns like as-patterns, list patterns and alike are desugared.
simplifyPat
::
Pattern
->
Pattern
simplifyPat
p
@
(
LiteralPattern
l
)
=
case
l
of
simplifyPat
::
Pattern
->
WCM
Pattern
simplifyPat
p
@
(
LiteralPattern
l
)
=
return
$
case
l
of
String
r
s
->
simplifyListPattern
$
map
(
LiteralPattern
.
Char
r
)
s
_
->
p
simplifyPat
(
NegativePattern
_
l
)
=
LiteralPattern
(
negateLit
l
)
simplifyPat
(
NegativePattern
_
l
)
=
return
$
LiteralPattern
(
negateLit
l
)
where
negateLit
(
Int
i
n
)
=
Int
i
(
-
n
)
negateLit
(
Float
r
d
)
=
Float
r
(
-
d
)
negateLit
x
=
x
simplifyPat
v
@
(
VariablePattern
_
)
=
v
simplifyPat
(
ConstructorPattern
c
ps
)
=
ConstructorPattern
c
(
map
simplifyPat
ps
)
simplifyPat
(
InfixPattern
p1
c
p2
)
=
ConstructorPattern
c
(
map
simplifyPat
[
p1
,
p2
]
)
simplifyPat
v
@
(
VariablePattern
_
)
=
return
v
simplifyPat
(
ConstructorPattern
c
ps
)
=
ConstructorPattern
c
`
liftM
`
map
M
simplifyPat
ps
simplifyPat
(
InfixPattern
p1
c
p2
)
=
ConstructorPattern
c
`
liftM
`
map
M
simplifyPat
[
p1
,
p2
]
simplifyPat
(
ParenPattern
p
)
=
simplifyPat
p
simplifyPat
(
TuplePattern
_
ps
)
=
ConstructorPattern
(
qTupleId
(
length
ps
))
(
map
simplifyPat
ps
)
simplifyPat
(
ListPattern
_
ps
)
=
simplifyListPattern
(
map
simplifyPat
ps
)
simplifyPat
(
TuplePattern
_
ps
)
=
ConstructorPattern
(
qTupleId
(
length
ps
))
`
liftM
`
mapM
simplifyPat
ps
simplifyPat
(
ListPattern
_
ps
)
=
simplifyListPattern
`
liftM
`
mapM
simplifyPat
ps
simplifyPat
(
AsPattern
_
p
)
=
simplifyPat
p
simplifyPat
(
LazyPattern
_
_
)
=
VariablePattern
anonId
simplifyPat
p
=
p
simplifyPat
(
LazyPattern
_
_
)
=
return
$
VariablePattern
anonId
simplifyPat
(
FunctionPattern
_
_
)
=
return
$
VariablePattern
anonId
simplifyPat
(
InfixFuncPattern
_
_
_
)
=
return
$
VariablePattern
anonId
simplifyPat
(
RecordPattern
fs
_
)
|
null
fs
=
internalError
"Checks.WarnCheck.simplifyPat"
|
otherwise
=
do
(
r
,
rfs
)
<-
getAllLabels
(
fieldLabel
$
head
fs
)
let
ps
=
map
(
getPattern
(
map
field2Tuple
fs
))
rfs
simplifyPat
(
ConstructorPattern
r
ps
)
where
getPattern
fs'
l
=
fromMaybe
(
VariablePattern
anonId
)
(
lookup
l
fs'
)
getAllLabels
::
Ident
->
WCM
(
QualIdent
,
[
Ident
])
getAllLabels
l
=
do
tyEnv
<-
gets
valueEnv
case
lookupValue
l
tyEnv
of
[
Label
_
r
_
]
->
do
tcEnv
<-
gets
tyConsEnv
case
qualLookupTC
r
tcEnv
of
[
AliasType
_
_
(
TypeRecord
fs
_
)]
->
return
(
r
,
map
fst
fs
)
_
->
internalError
$
"Checks.WarnCheck.getAllLabels: "
++
show
r
_
->
internalError
$
"Checks.WarnCheck.getAllLabels: "
++
show
l
-- |Create a simplified list pattern by applying @:@ and @[]@.
simplifyListPattern
::
[
Pattern
]
->
Pattern
...
...
@@ -569,7 +589,7 @@ processEqs eqs@((n, ps):_)
|
any
isLitPat
firstPats
=
processLits
eqs
|
any
isConPat
firstPats
=
processCons
eqs
|
all
isVarPat
firstPats
=
processVars
eqs
|
otherwise
=
error
"
WarnCheck.processEqs"
|
otherwise
=
internalError
"Checks.
WarnCheck.processEqs"
where
firstPats
=
map
firstPat
eqs
-- |Literal patterns are checked by extracting the matched literals
...
...
@@ -829,9 +849,9 @@ warnOverlapPattern p loc pre post pats = posMessage p
maxPattern
::
Int
maxPattern
=
4
warnNondetOverlapping
::
Position
->
String
->
Message
warnNondetOverlapping
p
loc
=
posMessage
p
$
text
loc
<+>
text
"is non-deterministic due to non-trivial overlapping rules"
--
warnNondetOverlapping :: Position -> String -> Message
--
warnNondetOverlapping p loc = posMessage p $
--
text loc <+> text "is non-deterministic due to non-trivial overlapping rules"
-- -----------------------------------------------------------------------------
...
...
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