@@ -46,8 +46,6 @@ import Language.PureScript.Kinds
46import Language.PureScript.Types as P
46import Language.PureScript.Types as P
47import Language.PureScript.Errors
47import Language.PureScript.Errors
49−import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)
51-- | There are two modes of failure for the redudancy check:
49-- | There are two modes of failure for the redudancy check:
53-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.
51-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.
@@ -273,25 +271,36 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init
273-- Exhaustivity checking over a list of declarations
271-- Exhaustivity checking over a list of declarations
275checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
273checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
276−checkExhaustiveDecls env mn ds =
274+checkExhaustiveDecls env mn = mapM_ onDecl
277− let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
275+ where
276+ onDecl :: Declaration -> m ()
277+ onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs
279+ convert :: (Ident, NameKind, Expr) -> Declaration
280+ convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
281+ onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)
282+ onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
283+ onDecl _ = return ()
279− f' :: Declaration -> m Declaration
285+ onExpr :: Expr -> m ()
280− f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d
286+ onExpr (UnaryMinus e) = onExpr e
281− where
287+ onExpr (ArrayLiteral es) = mapM_ onExpr es
282− convert :: (Ident, NameKind, Expr) -> Declaration
288+ onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
283− convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
289+ onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
284− f' d@(ValueDeclaration name _ _ _) = censor (addHint (ErrorInValueDeclaration name)) $ f d
290+ onExpr (Accessor _ e) = onExpr e
291+ onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es
292+ onExpr (Abs _ e) = onExpr e
293+ onExpr (App e1 e2) = onExpr e1 >> onExpr e2
294+ onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3
295+ onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onCaseAlternative cas
296+ onExpr (TypedValue _ e _) = onExpr e
297+ onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e
285− f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (addHint (PositionedError pos)) (f' dec)
298+ onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
286− -- Don't generate two warnings for desugared dictionaries.
299+ onExpr _ = return ()
287− f' d@TypeInstanceDeclaration{} = return d
290− in mapM_ f' ds
301+ onCaseAlternative :: CaseAlternative -> m ()
291− where
302+ onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
292− checkExpr :: Expr -> m Expr
303+ onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
293− checkExpr c@(Case expr cas) = checkExhaustive env mn (length expr) cas >> return c
294− checkExpr other = return other
297-- Exhaustivity checking over a single module
306-- Exhaustivity checking over a single module