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