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