module Language.PureScript.Linter.Exhaustive
( checkExhaustive
, checkExhaustiveModule
) where
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.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
import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)
qualifyName :: a -> ModuleName -> Qualified a -> Qualified a
qualifyName n defmn qn = Qualified (Just mn) n
where
(mn, _) = qualify defmn qn
getConstructors :: Environment -> ModuleName -> (Qualified ProperName) -> [(ProperName, [Type])]
getConstructors env defmn n = extractConstructors lnte
where
qpn :: Qualified ProperName
qpn = getConsDataName n
getConsDataName :: (Qualified ProperName) -> (Qualified ProperName)
getConsDataName con = qualifyName nm defmn con
where
nm = case getConsInfo con of
Nothing -> error $ "ProperName " ++ show con ++ " not in the scope of the current environment in getConsDataName."
Just (_, pm, _, _) -> pm
getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident])
getConsInfo con = M.lookup con dce
where
dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
dce = dataConstructors env
lnte :: Maybe (Kind, TypeKind)
lnte = M.lookup qpn (types env)
extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]
extractConstructors (Just (_, DataType _ pt)) = pt
extractConstructors _ = error "Data name not in the scope of the current environment in extractConstructors"
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], Maybe Bool)
missingCasesSingle _ _ _ NullBinder = ([], Just True)
missingCasesSingle _ _ _ (VarBinder _) = ([], Just 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, Just 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], Just 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], Just True)
missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)
| bl == br = ([], Just True)
| otherwise = ([BooleanBinder bl], Just False)
missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
missingCasesSingle _ _ b _ = ([b], Nothing)
missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe 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 _ _ = error "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 _ = False
isExhaustiveGuard (Right _) = True
missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool)
missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe 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) => Environment -> ModuleName -> [CaseAlternative] -> m ()
checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (pure True, [])) cas
where
step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]]))
step (uncovered, (nec, redundant)) ca =
let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
cond = or <$> sequenceA pr
in (concat missed, (liftA2 (&&) cond nec,
if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant))
where
sequenceA = foldr (liftA2 (:)) (pure [])
initial :: [Binder]
initial = initialize numArgs
where
numArgs = length . caseAlternativeBinders . head $ cas
makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()
makeResult (bss, (_, bss')) =
do unless (null bss) tellExhaustive
unless (null bss') tellRedundant
where
tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
checkExhaustiveDecls env mn ds =
let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
f' :: Declaration -> m Declaration
f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d
where
convert :: (Ident, NameKind, Expr) -> Declaration
convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
f' d@(ValueDeclaration name _ _ _) = censor (onErrorMessages (ErrorInValueDeclaration name)) $ f d
f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (onErrorMessages (PositionedError pos)) (f' dec)
f' d@TypeInstanceDeclaration{} = return d
f' d = f d
in mapM_ f' ds
where
checkExpr :: Expr -> m Expr
checkExpr c@(Case _ cas) = checkExhaustive env mn cas >> return c
checkExpr other = return other
checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
checkExhaustiveModule env (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds