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