diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2019-04-09 15:09:29 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-04-14 08:49:23 -0400 |
| commit | e7cad16c19fb226353d3fb6e92914ed953d32857 (patch) | |
| tree | d92844fc8e68c082489d42aba5ff2e1b096f4ccf /compiler | |
| parent | d2271fe4e841cc157385bfc9ee498a0bf805f250 (diff) | |
| download | haskell-e7cad16c19fb226353d3fb6e92914ed953d32857.tar.gz | |
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.
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 9 |
1 files 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 |