Commit 1aa0b949 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Extended check for non-exhaustive pattern to record patterns

parent 9bf00304
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
module Checks.WarnCheck (warnCheck) where module Checks.WarnCheck (warnCheck) where
import Control.Monad import Control.Monad
(filterM, foldM_, guard, liftM, when, unless) (filterM, foldM_, guard, liftM, liftM2, when, unless, zipWithM)
import Control.Monad.State.Strict (State, execState, gets, modify) import Control.Monad.State.Strict (State, execState, gets, modify)
import qualified Data.IntSet as IntSet import qualified Data.IntSet as IntSet
(IntSet, empty, insert, notMember, singleton, union, unions) (IntSet, empty, insert, notMember, singleton, union, unions)
...@@ -507,7 +507,7 @@ checkPatternMatching pats = do ...@@ -507,7 +507,7 @@ checkPatternMatching pats = do
(missing, used, nondet) <- processEqs (zip [1..] simplePats) (missing, used, nondet) <- processEqs (zip [1..] simplePats)
-- 3. If any, we report the missing patterns, whereby we re-add the syntactic -- 3. If any, we report the missing patterns, whereby we re-add the syntactic
-- sugar removed in step (1) for a more precise output. -- sugar removed in step (1) for a more precise output.
let nonExhaustive = tidyExhaustivePats missing nonExhaustive <- mapM tidyExhaustivePats missing
let overlap = [ eqn | (i, eqn) <- zip [1..] pats, i `IntSet.notMember` used] let overlap = [ eqn | (i, eqn) <- zip [1..] pats, i `IntSet.notMember` used]
return (nonExhaustive , overlap, nondet) return (nonExhaustive , overlap, nondet)
...@@ -690,22 +690,24 @@ processVars eqs@((n, _) : _) = do ...@@ -690,22 +690,24 @@ processVars eqs@((n, _) : _) = do
getUnusedCons :: [QualIdent] -> WCM [DataConstr] getUnusedCons :: [QualIdent] -> WCM [DataConstr]
getUnusedCons [] = internalError "Checks.WarnCheck.getUnusedCons" getUnusedCons [] = internalError "Checks.WarnCheck.getUnusedCons"
getUnusedCons qs@(q:_) = do getUnusedCons qs@(q:_) = do
allCons <- getConTy q >>= getTyCons . arrowBase allCons <- getConTy q >>= getTyCons q . arrowBase
return [ c | c@(DataConstr q' _ _) <- allCons, q' `notElem` map unqualify qs] return [ c | c@(DataConstr q' _ _) <- allCons, q' `notElem` map unqualify qs]
-- |Retrieve the type of a given constructor. -- |Retrieve the type of a given constructor.
getConTy :: QualIdent -> WCM Type getConTy :: QualIdent -> WCM Type
getConTy q = do getConTy q = do
tyEnv <- gets valueEnv tyEnv <- gets valueEnv
tcEnv <- gets tyConsEnv
return $ case qualLookupValue q tyEnv of return $ case qualLookupValue q tyEnv of
[DataConstructor _ _ (ForAllExist _ _ ty)] -> ty [DataConstructor _ _ (ForAllExist _ _ ty)] -> ty
[NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty [NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty
_ -> _ -> case qualLookupTC q tcEnv of
internalError $ "Checks.WarnCheck.getConTy: " ++ show q [AliasType _ _ ty] -> ty
_ -> internalError $ "Checks.WarnCheck.getConTy: " ++ show q
-- |Retrieve all constructors of a given type. -- |Retrieve all constructors of a given type.
getTyCons :: Type -> WCM [DataConstr] getTyCons :: QualIdent -> Type -> WCM [DataConstr]
getTyCons (TypeConstructor tc _) = do getTyCons _ (TypeConstructor tc _) = do
tc' <- unAlias tc tc' <- unAlias tc
tcEnv <- gets tyConsEnv tcEnv <- gets tyConsEnv
return $ case lookupTC (unqualify tc) tcEnv of return $ case lookupTC (unqualify tc) tcEnv of
...@@ -716,35 +718,48 @@ getTyCons (TypeConstructor tc _) = do ...@@ -716,35 +718,48 @@ getTyCons (TypeConstructor tc _) = do
[RenamingType _ _ nc] -> [nc] [RenamingType _ _ nc] -> [nc]
err -> internalError $ "Checks.WarnCheck.getTyCons: " err -> internalError $ "Checks.WarnCheck.getTyCons: "
++ show tc ++ ' ' : show err ++ '\n' : show tcEnv ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv
getTyCons _ = internalError "Checks.WarnCheck.getTyCons" getTyCons q (TypeRecord fs _) = return [DataConstr (unqualify q) (length fs) (map snd fs)]
getTyCons _ _ = internalError "Checks.WarnCheck.getTyCons"
-- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'. -- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'.
tidyExhaustivePats :: [ExhaustivePats] -> [ExhaustivePats] tidyExhaustivePats :: ExhaustivePats -> WCM ExhaustivePats
tidyExhaustivePats = map (\(xs, ys) -> (map tidyPat xs, ys)) tidyExhaustivePats (xs, ys) = mapM tidyPat xs >>= \xs' -> return (xs', ys)
-- |Resugar a pattern previously desugared at 'simplifyPat', i.e. -- |Resugar a pattern previously desugared at 'simplifyPat', i.e.
-- * Convert a tuple constructor pattern into a tuple pattern -- * Convert a tuple constructor pattern into a tuple pattern
-- * Convert a list constructor pattern representing a finite list -- * Convert a list constructor pattern representing a finite list
-- into a list pattern -- into a list pattern
tidyPat :: Pattern -> Pattern tidyPat :: Pattern -> WCM Pattern
tidyPat p@(LiteralPattern _) = return p
tidyPat p@(VariablePattern _) = return p
tidyPat p@(ConstructorPattern c ps) tidyPat p@(ConstructorPattern c ps)
| isQTupleId c = TuplePattern noRef (map tidyPat ps) | isQTupleId c = TuplePattern noRef `liftM` mapM tidyPat ps
| c == qConsId && isFiniteList p = ListPattern [] (unwrapFinite p) | c == qConsId && isFiniteList p = ListPattern [] `liftM`
| c == qConsId = unwrapInfinite p mapM tidyPat (unwrapFinite p)
| c == qConsId = unwrapInfinite p
| otherwise = do
ty <- getConTy c
case ty of
TypeRecord fs _ -> flip RecordPattern Nothing `liftM`
zipWithM mkFieldPat fs ps
_ -> return p
where where
isFiniteList (ConstructorPattern d [] ) = d == qNilId isFiniteList (ConstructorPattern d [] ) = d == qNilId
isFiniteList (ConstructorPattern d [_, e2]) | d == qConsId = isFiniteList e2 isFiniteList (ConstructorPattern d [_, e2]) | d == qConsId = isFiniteList e2
isFiniteList _ = False isFiniteList _ = False
unwrapFinite (ConstructorPattern _ [] ) = [] unwrapFinite (ConstructorPattern _ [] ) = []
unwrapFinite (ConstructorPattern _ [p1,p2]) = tidyPat p1 : unwrapFinite p2 unwrapFinite (ConstructorPattern _ [p1,p2]) = p1 : unwrapFinite p2
unwrapFinite _ unwrapFinite pat
= internalError "WarnCheck.tidyPat.unwrapFinite" = internalError $ "WarnCheck.tidyPat.unwrapFinite: " ++ show pat
unwrapInfinite (ConstructorPattern d [p1,p2]) = InfixPattern (tidyPat p1) d unwrapInfinite (ConstructorPattern d [p1,p2]) = liftM2 (flip InfixPattern d)
(tidyPat p1)
(unwrapInfinite p2) (unwrapInfinite p2)
unwrapInfinite p0 = p0 unwrapInfinite p0 = return p0
tidyPat p = p
mkFieldPat (f, _) pat = Field NoPos f `liftM` tidyPat pat
tidyPat p = internalError $ "Checks.WarnCheck.tidyPat: " ++ show p
-- |Get the first pattern of a list. -- |Get the first pattern of a list.
firstPat :: EqnInfo -> Pattern firstPat :: EqnInfo -> Pattern
......
{-# LANGUAGE Records #-}
test x = case x of test x = case x of
Just 1 -> True Just 1 -> True
Just 2 -> True Just 2 -> True
...@@ -18,3 +19,7 @@ f "" = 0 ...@@ -18,3 +19,7 @@ f "" = 0
f (_:_) = 1 f (_:_) = 1
g "a" = 0 g "a" = 0
type Record = { list :: [Bool], int :: Int }
rec { list = [] | _ } = 0
Supports Markdown
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