From e7cad16c19fb226353d3fb6e92914ed953d32857 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Tue, 9 Apr 2019 15:09:29 +0200 Subject: Add a safeguard to Core Lint Lint returns a pair (Maybe a, WarnsAndErrs). The Maybe monad allows to handle an unrecoverable failure. In case of such a failure, the error should be added to the second component of the pair. If this is not done, Lint will silently accept bad programs. This situation actually happened during development of linear types. This adds a safeguard. --- compiler/coreSyn/CoreLint.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 8c85685d29..2210716fd5 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -2080,7 +2080,7 @@ defaultLintFlags = LF { lf_check_global_ids = False newtype LintM a = LintM { unLintM :: LintEnv -> - WarnsAndErrs -> -- Error and warning messages so far + WarnsAndErrs -> -- Warning and error messages so far (Maybe a, WarnsAndErrs) } -- Result and messages (if any) type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) @@ -2189,10 +2189,13 @@ data LintLocInfo | InCo Coercion -- Inside a coercion initL :: DynFlags -> LintFlags -> InScopeSet - -> LintM a -> WarnsAndErrs -- Errors and warnings + -> LintM a -> WarnsAndErrs -- Warnings and errors initL dflags flags in_scope m = case unLintM m env (emptyBag, emptyBag) of - (_, errs) -> errs + (Just _, errs) -> errs + (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + "without reporting an error message") empty where env = LE { le_flags = flags , le_subst = mkEmptyTCvSubst in_scope -- cgit v1.2.1