module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where
import Prelude ()
import Prelude.Compat
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.List (foldl', sortBy, nub)
import Data.Function (on)
import Control.Monad (unless)
import Control.Applicative
import Control.Arrow (first, second)
import Control.Monad.Writer.Class
import Language.PureScript.Crash
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Declarations
import Language.PureScript.Environment
import Language.PureScript.Names as P
import Language.PureScript.Kinds
import Language.PureScript.Types as P
import Language.PureScript.Errors
data RedundancyError = Incomplete | Unknown
qualifyName
:: (ProperName a)
-> ModuleName
-> Qualified (ProperName b)
-> Qualified (ProperName a)
qualifyName n defmn qn = Qualified (Just mn) n
where
(mn, _) = qualify defmn qn
getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])]
getConstructors env defmn n = extractConstructors lnte
where
extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]
extractConstructors (Just (_, DataType _ pt)) = pt
extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
lnte :: Maybe (Kind, TypeKind)
lnte = M.lookup qpn (types env)
qpn :: Qualified (ProperName 'TypeName)
qpn = getConsDataName n
getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)
getConsDataName con =
case getConsInfo con of
Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."
Just (_, pm, _, _) -> qualifyName pm defmn con
getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])
getConsInfo con = M.lookup con (dataConstructors env)
initialize :: Int -> [Binder]
initialize l = replicate l NullBinder
genericMerge :: Ord a =>
(a -> Maybe b -> Maybe c -> d) ->
[(a, b)] ->
[(a, c)] ->
[d]
genericMerge _ [] [] = []
genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs
genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs
genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
| s < s' = f s (Just b) Nothing : genericMerge f bs bsr
| s > s' = f s' Nothing (Just b') : genericMerge f bsl bs'
| otherwise = f s (Just b) (Just b') : genericMerge f bs bs'
missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)
missingCasesSingle _ _ _ NullBinder = ([], return True)
missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl
missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =
(concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True)
where
allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))
$ getConstructors env mn con
missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')
| con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)
| otherwise = ([cb], return False)
missingCasesSingle env mn NullBinder (ObjectBinder bs) =
(map (ObjectBinder . zip (map fst bs)) allMisses, pr)
where
(allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)
missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
(map (ObjectBinder . zip sortedNames) allMisses, pr)
where
(allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)
sortNames = sortBy (compare `on` fst)
(sbs, sbs') = (sortNames bs, sortNames bs')
compB :: a -> Maybe a -> Maybe a -> (a, a)
compB e b b' = (fm b, fm b')
where
fm = fromMaybe e
compBS :: Eq a => b -> a -> Maybe b -> Maybe b -> (a, (b, b))
compBS e s b b' = (s, compB e b b')
(sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)
missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)
| bl == br = ([], return True)
| otherwise = ([BooleanBinder bl], return False)
missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb
missingCasesSingle _ _ b _ = ([b], Left Unknown)
missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple env mn = go
where
go [] [] = ([], pure True)
go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2)
where
(miss1, pr1) = missingCasesSingle env mn x y
(miss2, pr2) = go xs ys
go _ _ = internalError "Argument lengths did not match in missingCasesMultiple."
isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool
isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
where
isOtherwise :: Expr -> Bool
isOtherwise (TypedValue _ (BooleanLiteral True) _) = True
isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True
isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True
isOtherwise _ = False
isExhaustiveGuard (Right _) = True
missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)
missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
missingAlternative env mn ca uncovered
| isExhaustiveGuard (caseAlternativeResult ca) = mcases
| otherwise = ([uncovered], snd mcases)
where
mcases = missingCases env mn uncovered ca
checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
where
step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
step (uncovered, (nec, redundant)) ca =
let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
(missed', approx) = splitAt 10000 (nub (concat missed))
cond = or <$> sequenceA pr
in (missed', ( if null approx
then liftA2 (&&) cond nec
else Left Incomplete
, if either (const True) id cond
then redundant
else caseAlternativeBinders ca : redundant
)
)
makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()
makeResult (bss, (rr, bss')) =
do unless (hasConstraint || null bss) tellNonExhaustive
unless (null bss') tellRedundant
case rr of
Left Incomplete -> unless hasConstraint tellIncomplete
_ -> return ()
where
tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
checkExhaustiveDecls env mn = mapM_ onDecl
where
onDecl :: Declaration -> m ()
onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs
where
convert :: (Ident, NameKind, Expr) -> Declaration
convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e)
onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
onDecl _ = return ()
onExpr :: Bool -> Expr -> m ()
onExpr isP (UnaryMinus e) = onExpr isP e
onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es
onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es
onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e
onExpr isP (Accessor _ e) = onExpr isP e
onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es
onExpr isP (Abs _ e) = onExpr isP e
onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2
onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3
onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas
onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e
onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e
onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)
onExpr _ _ = return ()
onCaseAlternative :: Bool -> CaseAlternative -> m ()
onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es
onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e
hasPartialConstraint :: Type -> Bool
hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs
where
go :: Qualified (ProperName 'ClassName) -> Bool
go qname
| qname == partialClass = True
| otherwise =
case qname `M.lookup` typeClasses env of
Just ([], _, cs') -> any (go . fst) cs'
_ -> False
partialClass :: Qualified (ProperName 'ClassName)
partialClass = primName "Partial"
hasPartialConstraint _ = False
checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds