diff options
Diffstat (limited to 'compiler/GHC/Core/Lint.hs')
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 13 |
1 files changed, 7 insertions, 6 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 43c93595df..d14bc633fe 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1277,7 +1277,7 @@ lintTyApp fun_ty arg_ty -- application. lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue - | Just (Scaled w arg_ty', res_ty') <- splitFunTy_maybe fun_ty + | Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty = do { ensureEqTys arg_ty' arg_ty err1 ; let app_ue = addUE fun_ue (scaleUE w arg_ue) ; return (res_ty', app_ue) } @@ -2743,17 +2743,18 @@ ensureSubMult actual_usage described_usage err_msg = do flags <- getLintFlags when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of Submult -> return () - Unknown -> case actual_usage' of - MultMul m1 m2 -> ensureSubMult m1 described_usage' err_msg >> + Unknown -> case isMultMul actual_usage' of + Just (m1, m2) -> ensureSubMult m1 described_usage' err_msg >> ensureSubMult m2 described_usage' err_msg - _ -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) + Nothing -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) where actual_usage' = normalize actual_usage described_usage' = normalize described_usage normalize :: Mult -> Mult - normalize (MultMul m1 m2) = mkMultMul (normalize m1) (normalize m2) - normalize m = m + normalize m = case isMultMul m of + Just (m1, m2) -> mkMultMul (normalize m1) (normalize m2) + Nothing -> m lintRole :: Outputable thing => thing -- where the role appeared |