Commit 5f00d64d authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Fixed pattern matching warnings for non-deterministic matching

parent 1aa0b949
......@@ -274,14 +274,11 @@ checkFunctionDecl p f eqs = inNestedScope $ do
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, _) <- checkPatternMatching pats
unless (null nonExhaustive) $ warnFor WarnNondetPatterns $ report $
warnMissingPattern p loc nonExhaustive
unless (null overlapped) $ warnFor WarnNondetPatterns $ report $
warnOverlapPattern p loc (idName f) "=" overlapped
-- when nondet $ warnFor WarnOverlapping $ report $
-- warnNondetOverlapping p ("Function " ++ escName f)
(nonExhaustive, overlapped, nondet) <- checkPatternMatching pats
unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
warnMissingPattern p ("an equation for " ++ escName f) nonExhaustive
when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $
warnNondetOverlapping p ("Function " ++ escName f)
-- Check an equation for warnings.
-- This is done in a seperate scope as the left-hand-side may introduce
......@@ -306,16 +303,16 @@ checkLhs (ApLhs lhs ts) = do
checkPattern :: Pattern -> WCM ()
checkPattern (VariablePattern v) = checkShadowing v
checkPattern (ConstructorPattern _ ps) = mapM_ checkPattern ps
checkPattern (InfixPattern p1 f p2)
= checkPattern (ConstructorPattern f [p1, p2])
checkPattern (InfixPattern p1 f p2) = checkPattern
(ConstructorPattern f [p1, p2])
checkPattern (ParenPattern p) = checkPattern p
checkPattern (TuplePattern _ ps) = mapM_ checkPattern ps
checkPattern (ListPattern _ ps) = mapM_ checkPattern ps
checkPattern (AsPattern v p) = checkShadowing v >> checkPattern p
checkPattern (LazyPattern _ p) = checkPattern p
checkPattern (FunctionPattern _ ps) = mapM_ checkPattern ps
checkPattern (InfixFuncPattern p1 f p2)
= checkPattern (FunctionPattern f [p1, p2])
checkPattern (InfixFuncPattern p1 f p2) = checkPattern
(FunctionPattern f [p1, p2])
checkPattern (RecordPattern fs r) = do
mapM_ (\ (Field _ _ p) -> checkPattern p) fs
maybe ok checkPattern r
......@@ -460,27 +457,25 @@ warnAliasNameClash mids = posMessage (head mids) $ text
ppLine pos <> text ":" <+> text (escModuleName mid)
-- -----------------------------------------------------------------------------
-- Check for overlapping and non-exhaustive case alternatives
-- Check for overlapping/unreachable and non-exhaustive case alternatives
-- -----------------------------------------------------------------------------
checkCaseAlts :: CaseType -> [Alt] -> WCM ()
checkCaseAlts _ [] = ok
checkCaseAlts ct alts@(Alt p _ _ : _) = do
let pats = map (\(Alt _ pat _) -> [pat]) alts
let loc = "a fcase alternative"
(nonExhaustive, overlapped, _) <- checkPatternMatching pats
(nonExhaustive, overlapped, nondet) <- checkPatternMatching pats
case ct of
Flex -> do
unless (null nonExhaustive) $ warnFor WarnNondetPatterns $ report $
warnMissingPattern p loc nonExhaustive
unless (null overlapped) $ warnFor WarnNondetPatterns $ report $
warnOverlapPattern p loc "" "->" overlapped
-- when nondet $ warnFor WarnOverlapping $ report $
-- warnNondetOverlapping p ("A fcase expression")
unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
warnMissingPattern p "an fcase alternative" nonExhaustive
when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report
$ warnNondetOverlapping p "An fcase expression"
Rigid -> do
unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
warnMissingPattern p loc nonExhaustive
warnMissingPattern p "a case alternative" nonExhaustive
unless (null overlapped) $ warnFor WarnOverlapping $ report $
warnOverlapPattern p loc "" "->" overlapped
warnUnreachablePattern p overlapped
-- -----------------------------------------------------------------------------
-- Check for non-exhaustive and overlapping patterns.
......@@ -584,7 +579,7 @@ type EqnSet = IntSet.IntSet
processEqs :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processEqs [] = return ([], IntSet.empty, False)
processEqs eqs@((n, ps):_)
| null ps = return ([], IntSet.singleton n, False)
| null ps = return ([], IntSet.singleton n, length eqs > 1)
| any isLitPat firstPats = processLits eqs
| any isConPat firstPats = processCons eqs
| all isVarPat firstPats = processVars eqs
......@@ -602,9 +597,9 @@ processLits qs@(q:_) = do
then return $ (defaultPat : missing1, used1, nd1)
else do
-- Missing patterns for the default alternatives
(missing2, used2, _) <- processEqs defaults
(missing2, used2, nd2) <- processEqs defaults
return ( [ (wildPat : ps, cs) | (ps, cs) <- missing2 ] ++ missing1
, IntSet.union used1 used2, True )
, IntSet.union used1 used2, nd1 || nd2 )
where
-- The literals occurring in the patterns
usedLits = nub $ concatMap (getLit . firstPat) qs
......@@ -623,9 +618,10 @@ processUsedLits lits qs = do
return (concat eps, IntSet.unions idxs, or nds)
where
process lit = do
(missing, used, nd) <- processEqs
[shiftPat q | q <- qs, isVarLit lit (firstPat q)]
return (map (\(xs, ys) -> (LiteralPattern lit : xs, ys)) missing, used, nd)
let qs' = [shiftPat q | q <- qs, isVarLit lit (firstPat q)]
ovlp = length qs' > 1
(missing, used, nd) <- processEqs qs'
return (map (\(xs, ys) -> (LiteralPattern lit : xs, ys)) missing, used, nd && ovlp)
-- |Constructor patterns are checked by extracting the matched constructors
-- and constructing a pattern for any missing case.
......@@ -637,15 +633,15 @@ processCons qs@(q:_) = do
-- Determine unused constructors
unused <- getUnusedCons (map fst used_cons)
if null unused
then return (missing1, used1, nd || not (null defaults))
then return (missing1, used1, nd)
else if null defaults
then return $ (map defaultPat unused ++ missing1, used1, nd)
else do
-- Missing patterns for the default alternatives
(missing2, used2, _) <- processEqs defaults
(missing2, used2, nd2) <- processEqs defaults
return ( [ (mkPattern c : ps, cs) | c <- unused, (ps, cs) <- missing2 ]
++ missing1
, IntSet.union used1 used2, True)
, IntSet.union used1 used2, nd || nd2)
where
-- used constructors (occurring in a pattern)
used_cons = nub $ concatMap (getCon . firstPat) qs
......@@ -666,8 +662,9 @@ processUsedCons cons qs = do
where
process (c, a) = do
let qs' = [ removeFirstCon c a q | q <- qs , isVarCon c (firstPat q)]
ovlp = length qs' > 1
(missing, used, nd) <- processEqs qs'
return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd)
return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd && ovlp)
makeCon c a ps = let (args, rest) = splitAt a ps
in ConstructorPattern c args : rest
......@@ -682,9 +679,10 @@ processUsedCons cons qs = do
processVars :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processVars [] = error "WarnCheck.processVars"
processVars eqs@((n, _) : _) = do
let ovlp = length eqs > 1
(missing, used, nd) <- processEqs (map shiftPat eqs)
return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing
, IntSet.insert n used, nd)
, IntSet.insert n used, nd && ovlp)
-- |Return the constructors of a type not contained in the list of constructors.
getUnusedCons :: [QualIdent] -> WCM [DataConstr]
......@@ -829,7 +827,7 @@ patArgs _ = []
warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message
warnMissingPattern p loc pats = posMessage p
$ text "Pattern matches are non-exhaustive"
$+$ text "In a" <+> text loc <> char ':'
$+$ text "In" <+> text loc <> char ':'
$+$ nest 2 (text "Patterns not matched:" $+$ nest 2 (vcat (ppExPats pats)))
where
ppExPats ps
......@@ -843,15 +841,14 @@ warnMissingPattern p loc pats = posMessage p
ppCons (i, lits) = ppIdent i <+> text "`notElem`"
<+> ppExpr 0 (List [] (map Literal lits))
-- |Warning message for non-exhaustive patterns.
-- |Warning message for unreachable patterns.
-- To shorten the output only the first 'maxPattern' are printed,
-- additional pattern are abbreviated by dots.
warnOverlapPattern :: Position -> String -> String -> String
-> [[Pattern]] -> Message
warnOverlapPattern p loc pre post pats = posMessage p
$ text "Pattern matches are overlapped"
$+$ text "In a" <+> text loc <> char ':'
$+$ nest 2 (text pre <+> vcat (ppExPats pats) <+> text post <+> text "...")
warnUnreachablePattern :: Position -> [[Pattern]] -> Message
warnUnreachablePattern p pats = posMessage p
$ text "Pattern matches are unreachable"
$+$ text "In a case alternative:"
$+$ nest 2 (vcat (ppExPats pats) <+> text "->" <+> text "...")
where
ppExPats ps
| length ps > maxPattern = ppPats ++ [text "..."]
......@@ -863,9 +860,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 overlapping rules"
-- -----------------------------------------------------------------------------
......
......@@ -157,7 +157,6 @@ data WarnFlag
| WarnNameShadowing -- ^ Warn for name shadowing
| WarnOverlapping -- ^ Warn for overlapping rules/alternatives
| WarnIncompletePatterns -- ^ Warn for incomplete pattern matching
| WarnNondetPatterns -- ^ Warn for non-deterministic pattern matching
| WarnMissingSignatures -- ^ Warn for missing type signatures
deriving (Eq, Bounded, Enum, Show)
......@@ -184,8 +183,6 @@ warnFlags =
, "overlapping function rules" )
, ( WarnIncompletePatterns, "incomplete-patterns"
, "incomplete pattern matching")
, ( WarnNondetPatterns , "nondet-patterns"
, "Nondeterministic patterns" )
, ( WarnMissingSignatures , "missing-signatures"
, "missing type signatures" )
]
......
......@@ -14,10 +14,10 @@
The MCC translates case expressions into the intermediate language
representation (IL) without completing them (i.e. without generating
case branches for missing contructors), because the intermediate language
supports variable patterns.
supports variable patterns for the fallback case.
In contrast, the FlatCurry representation of patterns only allows
literal and constructor patterns, which requires the expansion of
missing or default branches to all missing constructors.
literal and constructor patterns, which requires the expansion
default branches to all missing constructors.
This is only necessary for *rigid* case expressions, because any
*flexible* case expression with more than one branch and a variable
......@@ -45,7 +45,7 @@ import Env.Interface (InterfaceEnv, lookupInterface)
import IL
-- Completes case expressions by adding branches for missing constructors.
-- The interface environment 'menv' is needed to compute these constructors.
-- The interface environment 'iEnv' is needed to compute these constructors.
completeCase :: InterfaceEnv -> Module -> Module
completeCase iEnv mdl@(Module mid is ds) = Module mid is ds'
where ds'= S.evalState (mapM (withLocalEnv . ccDecl) ds)
......
f = case () of
_ -> True
_ -> False
f [] _ = Nothing
f (_ : _) [] = Nothing
f ((_, _) : _) ((_, _) : _) = Nothing
f [] _ = Nothing
f (_ : _) [] = Nothing
f ((_, _) : _) (_ : _) = Nothing
g x = fcase x of
g x = case x of
"" -> 0
[] -> 1
_ -> 2
g x = fcase x of
h x = fcase x of
[_] -> 0
(_:[]) -> 1
_ -> 2
......@@ -16,4 +17,7 @@ i y = y
j [] = 0
j (_:_) = 0
j x = 1
j _ = 1
k [] = 0
k _ = 1
{-# LANGUAGE Records #-}
module RecordTest where
type Record =
......@@ -9,4 +10,14 @@ empty = { intField := 0, boolField := False }
full = { intField := 1, boolField := True }
expr = empty :> intField + 1 == 0
\ No newline at end of file
expr = empty :> intField + 1 == 0
-- int :: { intField :: Int | a }
-- int = { intField := 0 }
type Record2 =
{ intField2 :: Int
, boolField2 :: Bool
}
test = { intField := 0, boolField2 := True }
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment