ghc/compiler/coreSyn/CoreLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
   5
   6 \begin{code}
   7 module CoreLint (
   8         lintCoreBindings,
   9         lintUnfolding,
  10         showPass, endPass, endPassWithRules
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import IO               ( hPutStr, hPutStrLn, stdout )
  16
  17 import CoreSyn
  18 import Rules            ( RuleBase, pprRuleBase )
  19 import CoreFVs          ( idFreeVars, mustHaveLocalBinding )
  20 import CoreUtils        ( exprOkForSpeculation, coreBindsSize, mkPiType )
  21
  22 import Bag
  23 import Literal          ( literalType )
  24 import DataCon          ( dataConRepType )
  25 import Var              ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
  26 import VarSet
  27 import Subst            ( mkTyVarSubst, substTy )
  28 import Name             ( getSrcLoc )
  29 import PprCore
  30 import ErrUtils         ( doIfSet, dumpIfSet, ghcExit, Message, showPass,
  31                           ErrMsg, addErrLocHdrLine, pprBagOfErrors,
  32                           WarnMsg, pprBagOfWarnings)
  33 import SrcLoc           ( SrcLoc, noSrcLoc )
  34 import Type             ( Type, tyVarsOfType,
  35                           splitFunTy_maybe, mkTyVarTy,
  36                           splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
  37                           isUnLiftedType, typeKind,
  38                           isUnboxedTupleType,
  39                           hasMoreBoxityInfo
  40                         )
  41 import TyCon            ( isPrimTyCon )
  42 import BasicTypes       ( RecFlag(..), isNonRec )
  43 import CmdLineOpts
  44 import Maybe
  45 import Outputable
  46
  47 infixr 9 `thenL`, `seqL`
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{Start and end pass}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 @beginPass@ and @endPass@ don't really belong here, but it makes a convenient
  57 place for them.  They print out stuff before and after core passes,
  58 and do Core Lint when necessary.
  59
  60 \begin{code}
  61 endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
  62 endPass dflags pass_name dump_flag binds
  63   = do
  64         (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
  65         return binds
  66
  67 endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase
  68                  -> IO ([CoreBind], Maybe RuleBase)
  69 endPassWithRules dflags pass_name dump_flag binds rules
  70   = do
  71         -- ToDo: force the rules?
  72
  73         -- Report result size if required
  74         -- This has the side effect of forcing the intermediate to be evaluated
  75         if verbosity dflags >= 2 then
  76            hPutStrLn stdout ("    Result size = " ++ show (coreBindsSize binds))
  77          else
  78            return ()
  79
  80         -- Report verbosely, if required
  81         dumpIfSet dump_flag pass_name
  82                   (pprCoreBindings binds $$ case rules of
  83                                               Nothing -> empty
  84                                               Just rb -> pprRuleBase rb)
  85
  86         -- Type check
  87         lintCoreBindings dflags pass_name binds
  88         -- ToDo: lint the rules
  89
  90         return (binds, rules)
  91 \end{code}
  92
  93
  94 %************************************************************************
  95 %*                                                                      *
  96 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  97 %*                                                                      *
  98 %************************************************************************
  99
 100 Checks that a set of core bindings is well-formed.  The PprStyle and String
 101 just control what we print in the event of an error.  The Bool value
 102 indicates whether we have done any specialisation yet (in which case we do
 103 some extra checks).
 104
 105 We check for
 106         (a) type errors
 107         (b) Out-of-scope type variables
 108         (c) Out-of-scope local variables
 109         (d) Ill-kinded types
 110
 111 If we have done specialisation the we check that there are
 112         (a) No top-level bindings of primitive (unboxed type)
 113
 114 Outstanding issues:
 115
 116     --
 117     -- Things are *not* OK if:
 118     --
 119     -- * Unsaturated type app before specialisation has been done;
 120     --
 121     -- * Oversaturated type app after specialisation (eta reduction
 122     --   may well be happening...);
 123
 124 \begin{code}
 125 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 126
 127 lintCoreBindings dflags whoDunnit binds
 128   | not (dopt Opt_DoCoreLinting dflags)
 129   = return ()
 130
 131 lintCoreBindings dflags whoDunnit binds
 132   = case (initL (lint_binds binds)) of
 133       (Nothing, Nothing)       -> done_lint
 134
 135       (Nothing, Just warnings) -> printDump (warn warnings) >>
 136                                   done_lint
 137
 138       (Just bad_news, warns)   -> printDump (display bad_news warns)    >>
 139                                   ghcExit 1
 140   where
 141         -- Put all the top-level binders in scope at the start
 142         -- This is because transformation rules can bring something
 143         -- into use 'unexpectedly'
 144     lint_binds binds = addInScopeVars (bindersOfBinds binds) $
 145                        mapL lint_bind binds
 146
 147     lint_bind (Rec prs)         = mapL (lintSingleBinding Recursive) prs        `seqL`
 148                                   returnL ()
 149     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 150
 151     done_lint = doIfSet (verbosity dflags >= 2)
 152                         (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
 153     warn warnings
 154       = vcat [
 155                 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
 156                 warnings,
 157                 offender
 158         ]
 159
 160     display bad_news warns
 161       = vcat [
 162                 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 163                 bad_news,
 164                 maybe offender warn warns  -- either offender or warnings (with offender)
 165         ]
 166
 167     offender
 168       = vcat [
 169                 ptext SLIT("*** Offending Program ***"),
 170                 pprCoreBindings binds,
 171                 ptext SLIT("*** End of Offense ***")
 172         ]
 173 \end{code}
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection[lintUnfolding]{lintUnfolding}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 We use this to check all unfoldings that come in from interfaces
 182 (it is very painful to catch errors otherwise):
 183
 184 \begin{code}
 185 lintUnfolding :: DynFlags
 186               -> SrcLoc
 187               -> [Var]          -- Treat these as in scope
 188               -> CoreExpr
 189               -> (Maybe Message, Maybe Message)         -- (Nothing,_) => OK
 190
 191 lintUnfolding dflags locn vars expr
 192   | not (dopt Opt_DoCoreLinting dflags)
 193   = (Nothing, Nothing)
 194
 195   | otherwise
 196   = initL (addLoc (ImportedUnfolding locn) $
 197            addInScopeVars vars             $
 198            lintCoreExpr expr)
 199 \end{code}
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection[lintCoreBinding]{lintCoreBinding}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 Check a core binding, returning the list of variables bound.
 208
 209 \begin{code}
 210 lintSingleBinding rec_flag (binder,rhs)
 211   = addLoc (RhsOf binder) $
 212
 213         -- Check the rhs
 214     lintCoreExpr rhs                            `thenL` \ ty ->
 215
 216         -- Check match to RHS type
 217     lintBinder binder                           `seqL`
 218     checkTys binder_ty ty (mkRhsMsg binder ty)  `seqL`
 219
 220         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 221     checkL (not (isUnLiftedType binder_ty)
 222             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 223            (mkRhsPrimMsg binder rhs)            `seqL`
 224
 225         -- Check whether binder's specialisations contain any out-of-scope variables
 226     mapL (checkBndrIdInScope binder) bndr_vars  `seqL`
 227     returnL ()
 228
 229         -- We should check the unfolding, if any, but this is tricky because
 230         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 231   where
 232     binder_ty = idType binder
 233     bndr_vars = varSetElems (idFreeVars binder)
 234 \end{code}
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsection[lintCoreExpr]{lintCoreExpr}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 \begin{code}
 243 lintCoreExpr :: CoreExpr -> LintM Type
 244
 245 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
 246 lintCoreExpr (Lit lit) = returnL (literalType lit)
 247
 248 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 249   = lintCoreExpr expr   `thenL` \ expr_ty ->
 250     lintTy to_ty        `seqL`
 251     lintTy from_ty      `seqL`
 252     checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)      `seqL`
 253     returnL to_ty
 254
 255 lintCoreExpr (Note other_note expr)
 256   = lintCoreExpr expr
 257
 258 lintCoreExpr (Let (NonRec bndr rhs) body)
 259   = lintSingleBinding NonRecursive (bndr,rhs)   `seqL`
 260     addLoc (BodyOfLetRec [bndr])
 261            (addInScopeVars [bndr] (lintCoreExpr body))
 262
 263 lintCoreExpr (Let (Rec pairs) body)
 264   = addInScopeVars bndrs        $
 265     mapL (lintSingleBinding Recursive) pairs    `seqL`
 266     addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
 267   where
 268     bndrs = map fst pairs
 269
 270 lintCoreExpr e@(App fun arg)
 271   = lintCoreExpr fun    `thenL` \ ty ->
 272     addLoc (AnExpr e)   $
 273     lintCoreArg ty arg
 274
 275 lintCoreExpr (Lam var expr)
 276   = addLoc (LambdaBodyOf var)   $
 277     (if isId var then
 278        checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
 279      else
 280        returnL ())
 281                                 `seqL`
 282     (addInScopeVars [var]       $
 283      lintCoreExpr expr          `thenL` \ ty ->
 284
 285      returnL (mkPiType var ty))
 286
 287 lintCoreExpr e@(Case scrut var alts)
 288  =      -- Check the scrutinee
 289    lintCoreExpr scrut                   `thenL` \ scrut_ty ->
 290
 291         -- Check the binder
 292    lintBinder var                                               `seqL`
 293
 294         -- If this is an unboxed tuple case, then the binder must be dead
 295    {-
 296    checkL (if isUnboxedTupleType (idType var)
 297                 then isDeadBinder var
 298                 else True) (mkUnboxedTupleMsg var)              `seqL`
 299    -}
 300
 301    checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty)     `seqL`
 302
 303    addInScopeVars [var]                         (
 304
 305         -- Check the alternatives
 306    checkAllCasesCovered e scrut_ty alts `seqL`
 307
 308    mapL (lintCoreAlt scrut_ty) alts             `thenL` \ (alt_ty : alt_tys) ->
 309    mapL (check alt_ty) alt_tys                  `seqL`
 310    returnL alt_ty)
 311  where
 312    check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
 313
 314 lintCoreExpr e@(Type ty)
 315   = addErrL (mkStrangeTyMsg e)
 316 \end{code}
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection[lintCoreArgs]{lintCoreArgs}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 The basic version of these functions checks that the argument is a
 325 subtype of the required type, as one would expect.
 326
 327 \begin{code}
 328 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
 329 lintCoreArgs = lintCoreArgs0 checkTys
 330
 331 lintCoreArg :: Type -> CoreArg -> LintM Type
 332 lintCoreArg = lintCoreArg0 checkTys
 333 \end{code}
 334
 335 The primitive version of these functions takes a check argument,
 336 allowing a different comparison.
 337
 338 \begin{code}
 339 lintCoreArgs0 check_tys ty [] = returnL ty
 340 lintCoreArgs0 check_tys ty (a : args)
 341   = lintCoreArg0  check_tys ty a        `thenL` \ res ->
 342     lintCoreArgs0 check_tys res args
 343
 344 lintCoreArg0 check_tys ty a@(Type arg_ty)
 345   = lintTy arg_ty                       `seqL`
 346     lintTyApp ty arg_ty
 347
 348 lintCoreArg0 check_tys fun_ty arg
 349   = -- Make sure function type matches argument
 350     lintCoreExpr arg            `thenL` \ arg_ty ->
 351     let
 352       err = mkAppMsg fun_ty arg_ty
 353     in
 354     case splitFunTy_maybe fun_ty of
 355       Just (arg,res) -> check_tys arg arg_ty err `seqL`
 356                         returnL res
 357       _              -> addErrL err
 358 \end{code}
 359
 360 \begin{code}
 361 lintTyApp ty arg_ty
 362   = case splitForAllTy_maybe ty of
 363       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 364
 365       Just (tyvar,body) ->
 366         if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
 367         let
 368             tyvar_kind = tyVarKind tyvar
 369             argty_kind = typeKind arg_ty
 370         in
 371         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 372                 -- Arg type might be boxed for a function with an uncommitted
 373                 -- tyvar; notably this is used so that we can give
 374                 --      error :: forall a:*. String -> a
 375                 -- and then apply it to both boxed and unboxed types.
 376          then
 377             returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
 378         else
 379             addErrL (mkKindErrMsg tyvar arg_ty)
 380
 381 lintTyApps fun_ty []
 382   = returnL fun_ty
 383
 384 lintTyApps fun_ty (arg_ty : arg_tys)
 385   = lintTyApp fun_ty arg_ty             `thenL` \ fun_ty' ->
 386     lintTyApps fun_ty' arg_tys
 387 \end{code}
 388
 389
 390
 391 %************************************************************************
 392 %*                                                                      *
 393 \subsection[lintCoreAlts]{lintCoreAlts}
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 \begin{code}
 398 checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
 399
 400 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
 401
 402 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
 403
 404 checkAllCasesCovered e scrut_ty alts
 405   = case splitTyConApp_maybe scrut_ty of {
 406         Nothing -> addErrL (badAltsMsg e);
 407         Just (tycon, tycon_arg_tys) ->
 408
 409     if isPrimTyCon tycon then
 410         checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
 411     else
 412 {-              No longer needed
 413 #ifdef DEBUG
 414         -- Algebraic cases are not necessarily exhaustive, because
 415         -- the simplifer correctly eliminates case that can't
 416         -- possibly match.
 417         -- This code just emits a message to say so
 418     let
 419         missing_cons    = filter not_in_alts (tyConDataCons tycon)
 420         not_in_alts con = all (not_in_alt con) alts
 421         not_in_alt con (DataCon con', _, _) = con /= con'
 422         not_in_alt con other                = True
 423
 424         case_bndr = case e of { Case _ bndr alts -> bndr }
 425     in
 426     if not (hasDefault alts || null missing_cons) then
 427         pprTrace "Exciting (but not a problem)!  Non-exhaustive case:"
 428                  (ppr case_bndr <+> ppr missing_cons)
 429                  nopL
 430     else
 431 #endif
 432 -}
 433     nopL }
 434
 435 hasDefault []                     = False
 436 hasDefault ((DEFAULT,_,_) : alts) = True
 437 hasDefault (alt           : alts) = hasDefault alts
 438 \end{code}
 439
 440 \begin{code}
 441 lintCoreAlt :: Type                     -- Type of scrutinee
 442             -> CoreAlt
 443             -> LintM Type               -- Type of alternatives
 444
 445 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
 446   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 447     lintCoreExpr rhs
 448
 449 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
 450   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 451     checkTys lit_ty scrut_ty
 452              (mkBadPatMsg lit_ty scrut_ty)      `seqL`
 453     lintCoreExpr rhs
 454   where
 455     lit_ty = literalType lit
 456
 457 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
 458   = addLoc (CaseAlt alt) (
 459
 460     mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
 461                         (mkUnboxedTupleMsg arg)) args `seqL`
 462
 463     addInScopeVars args (
 464
 465         -- Check the pattern
 466         -- Scrutinee type must be a tycon applicn; checked by caller
 467         -- This code is remarkably compact considering what it does!
 468         -- NB: args must be in scope here so that the lintCoreArgs line works.
 469     case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
 470         lintTyApps (dataConRepType con) tycon_arg_tys   `thenL` \ con_type ->
 471         lintCoreArgs con_type (map mk_arg args)         `thenL` \ con_result_ty ->
 472         checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 473     }                                           `seqL`
 474
 475         -- Check the RHS
 476     lintCoreExpr rhs
 477     ))
 478   where
 479     mk_arg b | isTyVar b = Type (mkTyVarTy b)
 480              | isId    b = Var b
 481              | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
 482 \end{code}
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsection[lint-types]{Types}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 \begin{code}
 491 lintBinder :: Var -> LintM ()
 492 lintBinder v = nopL
 493 -- ToDo: lint its type
 494 -- ToDo: lint its rules
 495
 496 lintTy :: Type -> LintM ()
 497 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
 498             returnL ()
 499         -- ToDo: check the kind structure of the type
 500 \end{code}
 501
 502
 503 %************************************************************************
 504 %*                                                                      *
 505 \subsection[lint-monad]{The Lint monad}
 506 %*                                                                      *
 507 %************************************************************************
 508
 509 \begin{code}
 510 type LintM a = [LintLocInfo]    -- Locations
 511             -> IdSet            -- Local vars in scope
 512             -> Bag ErrMsg       -- Error messages so far
 513             -> Bag WarnMsg      -- Warning messages so far
 514             -> (Maybe a, Bag ErrMsg, Bag WarnMsg)  -- Result and error/warning messages (if any)
 515
 516 data LintLocInfo
 517   = RhsOf Id            -- The variable bound
 518   | LambdaBodyOf Id     -- The lambda-binder
 519   | BodyOfLetRec [Id]   -- One of the binders
 520   | CaseAlt CoreAlt     -- Pattern of a case alternative
 521   | AnExpr CoreExpr     -- Some expression
 522   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 523 \end{code}
 524
 525 \begin{code}
 526 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
 527 initL m
 528   = case m [] emptyVarSet emptyBag emptyBag of
 529       (_, errs, warns) -> (ifNonEmptyBag errs  pprBagOfErrors,
 530                            ifNonEmptyBag warns pprBagOfWarnings)
 531   where
 532     ifNonEmptyBag bag f | isEmptyBag bag = Nothing
 533                         | otherwise      = Just (f bag)
 534
 535 returnL :: a -> LintM a
 536 returnL r loc scope errs warns = (Just r, errs, warns)
 537
 538 nopL :: LintM a
 539 nopL loc scope errs warns = (Nothing, errs, warns)
 540
 541 thenL :: LintM a -> (a -> LintM b) -> LintM b
 542 thenL m k loc scope errs warns
 543   = case m loc scope errs warns of
 544       (Just r, errs', warns')  -> k r loc scope errs' warns'
 545       (Nothing, errs', warns') -> (Nothing, errs', warns')
 546
 547 seqL :: LintM a -> LintM b -> LintM b
 548 seqL m k loc scope errs warns
 549   = case m loc scope errs warns of
 550       (_, errs', warns') -> k loc scope errs' warns'
 551
 552 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 553 mapL f [] = returnL []
 554 mapL f (x:xs)
 555   = f x         `thenL` \ r ->
 556     mapL f xs   `thenL` \ rs ->
 557     returnL (r:rs)
 558 \end{code}
 559
 560 \begin{code}
 561 checkL :: Bool -> Message -> LintM ()
 562 checkL True  msg = nopL
 563 checkL False msg = addErrL msg
 564
 565 addErrL :: Message -> LintM a
 566 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
 567
 568 addWarnL :: Message -> LintM a
 569 addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
 570
 571 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
 572 -- errors or warnings, actually... they're the same type.
 573 addErr errs_so_far msg locs
 574   = ASSERT( not (null locs) )
 575     errs_so_far `snocBag` mk_msg msg
 576   where
 577    (loc, cxt1) = dumpLoc (head locs)
 578    cxts        = [snd (dumpLoc loc) | loc <- locs]
 579    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
 580                | otherwise          = cxt1
 581
 582    mk_msg msg = addErrLocHdrLine loc context msg
 583
 584 addLoc :: LintLocInfo -> LintM a -> LintM a
 585 addLoc extra_loc m loc scope errs warns
 586   = m (extra_loc:loc) scope errs warns
 587
 588 addInScopeVars :: [Var] -> LintM a -> LintM a
 589 addInScopeVars ids m loc scope errs warns
 590   = m loc (scope `unionVarSet` mkVarSet ids) errs warns
 591 \end{code}
 592
 593 \begin{code}
 594 checkIdInScope :: Var -> LintM ()
 595 checkIdInScope id
 596   = checkInScope (ptext SLIT("is out of scope")) id
 597
 598 checkBndrIdInScope :: Var -> Var -> LintM ()
 599 checkBndrIdInScope binder id
 600   = checkInScope msg id
 601     where
 602      msg = ptext SLIT("is out of scope inside info for") <+>
 603            ppr binder
 604
 605 checkInScope :: SDoc -> Var -> LintM ()
 606 checkInScope loc_msg var loc scope errs warns
 607   |  mustHaveLocalBinding var && not (var `elemVarSet` scope)
 608   = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
 609   | otherwise
 610   = nopL loc scope errs warns
 611
 612 checkTys :: Type -> Type -> Message -> LintM ()
 613 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 614 -- annotations need only be consistent, not equal)
 615 checkTys ty1 ty2 msg
 616   | ty1 == ty2 = nopL
 617   | otherwise  = addErrL msg
 618 \end{code}
 619
 620
 621 %************************************************************************
 622 %*                                                                      *
 623 \subsection{Error messages}
 624 %*                                                                      *
 625 %************************************************************************
 626
 627 \begin{code}
 628 dumpLoc (RhsOf v)
 629   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 630
 631 dumpLoc (LambdaBodyOf b)
 632   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 633
 634 dumpLoc (BodyOfLetRec [])
 635   = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
 636
 637 dumpLoc (BodyOfLetRec bs@(_:_))
 638   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 639
 640 dumpLoc (AnExpr e)
 641   = (noSrcLoc, text "In the expression:" <+> ppr e)
 642
 643 dumpLoc (CaseAlt (con, args, rhs))
 644   = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
 645
 646 dumpLoc (ImportedUnfolding locn)
 647   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 648
 649 pp_binders :: [Var] -> SDoc
 650 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 651
 652 pp_binder :: Var -> SDoc
 653 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 654             | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 655 \end{code}
 656
 657 \begin{code}
 658 ------------------------------------------------------
 659 --      Messages for case expressions
 660
 661 mkNullAltsMsg :: CoreExpr -> Message
 662 mkNullAltsMsg e
 663   = hang (text "Case expression with no alternatives:")
 664          4 (ppr e)
 665
 666 mkDefaultArgsMsg :: [Var] -> Message
 667 mkDefaultArgsMsg args
 668   = hang (text "DEFAULT case with binders")
 669          4 (ppr args)
 670
 671 mkCaseAltMsg :: CoreExpr -> Message
 672 mkCaseAltMsg e
 673   = hang (text "Type of case alternatives not the same:")
 674          4 (ppr e)
 675
 676 mkScrutMsg :: Id -> Type -> Message
 677 mkScrutMsg var scrut_ty
 678   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 679           text "Result binder type:" <+> ppr (idType var),
 680           text "Scrutinee type:" <+> ppr scrut_ty]
 681
 682 badAltsMsg :: CoreExpr -> Message
 683 badAltsMsg e
 684   = hang (text "Case statement scrutinee is not a data type:")
 685          4 (ppr e)
 686
 687 nonExhaustiveAltsMsg :: CoreExpr -> Message
 688 nonExhaustiveAltsMsg e
 689   = hang (text "Case expression with non-exhaustive alternatives")
 690          4 (ppr e)
 691
 692 mkBadPatMsg :: Type -> Type -> Message
 693 mkBadPatMsg con_result_ty scrut_ty
 694   = vcat [
 695         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 696         text "Pattern result type:" <+> ppr con_result_ty,
 697         text "Scrutinee type:" <+> ppr scrut_ty
 698     ]
 699
 700 ------------------------------------------------------
 701 --      Other error messages
 702
 703 mkAppMsg :: Type -> Type -> Message
 704 mkAppMsg fun arg
 705   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 706               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 707               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 708
 709 mkKindErrMsg :: TyVar -> Type -> Message
 710 mkKindErrMsg tyvar arg_ty
 711   = vcat [ptext SLIT("Kinds don't match in type application:"),
 712           hang (ptext SLIT("Type variable:"))
 713                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 714           hang (ptext SLIT("Arg type:"))
 715                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 716
 717 mkTyAppMsg :: Type -> Type -> Message
 718 mkTyAppMsg ty arg_ty
 719   = vcat [text "Illegal type application:",
 720               hang (ptext SLIT("Exp type:"))
 721                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 722               hang (ptext SLIT("Arg type:"))
 723                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 724
 725 mkRhsMsg :: Id -> Type -> Message
 726 mkRhsMsg binder ty
 727   = vcat
 728     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 729             ppr binder],
 730      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 731      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 732
 733 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 734 mkRhsPrimMsg binder rhs
 735   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 736                      ppr binder],
 737               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 738              ]
 739
 740 mkUnboxedTupleMsg :: Id -> Message
 741 mkUnboxedTupleMsg binder
 742   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 743           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 744
 745 mkCoerceErr from_ty expr_ty
 746   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 747           ptext SLIT("From-type:") <+> ppr from_ty,
 748           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 749     ]
 750
 751 mkStrangeTyMsg e
 752   = ptext SLIT("Type where expression expected:") <+> ppr e
 753 \end{code}