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