compiler/coreSyn/CoreLint.lhs

   1
   2 %
   3 % (c) The University of Glasgow 2006
   4 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   5 %
   6
   7 A ``lint'' pass to check for Core correctness
   8
   9 \begin{code}
  10 module CoreLint ( lintCoreBindings, lintUnfolding ) where
  11
  12 #include "HsVersions.h"
  13
  14 import Demand
  15 import CoreSyn
  16 import CoreFVs
  17 import CoreUtils
  18 import Bag
  19 import Literal
  20 import DataCon
  21 import TysWiredIn
  22 import Var
  23 import VarEnv
  24 import VarSet
  25 import Name
  26 import Id
  27 import PprCore
  28 import ErrUtils
  29 import SrcLoc
  30 import Type
  31 import TypeRep
  32 import Coercion
  33 import TyCon
  34 import Class
  35 import BasicTypes
  36 import StaticFlags
  37 import ListSetOps
  38 import PrelNames
  39 import DynFlags
  40 import Outputable
  41 import FastString
  42 import Util
  43 import Control.Monad
  44 import Data.Maybe
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 Checks that a set of core bindings is well-formed.  The PprStyle and String
  54 just control what we print in the event of an error.  The Bool value
  55 indicates whether we have done any specialisation yet (in which case we do
  56 some extra checks).
  57
  58 We check for
  59         (a) type errors
  60         (b) Out-of-scope type variables
  61         (c) Out-of-scope local variables
  62         (d) Ill-kinded types
  63
  64 If we have done specialisation the we check that there are
  65         (a) No top-level bindings of primitive (unboxed type)
  66
  67 Outstanding issues:
  68
  69     --
  70     -- Things are *not* OK if:
  71     --
  72     --  * Unsaturated type app before specialisation has been done;
  73     --
  74     --  * Oversaturated type app after specialisation (eta reduction
  75     --   may well be happening...);
  76
  77
  78 Note [Linting type lets]
  79 ~~~~~~~~~~~~~~~~~~~~~~~~
  80 In the desugarer, it's very very convenient to be able to say (in effect)
  81         let a = Type Int in <body>
  82 That is, use a type let.   See Note [Type let] in CoreSyn.
  83
  84 However, when linting <body> we need to remember that a=Int, else we might
  85 reject a correct program.  So we carry a type substitution (in this example
  86 [a -> Int]) and apply this substitution before comparing types.  The functin
  87         lintInTy :: Type -> LintM Type
  88 returns a substituted type; that's the only reason it returns anything.
  89
  90 When we encounter a binder (like x::a) we must apply the substitution
  91 to the type of the binding variable.  lintBinders does this.
  92
  93 For Ids, the type-substituted Id is added to the in_scope set (which
  94 itself is part of the TvSubst we are carrying down), and when we
  95 find an occurence of an Id, we fetch it from the in-scope set.
  96
  97
  98 \begin{code}
  99 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 100
 101 lintCoreBindings dflags _whoDunnit _binds
 102   | not (dopt Opt_DoCoreLinting dflags)
 103   = return ()
 104
 105 lintCoreBindings dflags whoDunnit binds
 106   | isEmptyBag errs
 107   = do { showPass dflags ("Core Linted result of " ++ whoDunnit)
 108        ; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $
 109          (banner "warnings" $$ displayMessageBag warns)
 110        ; return () }
 111
 112   | otherwise
 113   = do { printDump (vcat [ banner "errors", displayMessageBag errs
 114                          , ptext (sLit "*** Offending Program ***")
 115                          , pprCoreBindings binds
 116                          , ptext (sLit "*** End of Offense ***") ])
 117
 118        ; ghcExit dflags 1 }
 119   where
 120     (warns, errs) = initL (lint_binds binds)
 121
 122         -- Put all the top-level binders in scope at the start
 123         -- This is because transformation rules can bring something
 124         -- into use 'unexpectedly'
 125     lint_binds binds = addLoc TopLevelBindings $
 126                        addInScopeVars (bindersOfBinds binds) $
 127                        mapM lint_bind binds
 128
 129     lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs
 130     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
 131
 132     banner string = ptext (sLit "*** Core Lint")      <+> text string
 133                     <+> ptext (sLit ": in result of") <+> text whoDunnit
 134                     <+> ptext (sLit "***")
 135
 136 displayMessageBag :: Bag Message -> SDoc
 137 displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
 138 \end{code}
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection[lintUnfolding]{lintUnfolding}
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 We use this to check all unfoldings that come in from interfaces
 147 (it is very painful to catch errors otherwise):
 148
 149 \begin{code}
 150 lintUnfolding :: SrcLoc
 151               -> [Var]          -- Treat these as in scope
 152               -> CoreExpr
 153               -> Maybe Message  -- Nothing => OK
 154
 155 lintUnfolding locn vars expr
 156   | isEmptyBag errs = Nothing
 157   | otherwise       = Just (displayMessageBag errs)
 158   where
 159     (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
 160                             addInScopeVars vars            $
 161                             lintCoreExpr expr)
 162 \end{code}
 163
 164 %************************************************************************
 165 %*                                                                      *
 166 \subsection[lintCoreBinding]{lintCoreBinding}
 167 %*                                                                      *
 168 %************************************************************************
 169
 170 Check a core binding, returning the list of variables bound.
 171
 172 \begin{code}
 173 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
 174 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 175   = addLoc (RhsOf binder) $
 176          -- Check the rhs
 177     do { ty <- lintCoreExpr rhs
 178        ; lintBinder binder -- Check match to RHS type
 179        ; binder_ty <- applySubst binder_ty
 180        ; checkTys binder_ty ty (mkRhsMsg binder ty)
 181         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 182        ; checkL (not (isUnLiftedType binder_ty)
 183             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 184            (mkRhsPrimMsg binder rhs)
 185         -- Check that if the binder is top-level or recursive, it's not demanded
 186        ; checkL (not (isStrictId binder)
 187             || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
 188            (mkStrictMsg binder)
 189         -- Check whether binder's specialisations contain any out-of-scope variables
 190        ; mapM_ (checkBndrIdInScope binder) bndr_vars
 191
 192        ; when (isNonRuleLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder))
 193               (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder))
 194               -- Only non-rule loop breakers inhibit inlining
 195
 196       -- Check whether arity and demand type are consistent (only if demand analysis
 197       -- already happened)
 198        ; checkL (case maybeDmdTy of
 199                   Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
 200                   Nothing -> True)
 201            (mkArityMsg binder) }
 202
 203         -- We should check the unfolding, if any, but this is tricky because
 204         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 205    where
 206     binder_ty                  = idType binder
 207     maybeDmdTy                 = idStrictness_maybe binder
 208     bndr_vars                  = varSetElems (idFreeVars binder)
 209     lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
 210                    | otherwise = return ()
 211 \end{code}
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection[lintCoreExpr]{lintCoreExpr}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 \begin{code}
 220 type InType  = Type     -- Substitution not yet applied
 221 type InVar   = Var
 222 type InTyVar = TyVar
 223
 224 type OutType  = Type    -- Substitution has been applied to this
 225 type OutVar   = Var
 226 type OutTyVar = TyVar
 227 type OutCoVar = CoVar
 228
 229 lintCoreExpr :: CoreExpr -> LintM OutType
 230 -- The returned type has the substitution from the monad
 231 -- already applied to it:
 232 --      lintCoreExpr e subst = exprType (subst e)
 233 --
 234 -- The returned "type" can be a kind, if the expression is (Type ty)
 235
 236 lintCoreExpr (Var var)
 237   = do  { checkL (not (var == oneTupleDataConId))
 238                  (ptext (sLit "Illegal one-tuple"))
 239
 240         ; checkDeadIdOcc var
 241         ; var' <- lookupIdInScope var
 242         ; return (idType var')
 243         }
 244
 245 lintCoreExpr (Lit lit)
 246   = return (literalType lit)
 247
 248 lintCoreExpr (Cast expr co)
 249   = do { expr_ty <- lintCoreExpr expr
 250        ; co' <- applySubst co
 251        ; (from_ty, to_ty) <- lintCoercion co'
 252        ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
 253        ; return to_ty }
 254
 255 lintCoreExpr (Note _ expr)
 256   = lintCoreExpr expr
 257
 258 lintCoreExpr (Let (NonRec tv (Type ty)) body)
 259   =     -- See Note [Type let] in CoreSyn
 260     do  { checkL (isTyVar tv) (mkKindErrMsg tv ty)      -- Not quite accurate
 261         ; ty' <- lintInTy ty
 262         ; lintTyBndr tv              $ \ tv' ->
 263           addLoc (BodyOfLetRec [tv]) $
 264           extendSubstL tv' ty'       $ do
 265         { checkKinds tv' ty'
 266                 -- Now extend the substitution so we
 267                 -- take advantage of it in the body
 268         ; lintCoreExpr body } }
 269
 270 lintCoreExpr (Let (NonRec bndr rhs) body)
 271   = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
 272         ; addLoc (BodyOfLetRec [bndr])
 273                  (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
 274
 275 lintCoreExpr (Let (Rec pairs) body)
 276   = lintAndScopeIds bndrs       $ \_ ->
 277     do  { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
 278         ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
 279   where
 280     bndrs = map fst pairs
 281
 282 lintCoreExpr e@(App fun arg)
 283   = do  { fun_ty <- lintCoreExpr fun
 284         ; addLoc (AnExpr e) $
 285           lintCoreArg fun_ty arg }
 286
 287 lintCoreExpr (Lam var expr)
 288   = addLoc (LambdaBodyOf var) $
 289     lintBinders [var] $ \[var'] ->
 290     do { body_ty <- lintCoreExpr expr
 291        ; if isId var' then
 292              return (mkFunTy (idType var') body_ty)
 293          else
 294              return (mkForAllTy var' body_ty)
 295        }
 296         -- The applySubst is needed to apply the subst to var
 297
 298 lintCoreExpr e@(Case scrut var alt_ty alts) =
 299        -- Check the scrutinee
 300   do { scrut_ty <- lintCoreExpr scrut
 301      ; alt_ty   <- lintInTy alt_ty
 302      ; var_ty   <- lintInTy (idType var)
 303
 304      ; let mb_tc_app = splitTyConApp_maybe (idType var)
 305      ; case mb_tc_app of
 306          Just (tycon, _)
 307               | debugIsOn &&
 308                 isAlgTyCon tycon &&
 309                 not (isOpenTyCon tycon) &&
 310                 null (tyConDataCons tycon) ->
 311                   pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
 312                         -- This can legitimately happen for type families
 313                       $ return ()
 314          _otherwise -> return ()
 315
 316         -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
 317
 318      ; subst <- getTvSubst
 319      ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
 320
 321      -- If the binder is an unboxed tuple type, don't put it in scope
 322      ; let scope = if (isUnboxedTupleType (idType var)) then
 323                        pass_var
 324                    else lintAndScopeId var
 325      ; scope $ \_ ->
 326        do { -- Check the alternatives
 327             mapM_ (lintCoreAlt scrut_ty alt_ty) alts
 328           ; checkCaseAlts e scrut_ty alts
 329           ; return alt_ty } }
 330   where
 331     pass_var f = f var
 332
 333 lintCoreExpr (Type ty)
 334   = do { ty' <- lintInTy ty
 335        ; return (typeKind ty') }
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[lintCoreArgs]{lintCoreArgs}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 The basic version of these functions checks that the argument is a
 345 subtype of the required type, as one would expect.
 346
 347 \begin{code}
 348 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
 349 lintCoreArg  :: OutType -> CoreArg   -> LintM OutType
 350 -- First argument has already had substitution applied to it
 351 \end{code}
 352
 353 \begin{code}
 354 lintCoreArgs ty [] = return ty
 355 lintCoreArgs ty (a : args) =
 356   do { res <- lintCoreArg ty a
 357      ; lintCoreArgs res args }
 358
 359 lintCoreArg fun_ty (Type arg_ty)
 360   | Just (tyvar,body) <- splitForAllTy_maybe fun_ty
 361   = do  { arg_ty' <- applySubst arg_ty
 362         ; checkKinds tyvar arg_ty'
 363         ; if isCoVar tyvar then
 364              return body   -- Co-vars don't appear in body!
 365           else
 366              return (substTyWith [tyvar] [arg_ty'] body) }
 367   | otherwise
 368   = failWithL (mkTyAppMsg fun_ty arg_ty)
 369
 370 lintCoreArg fun_ty arg
 371        -- Make sure function type matches argument
 372  = do { arg_ty <- lintCoreExpr arg
 373       ; let err1 = mkAppMsg fun_ty arg_ty arg
 374             err2 = mkNonFunAppMsg fun_ty arg_ty arg
 375       ; case splitFunTy_maybe fun_ty of
 376           Just (arg,res) ->
 377             do { checkTys arg arg_ty err1
 378                ; return res }
 379           _ -> failWithL err2 }
 380 \end{code}
 381
 382 \begin{code}
 383 checkKinds :: Var -> OutType -> LintM ()
 384 -- Both args have had substitution applied
 385 checkKinds tyvar arg_ty
 386         -- Arg type might be boxed for a function with an uncommitted
 387         -- tyvar; notably this is used so that we can give
 388         --      error :: forall a:*. String -> a
 389         -- and then apply it to both boxed and unboxed types.
 390   | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty
 391                        ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2)
 392                                 (addErrL (mkCoAppErrMsg tyvar arg_ty)) }
 393   | otherwise     = do { arg_kind <- lintType arg_ty
 394                        ; unless (arg_kind `isSubKind` tyvar_kind)
 395                                 (addErrL (mkKindErrMsg tyvar arg_ty)) }
 396   where
 397     tyvar_kind = tyVarKind tyvar
 398     (s1,t1)    = coVarKind tyvar
 399
 400 checkDeadIdOcc :: Id -> LintM ()
 401 -- Occurrences of an Id should never be dead....
 402 -- except when we are checking a case pattern
 403 checkDeadIdOcc id
 404   | isDeadOcc (idOccInfo id)
 405   = do { in_case <- inCasePat
 406        ; checkL in_case
 407                 (ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
 408   | otherwise
 409   = return ()
 410 \end{code}
 411
 412
 413 %************************************************************************
 414 %*                                                                      *
 415 \subsection[lintCoreAlts]{lintCoreAlts}
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 \begin{code}
 420 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 421 -- a) Check that the alts are non-empty
 422 -- b1) Check that the DEFAULT comes first, if it exists
 423 -- b2) Check that the others are in increasing order
 424 -- c) Check that there's a default for infinite types
 425 -- NB: Algebraic cases are not necessarily exhaustive, because
 426 --     the simplifer correctly eliminates case that can't
 427 --     possibly match.
 428
 429 checkCaseAlts e _ []
 430   = addErrL (mkNullAltsMsg e)
 431
 432 checkCaseAlts e ty alts =
 433   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
 434      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
 435      ; checkL (isJust maybe_deflt || not is_infinite_ty)
 436            (nonExhaustiveAltsMsg e) }
 437   where
 438     (con_alts, maybe_deflt) = findDefault alts
 439
 440         -- Check that successive alternatives have increasing tags
 441     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
 442     increasing_tag _                         = True
 443
 444     non_deflt (DEFAULT, _, _) = False
 445     non_deflt _               = True
 446
 447     is_infinite_ty = case splitTyConApp_maybe ty of
 448                         Nothing         -> False
 449                         Just (tycon, _) -> isPrimTyCon tycon
 450 \end{code}
 451
 452 \begin{code}
 453 checkAltExpr :: CoreExpr -> OutType -> LintM ()
 454 checkAltExpr expr ann_ty
 455   = do { actual_ty <- lintCoreExpr expr
 456        ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
 457
 458 lintCoreAlt :: OutType          -- Type of scrutinee
 459             -> OutType          -- Type of the alternative
 460             -> CoreAlt
 461             -> LintM ()
 462
 463 lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
 464   do { checkL (null args) (mkDefaultArgsMsg args)
 465      ; checkAltExpr rhs alt_ty }
 466
 467 lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) =
 468   do { checkL (null args) (mkDefaultArgsMsg args)
 469      ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
 470      ; checkAltExpr rhs alt_ty }
 471   where
 472     lit_ty = literalType lit
 473
 474 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 475   | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
 476   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
 477   = addLoc (CaseAlt alt) $  do
 478     {   -- First instantiate the universally quantified
 479         -- type variables of the data constructor
 480         -- We've already check
 481       checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
 482     ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
 483
 484         -- And now bring the new binders into scope
 485     ; lintBinders args $ \ args -> do
 486     { addLoc (CasePat alt) $ do
 487           {    -- Check the pattern
 488                  -- Scrutinee type must be a tycon applicn; checked by caller
 489                  -- This code is remarkably compact considering what it does!
 490                  -- NB: args must be in scope here so that the lintCoreArgs
 491                  --     line works.
 492                  -- NB: relies on existential type args coming *after*
 493                  --     ordinary type args
 494           ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
 495           ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 496           }
 497                -- Check the RHS
 498     ; checkAltExpr rhs alt_ty } }
 499
 500   | otherwise   -- Scrut-ty is wrong shape
 501   = addErrL (mkBadAltMsg scrut_ty alt)
 502 \end{code}
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 \subsection[lint-types]{Types}
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 \begin{code}
 511 -- When we lint binders, we (one at a time and in order):
 512 --  1. Lint var types or kinds (possibly substituting)
 513 --  2. Add the binder to the in scope set, and if its a coercion var,
 514 --     we may extend the substitution to reflect its (possibly) new kind
 515 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
 516 lintBinders [] linterF = linterF []
 517 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
 518                                  lintBinders vars $ \ vars' ->
 519                                  linterF (var':vars')
 520
 521 lintBinder :: Var -> (Var -> LintM a) -> LintM a
 522 lintBinder var linterF
 523   | isId var  = lintIdBndr var linterF
 524   | otherwise = lintTyBndr var linterF
 525
 526 lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
 527 lintTyBndr tv thing_inside
 528   = do { subst <- getTvSubst
 529        ; let (subst', tv') = substTyVarBndr subst tv
 530        ; lintTyBndrKind tv'
 531        ; updateTvSubst subst' (thing_inside tv') }
 532
 533 lintIdBndr :: Id -> (Id -> LintM a) -> LintM a
 534 -- Do substitution on the type of a binder and add the var with this
 535 -- new type to the in-scope set of the second argument
 536 -- ToDo: lint its rules
 537
 538 lintIdBndr id linterF
 539   = do  { checkL (not (isUnboxedTupleType (idType id)))
 540                  (mkUnboxedTupleMsg id)
 541                 -- No variable can be bound to an unboxed tuple.
 542         ; lintAndScopeId id $ \id' -> linterF id' }
 543
 544 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
 545 lintAndScopeIds ids linterF
 546   = go ids
 547   where
 548     go []       = linterF []
 549     go (id:ids) = lintAndScopeId id $ \id ->
 550                   lintAndScopeIds ids $ \ids ->
 551                   linterF (id:ids)
 552
 553 lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a
 554 lintAndScopeId id linterF
 555   = do { ty <- lintInTy (idType id)
 556        ; let id' = setIdType id ty
 557        ; addInScopeVar id' $ (linterF id') }
 558 \end{code}
 559
 560
 561 %************************************************************************
 562 %*                                                                      *
 563 \subsection[lint-monad]{The Lint monad}
 564 %*                                                                      *
 565 %************************************************************************
 566
 567 \begin{code}
 568 lintInTy :: InType -> LintM OutType
 569 -- Check the type, and apply the substitution to it
 570 -- See Note [Linting type lets]
 571 -- ToDo: check the kind structure of the type
 572 lintInTy ty
 573   = addLoc (InType ty) $
 574     do  { ty' <- applySubst ty
 575         ; _ <- lintType ty'
 576         ; return ty' }
 577
 578 -------------------
 579 lintKind :: Kind -> LintM ()
 580 -- Check well-formedness of kinds: *, *->*, etc
 581 lintKind (TyConApp tc [])
 582   | getUnique tc `elem` kindKeys
 583   = return ()
 584 lintKind (FunTy k1 k2)
 585   = lintKind k1 >> lintKind k2
 586 lintKind kind
 587   = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)))
 588
 589 -------------------
 590 lintTyBndrKind :: OutTyVar -> LintM ()
 591 lintTyBndrKind tv
 592   | isCoVar tv = lintCoVarKind tv
 593   | otherwise  = lintKind (tyVarKind tv)
 594
 595 -------------------
 596 lintCoVarKind :: OutCoVar -> LintM ()
 597 -- Check the kind of a coercion binder
 598 lintCoVarKind tv
 599   = do { (ty1,ty2) <- lintSplitCoVar tv
 600        ; k1 <- lintType ty1
 601        ; k2 <- lintType ty2
 602        ; unless (k1 `eqKind` k2)
 603                 (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:")
 604                               , nest 2 (quotes (ppr tv))
 605                               , ppr [k1,k2] ])) }
 606
 607 -------------------
 608 lintSplitCoVar :: CoVar -> LintM (Type,Type)
 609 lintSplitCoVar cv
 610   = case coVarKind_maybe cv of
 611       Just ts -> return ts
 612       Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
 613                                 , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
 614
 615 -------------------
 616 lintCoercion :: OutType -> LintM (OutType, OutType)
 617 -- Check the kind of a coercion term, returning the kind
 618 lintCoercion ty@(TyVarTy tv)
 619   = do { checkTyVarInScope tv
 620        ; if isCoVar tv then return (coVarKind tv)
 621                        else return (ty, ty) }
 622
 623 lintCoercion ty@(AppTy ty1 ty2)
 624   = do { (s1,t1) <- lintCoercion ty1
 625        ; (s2,t2) <- lintCoercion ty2
 626        ; check_co_app ty (typeKind s1) [s2]
 627        ; return (AppTy s1 s2, AppTy t1 t2) }
 628
 629 lintCoercion ty@(FunTy ty1 ty2)
 630   = do { (s1,t1) <- lintCoercion ty1
 631        ; (s2,t2) <- lintCoercion ty2
 632        ; check_co_app ty (tyConKind funTyCon) [s1, s2]
 633        ; return (FunTy s1 s2, FunTy t1 t2) }
 634
 635 lintCoercion ty@(TyConApp tc tys)
 636   | Just (ar, desc) <- isCoercionTyCon_maybe tc
 637   = do { unless (tys `lengthAtLeast` ar) (badCo ty)
 638        ; (s,t) <- lintCoTyConApp ty desc (take ar tys)
 639        ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys)
 640        ; check_co_app ty (typeKind s) ss
 641        ; return (mkAppTys s ss, mkAppTys t ts) }
 642
 643   | not (tyConHasKind tc)       -- Just something bizarre like SuperKindTyCon
 644   = badCo ty
 645
 646   | otherwise
 647   = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
 648        ; check_co_app ty (tyConKind tc) ss
 649        ; return (TyConApp tc ss, TyConApp tc ts) }
 650
 651 lintCoercion ty@(PredTy (ClassP cls tys))
 652   = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
 653        ; check_co_app ty (tyConKind (classTyCon cls)) ss
 654        ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) }
 655
 656 lintCoercion (PredTy (IParam n p_ty))
 657   = do { (s,t) <- lintCoercion p_ty
 658        ; return (PredTy (IParam n s), PredTy (IParam n t)) }
 659
 660 lintCoercion ty@(PredTy (EqPred {}))
 661   = failWithL (badEq ty)
 662
 663 lintCoercion (ForAllTy tv ty)
 664   | isCoVar tv
 665   = do { (co1, co2) <- lintSplitCoVar tv
 666        ; (s1,t1)    <- lintCoercion co1
 667        ; (s2,t2)    <- lintCoercion co2
 668        ; (sr,tr)    <- lintCoercion ty
 669        ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) }
 670
 671   | otherwise
 672   = do { lintKind (tyVarKind tv)
 673        ; (s,t) <- addInScopeVar tv (lintCoercion ty)
 674        ; return (ForAllTy tv s, ForAllTy tv t) }
 675
 676 badCo :: Coercion -> LintM a
 677 badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co))
 678
 679 ---------------
 680 lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type)
 681 -- Always called with correct number of coercion arguments
 682 -- First arg is just for error message
 683 lintCoTyConApp _ CoLeft  (co:_) = lintLR   fst      co
 684 lintCoTyConApp _ CoRight (co:_) = lintLR   snd      co
 685 lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3   co
 686 lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3   co
 687 lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co
 688
 689 lintCoTyConApp _ CoSym (co:_)
 690   = do { (ty1,ty2) <- lintCoercion co
 691        ; return (ty2,ty1) }
 692
 693 lintCoTyConApp co CoTrans (co1:co2:_)
 694   = do { (ty1a, ty1b) <- lintCoercion co1
 695        ; (ty2a, ty2b) <- lintCoercion co2
 696        ; checkL (ty1b `coreEqType` ty2a)
 697                 (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
 698                     2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
 699        ; return (ty1a, ty2b) }
 700
 701 lintCoTyConApp _ CoInst (co:arg_ty:_)
 702   = do { co_tys <- lintCoercion co
 703        ; arg_kind  <- lintType arg_ty
 704        ; case decompInst_maybe co_tys of
 705           Just ((tv1,tv2), (ty1,ty2))
 706             | arg_kind `isSubKind` tyVarKind tv1
 707             -> return (substTyWith [tv1] [arg_ty] ty1,
 708                        substTyWith [tv2] [arg_ty] ty2)
 709             | otherwise
 710             -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
 711           Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
 712
 713 lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs
 714                           , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
 715   = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos
 716        ; sequence_ (zipWith checkKinds tvs tys1)
 717        ; return (substTyWith tvs tys1 lhs_ty,
 718                  substTyWith tvs tys2 rhs_ty) }
 719
 720 lintCoTyConApp _ CoUnsafe (ty1:ty2:_)
 721   = do { _ <- lintType ty1
 722        ; _ <- lintType ty2      -- Ignore kinds; it's unsafe!
 723        ; return (ty1,ty2) }
 724
 725 lintCoTyConApp _ _ _ = panic "lintCoTyConApp"  -- Called with wrong number of coercion args
 726
 727 ----------
 728 lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type)
 729 lintLR sel co
 730   = do { (ty1,ty2) <- lintCoercion co
 731        ; case decompLR_maybe (ty1,ty2) of
 732            Just res -> return (sel res)
 733            Nothing  -> failWithL (ptext (sLit "Bad argument of left/right")) }
 734
 735 ----------
 736 lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type)
 737 lintCsel sel co
 738   = do { (ty1,ty2) <- lintCoercion co
 739        ; case decompCsel_maybe (ty1,ty2) of
 740            Just res -> return (sel res)
 741            Nothing  -> failWithL (ptext (sLit "Bad argument of csel")) }
 742
 743 -------------------
 744 lintType :: OutType -> LintM Kind
 745 lintType (TyVarTy tv)
 746   = do { checkTyVarInScope tv
 747        ; return (tyVarKind tv) }
 748
 749 lintType ty@(AppTy t1 t2)
 750   = do { k1 <- lintType t1
 751        ; lint_ty_app ty k1 [t2] }
 752
 753 lintType ty@(FunTy t1 t2)
 754   = lint_ty_app ty (tyConKind funTyCon) [t1,t2]
 755
 756 lintType ty@(TyConApp tc tys)
 757   | tyConHasKind tc
 758   = lint_ty_app ty (tyConKind tc) tys
 759   | otherwise
 760   = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))
 761
 762 lintType (ForAllTy tv ty)
 763   = do { lintTyBndrKind tv
 764        ; addInScopeVar tv (lintType ty) }
 765
 766 lintType ty@(PredTy (ClassP cls tys))
 767   = lint_ty_app ty (tyConKind (classTyCon cls)) tys
 768
 769 lintType (PredTy (IParam _ p_ty))
 770   = lintType p_ty
 771
 772 lintType ty@(PredTy (EqPred {}))
 773   = failWithL (badEq ty)
 774
 775 ----------------
 776 lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
 777 lint_ty_app ty k tys
 778   = do { ks <- mapM lintType tys
 779        ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
 780
 781 ----------------
 782 check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
 783 check_co_app ty k tys
 784   = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty))
 785                             k (map typeKind tys)
 786        ; return () }
 787
 788 ----------------
 789 lint_kind_app :: SDoc -> Kind -> [Kind] -> LintM Kind
 790 lint_kind_app doc kfn ks = go kfn ks
 791   where
 792     fail_msg = vcat [hang (ptext (sLit "Kind application error in")) 2 doc,
 793                      nest 2 (ptext (sLit "Function kind =") <+> ppr kfn),
 794                      nest 2 (ptext (sLit "Arg kinds =") <+> ppr ks)]
 795
 796     go kfn []     = return kfn
 797     go kfn (k:ks) = case splitKindFunTy_maybe kfn of
 798                       Nothing         -> failWithL fail_msg
 799                       Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
 800                                                      (addErrL fail_msg)
 801                                             ; go kfb ks }
 802 --------------
 803 badEq :: Type -> SDoc
 804 badEq ty = hang (ptext (sLit "Unexpected equality predicate:"))
 805               1 (quotes (ppr ty))
 806 \end{code}
 807
 808 %************************************************************************
 809 %*                                                                      *
 810 \subsection[lint-monad]{The Lint monad}
 811 %*                                                                      *
 812 %************************************************************************
 813
 814 \begin{code}
 815 newtype LintM a =
 816    LintM { unLintM ::
 817             [LintLocInfo] ->         -- Locations
 818             TvSubst ->               -- Current type substitution; we also use this
 819                                      -- to keep track of all the variables in scope,
 820                                      -- both Ids and TyVars
 821             WarnsAndErrs ->           -- Error and warning messages so far
 822             (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
 823
 824 type WarnsAndErrs = (Bag Message, Bag Message)
 825
 826 {-      Note [Type substitution]
 827         ~~~~~~~~~~~~~~~~~~~~~~~~
 828 Why do we need a type substitution?  Consider
 829         /\(a:*). \(x:a). /\(a:*). id a x
 830 This is ill typed, because (renaming variables) it is really
 831         /\(a:*). \(x:a). /\(b:*). id b x
 832 Hence, when checking an application, we can't naively compare x's type
 833 (at its binding site) with its expected type (at a use site).  So we
 834 rename type binders as we go, maintaining a substitution.
 835
 836 The same substitution also supports let-type, current expressed as
 837         (/\(a:*). body) ty
 838 Here we substitute 'ty' for 'a' in 'body', on the fly.
 839 -}
 840
 841 instance Monad LintM where
 842   return x = LintM (\ _   _     errs -> (Just x, errs))
 843   fail err = failWithL (text err)
 844   m >>= k  = LintM (\ loc subst errs ->
 845                        let (res, errs') = unLintM m loc subst errs in
 846                          case res of
 847                            Just r -> unLintM (k r) loc subst errs'
 848                            Nothing -> (Nothing, errs'))
 849
 850 data LintLocInfo
 851   = RhsOf Id            -- The variable bound
 852   | LambdaBodyOf Id     -- The lambda-binder
 853   | BodyOfLetRec [Id]   -- One of the binders
 854   | CaseAlt CoreAlt     -- Case alternative
 855   | CasePat CoreAlt     -- The *pattern* of the case alternative
 856   | AnExpr CoreExpr     -- Some expression
 857   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 858   | TopLevelBindings
 859   | InType Type         -- Inside a type
 860 \end{code}
 861
 862
 863 \begin{code}
 864 initL :: LintM a -> WarnsAndErrs    -- Errors and warnings
 865 initL m
 866   = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of
 867       (_, errs) -> errs
 868 \end{code}
 869
 870 \begin{code}
 871 checkL :: Bool -> Message -> LintM ()
 872 checkL True  _   = return ()
 873 checkL False msg = failWithL msg
 874
 875 failWithL :: Message -> LintM a
 876 failWithL msg = LintM $ \ loc subst (warns,errs) ->
 877                 (Nothing, (warns, addMsg subst errs msg loc))
 878
 879 addErrL :: Message -> LintM ()
 880 addErrL msg = LintM $ \ loc subst (warns,errs) ->
 881               (Just (), (warns, addMsg subst errs msg loc))
 882
 883 addWarnL :: Message -> LintM ()
 884 addWarnL msg = LintM $ \ loc subst (warns,errs) ->
 885               (Just (), (addMsg subst warns msg loc, errs))
 886
 887 addMsg :: TvSubst ->  Bag Message -> Message -> [LintLocInfo] -> Bag Message
 888 addMsg subst msgs msg locs
 889   = ASSERT( notNull locs )
 890     msgs `snocBag` mk_msg msg
 891   where
 892    (loc, cxt1) = dumpLoc (head locs)
 893    cxts        = [snd (dumpLoc loc) | loc <- locs]
 894    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
 895                                       ptext (sLit "Substitution:") <+> ppr subst
 896                | otherwise          = cxt1
 897
 898    mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
 899
 900 addLoc :: LintLocInfo -> LintM a -> LintM a
 901 addLoc extra_loc m =
 902   LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
 903
 904 inCasePat :: LintM Bool         -- A slight hack; see the unique call site
 905 inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
 906   where
 907     is_case_pat (CasePat {} : _) = True
 908     is_case_pat _other           = False
 909
 910 addInScopeVars :: [Var] -> LintM a -> LintM a
 911 addInScopeVars vars m
 912   | null dups
 913   = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs)
 914   | otherwise
 915   = failWithL (dupVars dups)
 916   where
 917     (_, dups) = removeDups compare vars
 918
 919 addInScopeVar :: Var -> LintM a -> LintM a
 920 addInScopeVar var m
 921   = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst var) errs)
 922
 923 updateTvSubst :: TvSubst -> LintM a -> LintM a
 924 updateTvSubst subst' m =
 925   LintM (\ loc _ errs -> unLintM m loc subst' errs)
 926
 927 getTvSubst :: LintM TvSubst
 928 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
 929
 930 applySubst :: Type -> LintM Type
 931 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
 932
 933 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 934 extendSubstL tv ty m
 935   = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
 936 \end{code}
 937
 938 \begin{code}
 939 lookupIdInScope :: Id -> LintM Id
 940 lookupIdInScope id
 941   | not (mustHaveLocalBinding id)
 942   = return id   -- An imported Id
 943   | otherwise
 944   = do  { subst <- getTvSubst
 945         ; case lookupInScope (getTvInScope subst) id of
 946                 Just v  -> return v
 947                 Nothing -> do { addErrL out_of_scope
 948                               ; return id } }
 949   where
 950     out_of_scope = ppr id <+> ptext (sLit "is out of scope")
 951
 952
 953 oneTupleDataConId :: Id -- Should not happen
 954 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
 955
 956 checkBndrIdInScope :: Var -> Var -> LintM ()
 957 checkBndrIdInScope binder id
 958   = checkInScope msg id
 959     where
 960      msg = ptext (sLit "is out of scope inside info for") <+>
 961            ppr binder
 962
 963 checkTyVarInScope :: TyVar -> LintM ()
 964 checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
 965
 966 checkInScope :: SDoc -> Var -> LintM ()
 967 checkInScope loc_msg var =
 968  do { subst <- getTvSubst
 969     ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
 970              (hsep [ppr var, loc_msg]) }
 971
 972 checkTys :: Type -> Type -> Message -> LintM ()
 973 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 974 -- annotations need only be consistent, not equal)
 975 -- Assumes ty1,ty2 are have alrady had the substitution applied
 976 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
 977 \end{code}
 978
 979 %************************************************************************
 980 %*                                                                      *
 981 \subsection{Error messages}
 982 %*                                                                      *
 983 %************************************************************************
 984
 985 \begin{code}
 986 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
 987
 988 dumpLoc (RhsOf v)
 989   = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
 990
 991 dumpLoc (LambdaBodyOf b)
 992   = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
 993
 994 dumpLoc (BodyOfLetRec [])
 995   = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
 996
 997 dumpLoc (BodyOfLetRec bs@(_:_))
 998   = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
 999
1000 dumpLoc (AnExpr e)
1001   = (noSrcLoc, text "In the expression:" <+> ppr e)
1002
1003 dumpLoc (CaseAlt (con, args, _))
1004   = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
1005
1006 dumpLoc (CasePat (con, args, _))
1007   = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
1008
1009 dumpLoc (ImportedUnfolding locn)
1010   = (locn, brackets (ptext (sLit "in an imported unfolding")))
1011 dumpLoc TopLevelBindings
1012   = (noSrcLoc, empty)
1013 dumpLoc (InType ty)
1014   = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
1015
1016 pp_binders :: [Var] -> SDoc
1017 pp_binders bs = sep (punctuate comma (map pp_binder bs))
1018
1019 pp_binder :: Var -> SDoc
1020 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
1021             | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
1022 \end{code}
1023
1024 \begin{code}
1025 ------------------------------------------------------
1026 --      Messages for case expressions
1027
1028 mkNullAltsMsg :: CoreExpr -> Message
1029 mkNullAltsMsg e
1030   = hang (text "Case expression with no alternatives:")
1031          4 (ppr e)
1032
1033 mkDefaultArgsMsg :: [Var] -> Message
1034 mkDefaultArgsMsg args
1035   = hang (text "DEFAULT case with binders")
1036          4 (ppr args)
1037
1038 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
1039 mkCaseAltMsg e ty1 ty2
1040   = hang (text "Type of case alternatives not the same as the annotation on case:")
1041          4 (vcat [ppr ty1, ppr ty2, ppr e])
1042
1043 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
1044 mkScrutMsg var var_ty scrut_ty subst
1045   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
1046           text "Result binder type:" <+> ppr var_ty,--(idType var),
1047           text "Scrutinee type:" <+> ppr scrut_ty,
1048      hsep [ptext (sLit "Current TV subst"), ppr subst]]
1049
1050 mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
1051 mkNonDefltMsg e
1052   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
1053 mkNonIncreasingAltsMsg e
1054   = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
1055
1056 nonExhaustiveAltsMsg :: CoreExpr -> Message
1057 nonExhaustiveAltsMsg e
1058   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
1059
1060 mkBadConMsg :: TyCon -> DataCon -> Message
1061 mkBadConMsg tycon datacon
1062   = vcat [
1063         text "In a case alternative, data constructor isn't in scrutinee type:",
1064         text "Scrutinee type constructor:" <+> ppr tycon,
1065         text "Data con:" <+> ppr datacon
1066     ]
1067
1068 mkBadPatMsg :: Type -> Type -> Message
1069 mkBadPatMsg con_result_ty scrut_ty
1070   = vcat [
1071         text "In a case alternative, pattern result type doesn't match scrutinee type:",
1072         text "Pattern result type:" <+> ppr con_result_ty,
1073         text "Scrutinee type:" <+> ppr scrut_ty
1074     ]
1075
1076 mkBadAltMsg :: Type -> CoreAlt -> Message
1077 mkBadAltMsg scrut_ty alt
1078   = vcat [ text "Data alternative when scrutinee is not a tycon application",
1079            text "Scrutinee type:" <+> ppr scrut_ty,
1080            text "Alternative:" <+> pprCoreAlt alt ]
1081
1082 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
1083 mkNewTyDataConAltMsg scrut_ty alt
1084   = vcat [ text "Data alternative for newtype datacon",
1085            text "Scrutinee type:" <+> ppr scrut_ty,
1086            text "Alternative:" <+> pprCoreAlt alt ]
1087
1088
1089 ------------------------------------------------------
1090 --      Other error messages
1091
1092 mkAppMsg :: Type -> Type -> CoreExpr -> Message
1093 mkAppMsg fun_ty arg_ty arg
1094   = vcat [ptext (sLit "Argument value doesn't match argument type:"),
1095               hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
1096               hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
1097               hang (ptext (sLit "Arg:")) 4 (ppr arg)]
1098
1099 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
1100 mkNonFunAppMsg fun_ty arg_ty arg
1101   = vcat [ptext (sLit "Non-function type in function position"),
1102               hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
1103               hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
1104               hang (ptext (sLit "Arg:")) 4 (ppr arg)]
1105
1106 mkKindErrMsg :: TyVar -> Type -> Message
1107 mkKindErrMsg tyvar arg_ty
1108   = vcat [ptext (sLit "Kinds don't match in type application:"),
1109           hang (ptext (sLit "Type variable:"))
1110                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
1111           hang (ptext (sLit "Arg type:"))
1112                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
1113
1114 mkCoAppErrMsg :: TyVar -> Type -> Message
1115 mkCoAppErrMsg tyvar arg_ty
1116   = vcat [ptext (sLit "Kinds don't match in coercion application:"),
1117           hang (ptext (sLit "Coercion variable:"))
1118                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
1119           hang (ptext (sLit "Arg coercion:"))
1120                  4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))]
1121
1122 mkTyAppMsg :: Type -> Type -> Message
1123 mkTyAppMsg ty arg_ty
1124   = vcat [text "Illegal type application:",
1125               hang (ptext (sLit "Exp type:"))
1126                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
1127               hang (ptext (sLit "Arg type:"))
1128                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
1129
1130 mkRhsMsg :: Id -> Type -> Message
1131 mkRhsMsg binder ty
1132   = vcat
1133     [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
1134             ppr binder],
1135      hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
1136      hsep [ptext (sLit "Rhs type:"), ppr ty]]
1137
1138 mkRhsPrimMsg :: Id -> CoreExpr -> Message
1139 mkRhsPrimMsg binder _rhs
1140   = vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
1141                      ppr binder],
1142               hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
1143              ]
1144
1145 mkStrictMsg :: Id -> Message
1146 mkStrictMsg binder
1147   = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
1148                      ppr binder],
1149               hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
1150              ]
1151
1152 mkArityMsg :: Id -> Message
1153 mkArityMsg binder
1154   = vcat [hsep [ptext (sLit "Demand type has "),
1155                      ppr (dmdTypeDepth dmd_ty),
1156                      ptext (sLit " arguments, rhs has "),
1157                      ppr (idArity binder),
1158                      ptext (sLit "arguments, "),
1159                      ppr binder],
1160               hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
1161
1162          ]
1163            where (StrictSig dmd_ty) = idStrictness binder
1164
1165 mkUnboxedTupleMsg :: Id -> Message
1166 mkUnboxedTupleMsg binder
1167   = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
1168           hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
1169
1170 mkCastErr :: Type -> Type -> Message
1171 mkCastErr from_ty expr_ty
1172   = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
1173           ptext (sLit "From-type:") <+> ppr from_ty,
1174           ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
1175     ]
1176
1177 dupVars :: [[Var]] -> Message
1178 dupVars vars
1179   = hang (ptext (sLit "Duplicate variables brought into scope"))
1180        2 (ppr vars)
1181 \end{code}