@@ -46,8 +46,6 @@ import Language.PureScript.Kinds
4646import Language.PureScript.Types as P
4747import Language.PureScript.Errors
4848
49−import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)
50−
5149-- | There are two modes of failure for the redudancy check:
5250--
5351-- 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
273271-- Exhaustivity checking over a list of declarations
274272--
275273checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
276−checkExhaustiveDecls env mn ds =
277− let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
274+checkExhaustiveDecls env mn = mapM_ onDecl
275+ where
276+ onDecl :: Declaration -> m ()
277+ onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs
278+ where
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 ()
278284
279− f' :: Declaration -> m Declaration
280− f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d
281− where
282− convert :: (Ident, NameKind, Expr) -> Declaration
283− convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
284− f' d@(ValueDeclaration name _ _ _) = censor (addHint (ErrorInValueDeclaration name)) $ f d
285− f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (addHint (PositionedError pos)) (f' dec)
286− -- Don't generate two warnings for desugared dictionaries.
287− f' d@TypeInstanceDeclaration{} = return d
288− f' d = f d
285+ onExpr :: Expr -> m ()
286+ onExpr (UnaryMinus e) = onExpr e
287+ onExpr (ArrayLiteral es) = mapM_ onExpr es
288+ onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
289+ onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
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
298+ onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
299+ onExpr _ = return ()
289300
290− in mapM_ f' ds
291− where
292− checkExpr :: Expr -> m Expr
293− checkExpr c@(Case expr cas) = checkExhaustive env mn (length expr) cas >> return c
294− checkExpr other = return other
301+ onCaseAlternative :: CaseAlternative -> m ()
302+ onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
303+ onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
295304
296305-- |
297306-- Exhaustivity checking over a single module