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