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 PprType          ( {- instance Outputable Type -} )
  43 import TyCon            ( TyCon, isPrimTyCon, tyConDataCons )
  44 import BasicTypes       ( RecFlag(..), isNonRec )
  45 import Maybe
  46 import Outputable
  47
  48 infixr 9 `thenL`, `seqL`
  49 \end{code}
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection{Start and end pass}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 @beginPass@ and @endPass@ don't really belong here, but it makes a convenient
  58 place for them.  They print out stuff before and after core passes,
  59 and do Core Lint when necessary.
  60
  61 \begin{code}
  62 beginPass :: String -> IO ()
  63 beginPass pass_name
  64   | opt_D_show_passes
  65   = hPutStrLn stdout ("*** " ++ pass_name)
  66   | otherwise
  67   = return ()
  68
  69
  70 endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
  71 endPass pass_name dump_flag binds
  72   = do
  73         (binds, _) <- endPassWithRules pass_name dump_flag binds Nothing
  74         return binds
  75
  76 endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase
  77                  -> IO ([CoreBind], Maybe RuleBase)
  78 endPassWithRules pass_name dump_flag binds rules
  79   = do
  80         -- ToDo: force the rules?
  81
  82         -- Report result size if required
  83         -- This has the side effect of forcing the intermediate to be evaluated
  84         if opt_D_show_passes then
  85            hPutStrLn stdout ("    Result size = " ++ show (coreBindsSize binds))
  86          else
  87            return ()
  88
  89         -- Report verbosely, if required
  90         dumpIfSet dump_flag pass_name
  91                   (pprCoreBindings binds $$ case rules of
  92                                               Nothing -> empty
  93                                               Just rb -> pprRuleBase rb)
  94
  95         -- Type check
  96         lintCoreBindings pass_name binds
  97         -- ToDo: lint the rules
  98
  99         return (binds, rules)
 100 \end{code}
 101
 102
 103 %************************************************************************
 104 %*                                                                      *
 105 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
 106 %*                                                                      *
 107 %************************************************************************
 108
 109 Checks that a set of core bindings is well-formed.  The PprStyle and String
 110 just control what we print in the event of an error.  The Bool value
 111 indicates whether we have done any specialisation yet (in which case we do
 112 some extra checks).
 113
 114 We check for
 115         (a) type errors
 116         (b) Out-of-scope type variables
 117         (c) Out-of-scope local variables
 118         (d) Ill-kinded types
 119
 120 If we have done specialisation the we check that there are
 121         (a) No top-level bindings of primitive (unboxed type)
 122
 123 Outstanding issues:
 124
 125     --
 126     -- Things are *not* OK if:
 127     --
 128     -- * Unsaturated type app before specialisation has been done;
 129     --
 130     -- * Oversaturated type app after specialisation (eta reduction
 131     --   may well be happening...);
 132
 133 \begin{code}
 134 lintCoreBindings :: String -> [CoreBind] -> IO ()
 135
 136 lintCoreBindings whoDunnit binds
 137   | not opt_DoCoreLinting
 138   = return ()
 139
 140 lintCoreBindings whoDunnit binds
 141   = case (initL (lint_binds binds)) of
 142       (Nothing, Nothing)       -> done_lint
 143
 144       (Nothing, Just warnings) -> printDump (warn warnings) >>
 145                                   done_lint
 146
 147       (Just bad_news, warns)   -> printDump (display bad_news warns)    >>
 148                                   ghcExit 1
 149   where
 150         -- Put all the top-level binders in scope at the start
 151         -- This is because transformation rules can bring something
 152         -- into use 'unexpectedly'
 153     lint_binds binds = addInScopeVars (bindersOfBinds binds) $
 154                        mapL lint_bind binds
 155
 156     lint_bind (Rec prs)         = mapL (lintSingleBinding Recursive) prs        `seqL`
 157                                   returnL ()
 158     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 159
 160     done_lint = doIfSet opt_D_show_passes
 161                         (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
 162     warn warnings
 163       = vcat [
 164                 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
 165                 warnings,
 166                 offender
 167         ]
 168
 169     display bad_news warns
 170       = vcat [
 171                 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 172                 bad_news,
 173                 maybe offender warn warns  -- either offender or warnings (with offender)
 174         ]
 175
 176     offender
 177       = vcat [
 178                 ptext SLIT("*** Offending Program ***"),
 179                 pprCoreBindings binds,
 180                 ptext SLIT("*** End of Offense ***")
 181         ]
 182 \end{code}
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsection[lintUnfolding]{lintUnfolding}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 We use this to check all unfoldings that come in from interfaces
 191 (it is very painful to catch errors otherwise):
 192
 193 \begin{code}
 194 lintUnfolding :: SrcLoc
 195               -> [Var]          -- Treat these as in scope
 196               -> CoreExpr
 197               -> (Maybe Message, Maybe Message)         -- (Nothing,_) => OK
 198
 199 lintUnfolding locn vars expr
 200   | not opt_DoCoreLinting
 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
 591      | isNoSrcLoc loc = (loc, hang context 4 msg)
 592      | otherwise      = addErrLocHdrLine loc context msg
 593
 594 addLoc :: LintLocInfo -> LintM a -> LintM a
 595 addLoc extra_loc m loc scope errs warns
 596   = m (extra_loc:loc) scope errs warns
 597
 598 addInScopeVars :: [Var] -> LintM a -> LintM a
 599 addInScopeVars ids m loc scope errs warns
 600   = m loc (scope `unionVarSet` mkVarSet ids) errs warns
 601 \end{code}
 602
 603 \begin{code}
 604 checkIdInScope :: Var -> LintM ()
 605 checkIdInScope id
 606   = checkInScope (ptext SLIT("is out of scope")) id
 607
 608 checkBndrIdInScope :: Var -> Var -> LintM ()
 609 checkBndrIdInScope binder id
 610   = checkInScope msg id
 611     where
 612      msg = ptext SLIT("is out of scope inside info for") <+>
 613            ppr binder
 614
 615 checkInScope :: SDoc -> Var -> LintM ()
 616 checkInScope loc_msg var loc scope errs warns
 617   |  mustHaveLocalBinding var && not (var `elemVarSet` scope)
 618   = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
 619   | otherwise
 620   = nopL loc scope errs warns
 621
 622 checkTys :: Type -> Type -> Message -> LintM ()
 623 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 624 -- annotations need only be consistent, not equal)
 625 checkTys ty1 ty2 msg
 626   | ty1 == ty2 = nopL
 627   | otherwise  = addErrL msg
 628 \end{code}
 629
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsection{Error messages}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 \begin{code}
 638 dumpLoc (RhsOf v)
 639   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 640
 641 dumpLoc (LambdaBodyOf b)
 642   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 643
 644 dumpLoc (BodyOfLetRec [])
 645   = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
 646
 647 dumpLoc (BodyOfLetRec bs@(_:_))
 648   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 649
 650 dumpLoc (AnExpr e)
 651   = (noSrcLoc, text "In the expression:" <+> ppr e)
 652
 653 dumpLoc (CaseAlt (con, args, rhs))
 654   = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
 655
 656 dumpLoc (ImportedUnfolding locn)
 657   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 658
 659 pp_binders :: [Var] -> SDoc
 660 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 661
 662 pp_binder :: Var -> SDoc
 663 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 664             | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 665 \end{code}
 666
 667 \begin{code}
 668 ------------------------------------------------------
 669 --      Messages for case expressions
 670
 671 mkNullAltsMsg :: CoreExpr -> Message
 672 mkNullAltsMsg e
 673   = hang (text "Case expression with no alternatives:")
 674          4 (ppr e)
 675
 676 mkDefaultArgsMsg :: [Var] -> Message
 677 mkDefaultArgsMsg args
 678   = hang (text "DEFAULT case with binders")
 679          4 (ppr args)
 680
 681 mkCaseAltMsg :: CoreExpr -> Message
 682 mkCaseAltMsg e
 683   = hang (text "Type of case alternatives not the same:")
 684          4 (ppr e)
 685
 686 mkScrutMsg :: Id -> Type -> Message
 687 mkScrutMsg var scrut_ty
 688   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 689           text "Result binder type:" <+> ppr (idType var),
 690           text "Scrutinee type:" <+> ppr scrut_ty]
 691
 692 badAltsMsg :: CoreExpr -> Message
 693 badAltsMsg e
 694   = hang (text "Case statement scrutinee is not a data type:")
 695          4 (ppr e)
 696
 697 nonExhaustiveAltsMsg :: CoreExpr -> Message
 698 nonExhaustiveAltsMsg e
 699   = hang (text "Case expression with non-exhaustive alternatives")
 700          4 (ppr e)
 701
 702 mkBadPatMsg :: Type -> Type -> Message
 703 mkBadPatMsg con_result_ty scrut_ty
 704   = vcat [
 705         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 706         text "Pattern result type:" <+> ppr con_result_ty,
 707         text "Scrutinee type:" <+> ppr scrut_ty
 708     ]
 709
 710 ------------------------------------------------------
 711 --      Other error messages
 712
 713 mkAppMsg :: Type -> Type -> Message
 714 mkAppMsg fun arg
 715   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 716               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 717               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 718
 719 mkKindErrMsg :: TyVar -> Type -> Message
 720 mkKindErrMsg tyvar arg_ty
 721   = vcat [ptext SLIT("Kinds don't match in type application:"),
 722           hang (ptext SLIT("Type variable:"))
 723                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 724           hang (ptext SLIT("Arg type:"))
 725                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 726
 727 mkTyAppMsg :: Type -> Type -> Message
 728 mkTyAppMsg ty arg_ty
 729   = vcat [text "Illegal type application:",
 730               hang (ptext SLIT("Exp type:"))
 731                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 732               hang (ptext SLIT("Arg type:"))
 733                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 734
 735 mkRhsMsg :: Id -> Type -> Message
 736 mkRhsMsg binder ty
 737   = vcat
 738     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 739             ppr binder],
 740      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 741      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 742
 743 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 744 mkRhsPrimMsg binder rhs
 745   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 746                      ppr binder],
 747               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 748              ]
 749
 750 mkUnboxedTupleMsg :: Id -> Message
 751 mkUnboxedTupleMsg binder
 752   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 753           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 754
 755 mkCoerceErr from_ty expr_ty
 756   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 757           ptext SLIT("From-type:") <+> ppr from_ty,
 758           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 759     ]
 760
 761 mkStrangeTyMsg e
 762   = ptext SLIT("Type where expression expected:") <+> ppr e
 763 \end{code}