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