Print which warning-flag controls an emitted warning
[ghc.git] / compiler / coreSyn / CoreLint.hs
index 9c61b39..f5d0f84 100644 (file)
@@ -284,7 +284,7 @@ displayLintResults :: DynFlags -> CoreToDo
                    -> IO ()
 displayLintResults dflags pass warns errs binds
   | not (isEmptyBag errs)
-  = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
+  = do { log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
            (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
                  , text "*** Offending Program ***"
                  , pprCoreBindings binds
@@ -294,7 +294,7 @@ displayLintResults dflags pass warns errs binds
   | not (isEmptyBag warns)
   , not opt_NoDebugOutput
   , showLintWarnings pass
-  = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
+  = log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
         (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
 
   | otherwise = return ()
@@ -324,7 +324,8 @@ lintInteractiveExpr what hsc_env expr
     dflags = hsc_dflags hsc_env
 
     display_lint_err err
-      = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
+      = do { log_action dflags dflags NoReason Err.SevDump
+               noSrcSpan defaultDumpStyle
                (vcat [ lint_banner "errors" (text what)
                      , err
                      , text "*** Offending Program ***"
@@ -473,7 +474,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 
         -- Check the let/app invariant
         -- See Note [CoreSyn let/app invariant] in CoreSyn
-       ; checkL (not (isUnLiftedType binder_ty)
+       ; checkL (not (isUnliftedType binder_ty)
             || (isNonRec rec_flag && exprOkForSpeculation rhs))
            (mkRhsPrimMsg binder rhs)
 
@@ -759,7 +760,7 @@ lintCoreArg fun_ty (Type arg_ty)
 
 lintCoreArg fun_ty arg
   = do { arg_ty <- lintCoreExpr arg
-       ; checkL (not (isUnLiftedType arg_ty) || exprOkForSpeculation arg)
+       ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
                 (mkLetAppMsg arg)
        ; lintValApp arg fun_ty arg_ty }
 
@@ -912,7 +913,7 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
         -- type variables of the data constructor
         -- We've already check
       lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
-    ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
+    ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys
 
         -- And now bring the new binders into scope
     ; lintBinders args $ \ args' -> do
@@ -988,8 +989,8 @@ lintAndScopeId id linterF
                 (text "Non-local Id binder" <+> ppr id)
                 -- See Note [Checking for global Ids]
        ; (ty, k) <- lintInTy (idType id)
-       ; lintL (not (isLevityPolymorphic k))
-           (text "Levity polymorphic binder:" <+>
+       ; lintL (not (isRuntimeRepPolymorphic k))
+           (text "RuntimeRep-polymorphic binder:" <+>
                  (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
        ; let id' = setIdType id ty
        ; addInScopeVar id' $ (linterF id') }
@@ -1042,7 +1043,7 @@ lintType ty@(TyConApp tc tys)
   = lintType ty'   -- Expand type synonyms, so that we do not bogusly complain
                    --  about un-saturated type synonyms
 
-  | isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
+  | isUnliftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
        -- Also type synonyms and type families
   , length tys < tyConArity tc
   = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
@@ -1136,25 +1137,28 @@ lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
 lint_app doc kfn kas
-    = foldlM go_app kfn kas
+    = do { in_scope <- getInScope
+         -- We need the in_scope set to satisfy the invariant in
+         -- Note [The substitution invariant] in TyCoRep
+         ; foldlM (go_app in_scope) kfn kas }
   where
     fail_msg = vcat [ hang (text "Kind application error in") 2 doc
                     , nest 2 (text "Function kind =" <+> ppr kfn)
                     , nest 2 (text "Arg kinds =" <+> ppr kas) ]
 
-    go_app kfn ka
+    go_app in_scope kfn ka
       | Just kfn' <- coreView kfn
-      = go_app kfn' ka
+      = go_app in_scope kfn' ka
 
-    go_app (ForAllTy (Anon kfa) kfb) (_,ka)
+    go_app (ForAllTy (Anon kfa) kfb) (_,ka)
       = do { unless (ka `eqType` kfa) (addErrL fail_msg)
            ; return kfb }
 
-    go_app (ForAllTy (Named kv _vis) kfn) (ta,ka)
+    go_app in_scope (ForAllTy (Named kv _vis) kfn) (ta,ka)
       = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg)
-           ; return (substTyWith [kv] [ta] kfn) }
+           ; return (substTyWithInScope in_scope [kv] [ta] kfn) }
 
-    go_app _ _ = failWithL fail_msg
+    go_app _ _ = failWithL fail_msg
 
 {- *********************************************************************
 *                                                                      *
@@ -1228,6 +1232,11 @@ lintStarCoercion g
 lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
 -- Check the kind of a coercion term, returning the kind
 -- Post-condition: the returned OutTypes are lint-free
+--
+-- If   lintCorecion co = (k1, k2, s1, s2, r)
+-- then co :: s1 ~r s2
+--      s1 :: k2
+--      s2 :: k2
 
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -1263,7 +1272,7 @@ lintCoercion co@(AppCo co1 co2)
   | Refl _ (TyConApp {}) <- co1
   = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)
   | otherwise
-  = do { (k1,k2,s1,s2,r1) <- lintCoercion co1
+  = do { (k1,  k2,  s1, s2, r1) <- lintCoercion co1
        ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2
        ; k3 <- lint_co_app co k1 [(t1,k'1)]
        ; k4 <- lint_co_app co k2 [(t2,k'2)]
@@ -1281,7 +1290,7 @@ lintCoercion (ForAllCo tv1 kind_co co)
        ; (k3, k4, t1, t2, r) <- addInScopeVar tv1 $ lintCoercion co
        ; let tyl = mkNamedForAllTy tv1 Invisible t1
              tyr = mkNamedForAllTy tv2 Invisible $
-                   substTyWith [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo kind_co] t2
+                   substTyWithUnchecked [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo kind_co] t2
        ; return (k3, k4, tyl, tyr, r) }
 
 lintCoercion (CoVarCo cv)
@@ -1291,7 +1300,7 @@ lintCoercion (CoVarCo cv)
   | otherwise
   = do { lintTyCoVarInScope cv
        ; cv' <- lookupIdInScope cv
-       ; lintUnLiftedCoVar cv
+       ; lintUnliftedCoVar cv
        ; return $ coVarKindsTypesRole cv' }
 
 -- See Note [Bad unsafe coercion]
@@ -1445,7 +1454,7 @@ lintCoercion co@(AxiomInstCo con ind cos)
                                       (empty_subst, empty_subst)
                                       (zip3 (ktvs ++ cvs) roles cos)
        ; let lhs' = substTys subst_l lhs
-             rhs' = substTy subst_r rhs
+             rhs' = substTy  subst_r rhs
        ; case checkAxInstCo co of
            Just bad_branch -> bad_ax $ text "inconsistent with" <+>
                                        pprCoAxBranch con bad_branch
@@ -1510,9 +1519,9 @@ lintCoercion this@(AxiomRuleCo co cs)
                           , text "Provided:" <+> int n ]
 
 ----------
-lintUnLiftedCoVar :: CoVar -> LintM ()
-lintUnLiftedCoVar cv
-  = when (not (isUnLiftedType (coVarKind cv))) $
+lintUnliftedCoVar :: CoVar -> LintM ()
+lintUnliftedCoVar cv
+  = when (not (isUnliftedType (coVarKind cv))) $
     failWithL (text "Bad lifted equality:" <+> ppr cv
                  <+> dcolon <+> ppr (coVarKind cv))
 
@@ -1680,7 +1689,7 @@ addInScopeVar var m
 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 extendSubstL tv ty m
   = LintM $ \ env errs ->
-    unLintM m (env { le_subst = Type.extendTCvSubst (le_subst env) tv ty }) errs
+    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
 
 updateTCvSubst :: TCvSubst -> LintM a -> LintM a
 updateTCvSubst subst' m