module Language.PureScript.Linter.Exhaustive
( checkExhaustiveExpr
) where
import Prelude
import Protolude (ordNub)
import Control.Applicative
import Control.Arrow (first, second)
import Control.Monad (unless)
import Control.Monad.Writer.Class
import Data.List (foldl', sortOn)
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import qualified Data.Text as T
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Declarations
import Language.PureScript.AST.Literals
import Language.PureScript.Crash
import Language.PureScript.Environment hiding (tyVar)
import Language.PureScript.Errors
import Language.PureScript.Names as P
import Language.PureScript.Pretty.Values (prettyPrintBinderAtom)
import Language.PureScript.Traversals
import Language.PureScript.Types as P
import qualified Language.PureScript.Constants.Prim as C
data RedundancyError = Incomplete | Unknown
qualifyName
:: ProperName a
-> ModuleName
-> Qualified (ProperName b)
-> Qualified (ProperName a)
qualifyName :: forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a
-> ModuleName
-> Qualified (ProperName b)
-> Qualified (ProperName a)
qualifyName ProperName a
n ModuleName
defmn Qualified (ProperName b)
qn = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName a
n
where
(ModuleName
mn, ProperName b
_) = forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
defmn Qualified (ProperName b)
qn
getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [SourceType])]
getConstructors :: Environment
-> ModuleName
-> Qualified (ProperName 'ConstructorName)
-> [(ProperName 'ConstructorName, [SourceType])]
getConstructors Environment
env ModuleName
defmn Qualified (ProperName 'ConstructorName)
n = Maybe (SourceType, TypeKind)
-> [(ProperName 'ConstructorName, [SourceType])]
extractConstructors Maybe (SourceType, TypeKind)
lnte
where
extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])]
extractConstructors :: Maybe (SourceType, TypeKind)
-> [(ProperName 'ConstructorName, [SourceType])]
extractConstructors (Just (SourceType
_, DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
_ [(ProperName 'ConstructorName, [SourceType])]
pt)) = [(ProperName 'ConstructorName, [SourceType])]
pt
extractConstructors Maybe (SourceType, TypeKind)
_ = forall a. HasCallStack => [Char] -> a
internalError [Char]
"Data name not in the scope of the current environment in extractConstructors"
lnte :: Maybe (SourceType, TypeKind)
lnte :: Maybe (SourceType, TypeKind)
lnte = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'TypeName)
qpn (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)
qpn :: Qualified (ProperName 'TypeName)
qpn :: Qualified (ProperName 'TypeName)
qpn = Qualified (ProperName 'ConstructorName)
-> Qualified (ProperName 'TypeName)
getConsDataName Qualified (ProperName 'ConstructorName)
n
getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)
getConsDataName :: Qualified (ProperName 'ConstructorName)
-> Qualified (ProperName 'TypeName)
getConsDataName Qualified (ProperName 'ConstructorName)
con =
case Qualified (ProperName 'ConstructorName)
-> Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
getConsInfo Qualified (ProperName 'ConstructorName)
con of
Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
Nothing -> forall a. HasCallStack => [Char] -> a
internalError forall a b. (a -> b) -> a -> b
$ [Char]
"Constructor " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ConstructorName)
con) forall a. [a] -> [a] -> [a]
++ [Char]
" not in the scope of the current environment in getConsDataName."
Just (DataDeclType
_, ProperName 'TypeName
pm, SourceType
_, [Ident]
_) -> forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a
-> ModuleName
-> Qualified (ProperName b)
-> Qualified (ProperName a)
qualifyName ProperName 'TypeName
pm ModuleName
defmn Qualified (ProperName 'ConstructorName)
con
getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
getConsInfo :: Qualified (ProperName 'ConstructorName)
-> Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
getConsInfo Qualified (ProperName 'ConstructorName)
con = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ConstructorName)
con (Environment
-> Map
(Qualified (ProperName 'ConstructorName))
(DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env)
initialize :: Int -> [Binder]
initialize :: Int -> [Binder]
initialize Int
l = forall a. Int -> a -> [a]
replicate Int
l Binder
NullBinder
genericMerge :: Ord a =>
(a -> Maybe b -> Maybe c -> d) ->
[(a, b)] ->
[(a, c)] ->
[d]
genericMerge :: forall a b c d.
Ord a =>
(a -> Maybe b -> Maybe c -> d) -> [(a, b)] -> [(a, c)] -> [d]
genericMerge a -> Maybe b -> Maybe c -> d
_ [] [] = []
genericMerge a -> Maybe b -> Maybe c -> d
f [(a, b)]
bs [] = forall a b. (a -> b) -> [a] -> [b]
map (\(a
s, b
b) -> a -> Maybe b -> Maybe c -> d
f a
s (forall a. a -> Maybe a
Just b
b) forall a. Maybe a
Nothing) [(a, b)]
bs
genericMerge a -> Maybe b -> Maybe c -> d
f [] [(a, c)]
bs = forall a b. (a -> b) -> [a] -> [b]
map (\(a
s, c
b) -> a -> Maybe b -> Maybe c -> d
f a
s forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just c
b)) [(a, c)]
bs
genericMerge a -> Maybe b -> Maybe c -> d
f bsl :: [(a, b)]
bsl@((a
s, b
b):[(a, b)]
bs) bsr :: [(a, c)]
bsr@((a
s', c
b'):[(a, c)]
bs')
| a
s forall a. Ord a => a -> a -> Bool
< a
s' = a -> Maybe b -> Maybe c -> d
f a
s (forall a. a -> Maybe a
Just b
b) forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: forall a b c d.
Ord a =>
(a -> Maybe b -> Maybe c -> d) -> [(a, b)] -> [(a, c)] -> [d]
genericMerge a -> Maybe b -> Maybe c -> d
f [(a, b)]
bs [(a, c)]
bsr
| a
s forall a. Ord a => a -> a -> Bool
> a
s' = a -> Maybe b -> Maybe c -> d
f a
s' forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just c
b') forall a. a -> [a] -> [a]
: forall a b c d.
Ord a =>
(a -> Maybe b -> Maybe c -> d) -> [(a, b)] -> [(a, c)] -> [d]
genericMerge a -> Maybe b -> Maybe c -> d
f [(a, b)]
bsl [(a, c)]
bs'
| Bool
otherwise = a -> Maybe b -> Maybe c -> d
f a
s (forall a. a -> Maybe a
Just b
b) (forall a. a -> Maybe a
Just c
b') forall a. a -> [a] -> [a]
: forall a b c d.
Ord a =>
(a -> Maybe b -> Maybe c -> d) -> [(a, b)] -> [(a, c)] -> [d]
genericMerge a -> Maybe b -> Maybe c -> d
f [(a, b)]
bs [(a, c)]
bs'
missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)
missingCasesSingle :: Environment
-> ModuleName
-> Binder
-> Binder
-> ([Binder], Either RedundancyError Bool)
missingCasesSingle Environment
_ ModuleName
_ Binder
_ Binder
NullBinder = ([], forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
missingCasesSingle Environment
_ ModuleName
_ Binder
_ (VarBinder SourceSpan
_ Ident
_) = ([], forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
missingCasesSingle Environment
env ModuleName
mn (VarBinder SourceSpan
_ Ident
_) Binder
b = Environment
-> ModuleName
-> Binder
-> Binder
-> ([Binder], Either RedundancyError Bool)
missingCasesSingle Environment
env ModuleName
mn Binder
NullBinder Binder
b
missingCasesSingle Environment
env ModuleName
mn Binder
br (NamedBinder SourceSpan
_ Ident
_ Binder
bl) = Environment
-> ModuleName
-> Binder
-> Binder
-> ([Binder], Either RedundancyError Bool)
missingCasesSingle Environment
env ModuleName
mn Binder
br Binder
bl
missingCasesSingle Environment
env ModuleName
mn Binder
NullBinder cb :: Binder
cb@(ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
con [Binder]
_) =
(forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Binder
cp -> forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Environment
-> ModuleName
-> Binder
-> Binder
-> ([Binder], Either RedundancyError Bool)
missingCasesSingle Environment
env ModuleName
mn Binder
cp Binder
cb) [Binder]
allPatterns, forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
where
allPatterns :: [Binder]
allPatterns = forall a b. (a -> b) -> [a] -> [b]
map (\(ProperName 'ConstructorName
p, [SourceType]
t) -> SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a
-> ModuleName
-> Qualified (ProperName b)
-> Qualified (ProperName a)
qualifyName ProperName 'ConstructorName
p ModuleName
mn Qualified (ProperName 'ConstructorName)
con) (Int -> [Binder]
initialize forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
t))
forall a b. (a -> b) -> a -> b
$ Environment
-> ModuleName
-> Qualified (ProperName 'ConstructorName)
-> [(ProperName 'ConstructorName, [SourceType])]
getConstructors Environment
env ModuleName
mn Qualified (ProperName 'ConstructorName)
con
missingCasesSingle Environment
env ModuleName
mn cb :: Binder
cb@(ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
con [Binder]
bs) (ConstructorBinder SourceSpan
_ Qualified (ProperName 'ConstructorName)
con' [Binder]
bs')
| Qualified (ProperName 'ConstructorName)
con forall a. Eq a => a -> a -> Bool
== Qualified (ProperName 'ConstructorName)
con' = let ([[Binder]]
bs'', Either RedundancyError Bool
pr) = Environment
-> ModuleName
-> [Binder]
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple Environment
env ModuleName
mn [Binder]
bs [Binder]
bs' in (forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
con) [[Binder]]
bs'', Either RedundancyError Bool
pr)
| Bool
otherwise = ([Binder
cb], forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
missingCasesSingle Environment
env ModuleName
mn Binder
NullBinder (LiteralBinder SourceSpan
ss (ObjectLiteral [(PSString, Binder)]
bs)) =
(forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan -> Literal Binder -> Binder
LiteralBinder SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PSString, Binder)]
bs)) [[Binder]]
allMisses, Either RedundancyError Bool
pr)
where
([[Binder]]
allMisses, Either RedundancyError Bool
pr) = Environment
-> ModuleName
-> [Binder]
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple Environment
env ModuleName
mn (Int -> [Binder]
initialize forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PSString, Binder)]
bs) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PSString, Binder)]
bs)
missingCasesSingle Environment
env ModuleName
mn (LiteralBinder SourceSpan
_ (ObjectLiteral [(PSString, Binder)]
bs)) (LiteralBinder SourceSpan
ss (ObjectLiteral [(PSString, Binder)]
bs')) =
(forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan -> Literal Binder -> Binder
LiteralBinder SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [PSString]
sortedNames) [[Binder]]
allMisses, Either RedundancyError Bool
pr)
where
([[Binder]]
allMisses, Either RedundancyError Bool
pr) = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Environment
-> ModuleName
-> [Binder]
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple Environment
env ModuleName
mn) (forall a b. [(a, b)] -> ([a], [b])
unzip [(Binder, Binder)]
binders)
sortNames :: [(PSString, b)] -> [(PSString, b)]
sortNames = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst
([(PSString, Binder)]
sbs, [(PSString, Binder)]
sbs') = (forall {b}. [(PSString, b)] -> [(PSString, b)]
sortNames [(PSString, Binder)]
bs, forall {b}. [(PSString, b)] -> [(PSString, b)]
sortNames [(PSString, Binder)]
bs')
compB :: a -> Maybe a -> Maybe a -> (a, a)
compB :: forall a. a -> Maybe a -> Maybe a -> (a, a)
compB a
e Maybe a
b Maybe a
b' = (Maybe a -> a
fm Maybe a
b, Maybe a -> a
fm Maybe a
b')
where
fm :: Maybe a -> a
fm = forall a. a -> Maybe a -> a
fromMaybe a
e
compBS :: b -> a -> Maybe b -> Maybe b -> (a, (b, b))
compBS :: forall b a. b -> a -> Maybe b -> Maybe b -> (a, (b, b))
compBS b
e a
s Maybe b
b Maybe b
b' = (a
s, forall a. a -> Maybe a -> Maybe a -> (a, a)
compB b
e Maybe b
b Maybe b
b')
([PSString]
sortedNames, [(Binder, Binder)]
binders) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b c d.
Ord a =>
(a -> Maybe b -> Maybe c -> d) -> [(a, b)] -> [(a, c)] -> [d]
genericMerge (forall b a. b -> a -> Maybe b -> Maybe b -> (a, (b, b))
compBS Binder
NullBinder) [(PSString, Binder)]
sbs [(PSString, Binder)]
sbs'
missingCasesSingle Environment
_ ModuleName
_ Binder
NullBinder (LiteralBinder SourceSpan
ss (BooleanLiteral Bool
b)) = ([SourceSpan -> Literal Binder -> Binder
LiteralBinder SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> Literal a
BooleanLiteral forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b], forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
missingCasesSingle Environment
_ ModuleName
_ (LiteralBinder SourceSpan
ss (BooleanLiteral Bool
bl)) (LiteralBinder SourceSpan
_ (BooleanLiteral Bool
br))
| Bool
bl forall a. Eq a => a -> a -> Bool
== Bool
br = ([], forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
| Bool
otherwise = ([SourceSpan -> Literal Binder -> Binder
LiteralBinder SourceSpan
ss forall a b. (a -> b) -> a -> b
$ forall a. Bool -> Literal a
BooleanLiteral Bool
bl], forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
missingCasesSingle Environment
env ModuleName
mn Binder
b (PositionedBinder SourceSpan
_ [Comment]
_ Binder
cb) = Environment
-> ModuleName
-> Binder
-> Binder
-> ([Binder], Either RedundancyError Bool)
missingCasesSingle Environment
env ModuleName
mn Binder
b Binder
cb
missingCasesSingle Environment
env ModuleName
mn Binder
b (TypedBinder SourceType
_ Binder
cb) = Environment
-> ModuleName
-> Binder
-> Binder
-> ([Binder], Either RedundancyError Bool)
missingCasesSingle Environment
env ModuleName
mn Binder
b Binder
cb
missingCasesSingle Environment
_ ModuleName
_ Binder
b Binder
_ = ([Binder
b], forall a b. a -> Either a b
Left RedundancyError
Unknown)
missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple :: Environment
-> ModuleName
-> [Binder]
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple Environment
env ModuleName
mn = [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
go
where
go :: [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
go (Binder
x:[Binder]
xs) (Binder
y:[Binder]
ys) = (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
: [Binder]
xs) [Binder]
miss1 forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Binder
x forall a. a -> [a] -> [a]
:) [[Binder]]
miss2, forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) Either RedundancyError Bool
pr1 Either RedundancyError Bool
pr2)
where
([Binder]
miss1, Either RedundancyError Bool
pr1) = Environment
-> ModuleName
-> Binder
-> Binder
-> ([Binder], Either RedundancyError Bool)
missingCasesSingle Environment
env ModuleName
mn Binder
x Binder
y
([[Binder]]
miss2, Either RedundancyError Bool
pr2) = [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
go [Binder]
xs [Binder]
ys
go [Binder]
_ [Binder]
_ = ([], forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
isExhaustiveGuard :: Environment -> ModuleName -> [GuardedExpr] -> Bool
isExhaustiveGuard :: Environment -> ModuleName -> [GuardedExpr] -> Bool
isExhaustiveGuard Environment
_ ModuleName
_ [MkUnguarded Expr
_] = Bool
True
isExhaustiveGuard Environment
env ModuleName
moduleName [GuardedExpr]
gs =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(GuardedExpr [Guard]
grd Expr
_) -> [Guard] -> Bool
isExhaustive [Guard]
grd) [GuardedExpr]
gs
where
isExhaustive :: [Guard] -> Bool
isExhaustive :: [Guard] -> Bool
isExhaustive = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Guard -> Bool
checkGuard
checkGuard :: Guard -> Bool
checkGuard :: Guard -> Bool
checkGuard (ConditionGuard Expr
cond) = Expr -> Bool
isTrueExpr Expr
cond
checkGuard (PatternGuard Binder
binder Expr
_) =
case Environment
-> ModuleName
-> [Binder]
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple Environment
env ModuleName
moduleName [Binder
NullBinder] [Binder
binder] of
([], Either RedundancyError Bool
_) -> Bool
True
([[Binder]], Either RedundancyError Bool)
_ -> Bool
False
missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)
missingCases :: Environment
-> ModuleName
-> [Binder]
-> CaseAlternative
-> ([[Binder]], Either RedundancyError Bool)
missingCases Environment
env ModuleName
mn [Binder]
uncovered CaseAlternative
ca = Environment
-> ModuleName
-> [Binder]
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple Environment
env ModuleName
mn [Binder]
uncovered (CaseAlternative -> [Binder]
caseAlternativeBinders CaseAlternative
ca)
missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
missingAlternative :: Environment
-> ModuleName
-> CaseAlternative
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingAlternative Environment
env ModuleName
mn CaseAlternative
ca [Binder]
uncovered
| Environment -> ModuleName -> [GuardedExpr] -> Bool
isExhaustiveGuard Environment
env ModuleName
mn (CaseAlternative -> [GuardedExpr]
caseAlternativeResult CaseAlternative
ca) = ([[Binder]], Either RedundancyError Bool)
mcases
| Bool
otherwise = ([[Binder]
uncovered], forall a b. (a, b) -> b
snd ([[Binder]], Either RedundancyError Bool)
mcases)
where
mcases :: ([[Binder]], Either RedundancyError Bool)
mcases = Environment
-> ModuleName
-> [Binder]
-> CaseAlternative
-> ([[Binder]], Either RedundancyError Bool)
missingCases Environment
env ModuleName
mn [Binder]
uncovered CaseAlternative
ca
checkExhaustive
:: forall m
. MonadWriter MultipleErrors m
=> SourceSpan
-> Environment
-> ModuleName
-> Int
-> [CaseAlternative]
-> Expr
-> m Expr
checkExhaustive :: forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan
-> Environment
-> ModuleName
-> Int
-> [CaseAlternative]
-> Expr
-> m Expr
checkExhaustive SourceSpan
ss Environment
env ModuleName
mn Int
numArgs [CaseAlternative]
cas Expr
expr = ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr
makeResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
-> CaseAlternative
-> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
step ([Int -> [Binder]
initialize Int
numArgs], (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True, [])) [CaseAlternative]
cas
where
step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
-> CaseAlternative
-> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
step ([[Binder]]
uncovered, (Either RedundancyError Bool
nec, [[Binder]]
redundant)) CaseAlternative
ca =
let ([[[Binder]]]
missed, [Either RedundancyError Bool]
pr) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map (Environment
-> ModuleName
-> CaseAlternative
-> [Binder]
-> ([[Binder]], Either RedundancyError Bool)
missingAlternative Environment
env ModuleName
mn CaseAlternative
ca) [[Binder]]
uncovered)
([[Binder]]
missed', [[Binder]]
approx) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
10000 (forall a. Ord a => [a] -> [a]
ordNub (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Binder]]]
missed))
cond :: Either RedundancyError Bool
cond = forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Either RedundancyError Bool]
pr
in ([[Binder]]
missed', ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Binder]]
approx
then forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) Either RedundancyError Bool
cond Either RedundancyError Bool
nec
else forall a b. a -> Either a b
Left RedundancyError
Incomplete
, if forall (t :: * -> *). Foldable t => t Bool -> Bool
and Either RedundancyError Bool
cond
then [[Binder]]
redundant
else CaseAlternative -> [Binder]
caseAlternativeBinders CaseAlternative
ca forall a. a -> [a] -> [a]
: [[Binder]]
redundant
)
)
makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr
makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr
makeResult ([[Binder]]
bss, (Either RedundancyError Bool
rr, [[Binder]]
bss')) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Binder]]
bss') m ()
tellRedundant
case Either RedundancyError Bool
rr of
Left RedundancyError
Incomplete -> m ()
tellIncomplete
Either RedundancyError Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Binder]]
bss
then Expr
expr
else ([[Binder]], Bool) -> Expr -> Expr
addPartialConstraint (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 [[Binder]]
bss)) Expr
expr
where
tellRedundant :: m ()
tellRedundant = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [[Binder]] -> Bool -> SimpleErrorMessage
OverlappingPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 forall a b. (a -> b) -> a -> b
$ [[Binder]]
bss'
tellIncomplete :: m ()
tellIncomplete = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage
IncompleteExhaustivityCheck
addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr
addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr
addPartialConstraint ([[Binder]]
bss, Bool
complete) Expr
e =
Bool -> Expr -> SourceType -> Expr
TypedValue Bool
True Expr
e forall a b. (a -> b) -> a -> b
$
SourceConstraint -> SourceType -> SourceType
srcConstrainedType (Qualified (ProperName 'ClassName)
-> [SourceType]
-> [SourceType]
-> Maybe ConstraintData
-> SourceConstraint
srcConstraint Qualified (ProperName 'ClassName)
C.Partial [] [] (forall a. a -> Maybe a
Just ConstraintData
constraintData)) forall a b. (a -> b) -> a -> b
$ forall a. a -> WildcardData -> Type a
TypeWildcard SourceAnn
NullSourceAnn WildcardData
IgnoredWildcard
where
constraintData :: ConstraintData
constraintData :: ConstraintData
constraintData =
[[Text]] -> Bool -> ConstraintData
PartialConstraintData (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Binder -> Text
prettyPrintBinderAtom) [[Binder]]
bss) Bool
complete
checkExhaustiveExpr
:: forall m
. MonadWriter MultipleErrors m
=> SourceSpan
-> Environment
-> ModuleName
-> Expr
-> m Expr
checkExhaustiveExpr :: forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan -> Environment -> ModuleName -> Expr -> m Expr
checkExhaustiveExpr SourceSpan
initSS Environment
env ModuleName
mn = SourceSpan -> Expr -> m Expr
onExpr SourceSpan
initSS
where
onDecl :: Declaration -> m Declaration
onDecl :: Declaration -> m Declaration
onDecl (BindingGroupDeclaration NonEmpty ((SourceAnn, Ident), NameKind, Expr)
bs) = NonEmpty ((SourceAnn, Ident), NameKind, Expr) -> Declaration
BindingGroupDeclaration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(sai :: (SourceAnn, Ident)
sai@((SourceSpan
ss, [Comment]
_), Ident
_), NameKind
nk, Expr
expr) -> ((SourceAnn, Ident)
sai, NameKind
nk,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
expr) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
bs
onDecl (ValueDecl sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
name NameKind
x [Binder]
y [MkUnguarded Expr
e]) =
SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name NameKind
x [Binder]
y forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [GuardedExpr]
mkUnguardedExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Ident -> ErrorMessageHint
ErrorInValueDeclaration Ident
name)) (SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e)
onDecl Declaration
decl = forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
decl
onExpr :: SourceSpan -> Expr -> m Expr
onExpr :: SourceSpan -> Expr -> m Expr
onExpr SourceSpan
_ (UnaryMinus SourceSpan
ss Expr
e) = SourceSpan -> Expr -> Expr
UnaryMinus SourceSpan
ss forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e
onExpr SourceSpan
_ (Literal SourceSpan
ss (ArrayLiteral [Expr]
es)) = SourceSpan -> Literal Expr -> Expr
Literal SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Literal a
ArrayLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss) [Expr]
es
onExpr SourceSpan
_ (Literal SourceSpan
ss (ObjectLiteral [(PSString, Expr)]
es)) = SourceSpan -> Literal Expr -> Expr
Literal SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM (SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss)) [(PSString, Expr)]
es
onExpr SourceSpan
ss (Accessor PSString
x Expr
e) = PSString -> Expr -> Expr
Accessor PSString
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e
onExpr SourceSpan
ss (ObjectUpdate Expr
o [(PSString, Expr)]
es) = Expr -> [(PSString, Expr)] -> Expr
ObjectUpdate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM (SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss)) [(PSString, Expr)]
es
onExpr SourceSpan
ss (Abs Binder
x Expr
e) = Binder -> Expr -> Expr
Abs Binder
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e
onExpr SourceSpan
ss (App Expr
e1 Expr
e2) = Expr -> Expr -> Expr
App forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e2
onExpr SourceSpan
ss (IfThenElse Expr
e1 Expr
e2 Expr
e3) = Expr -> Expr -> Expr -> Expr
IfThenElse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e3
onExpr SourceSpan
ss (Case [Expr]
es [CaseAlternative]
cas) = do
Expr
case' <- [Expr] -> [CaseAlternative] -> Expr
Case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss) [Expr]
es forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SourceSpan -> CaseAlternative -> m CaseAlternative
onCaseAlternative SourceSpan
ss) [CaseAlternative]
cas
forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan
-> Environment
-> ModuleName
-> Int
-> [CaseAlternative]
-> Expr
-> m Expr
checkExhaustive SourceSpan
ss Environment
env ModuleName
mn (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
es) [CaseAlternative]
cas Expr
case'
onExpr SourceSpan
ss (TypedValue Bool
x Expr
e SourceType
y) = Bool -> Expr -> SourceType -> Expr
TypedValue Bool
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SourceType
y
onExpr SourceSpan
ss (Let WhereProvenance
w [Declaration]
ds Expr
e) = WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
w forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> m Declaration
onDecl [Declaration]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e
onExpr SourceSpan
_ (PositionedValue SourceSpan
ss [Comment]
x Expr
e) = SourceSpan -> [Comment] -> Expr -> Expr
PositionedValue SourceSpan
ss [Comment]
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e
onExpr SourceSpan
_ Expr
expr = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
expr
onCaseAlternative :: SourceSpan -> CaseAlternative -> m CaseAlternative
onCaseAlternative :: SourceSpan -> CaseAlternative -> m CaseAlternative
onCaseAlternative SourceSpan
ss (CaseAlternative [Binder]
x [MkUnguarded Expr
e]) = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [GuardedExpr]
mkUnguardedExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
e
onCaseAlternative SourceSpan
ss (CaseAlternative [Binder]
x [GuardedExpr]
es) = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SourceSpan -> GuardedExpr -> m GuardedExpr
onGuardedExpr SourceSpan
ss) [GuardedExpr]
es
onGuardedExpr :: SourceSpan -> GuardedExpr -> m GuardedExpr
onGuardedExpr :: SourceSpan -> GuardedExpr -> m GuardedExpr
onGuardedExpr SourceSpan
ss (GuardedExpr [Guard]
guard Expr
rhs) = [Guard] -> Expr -> GuardedExpr
GuardedExpr [Guard]
guard forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Expr -> m Expr
onExpr SourceSpan
ss Expr
rhs
mkUnguardedExpr :: Expr -> [GuardedExpr]
mkUnguardedExpr = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> GuardedExpr
MkUnguarded