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
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import CoreSyn
  16 import CoreFVs          ( idFreeVars )
  17 import CoreUtils        ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
  18 import Unify            ( coreRefineTys )
  19 import Bag
  20 import Literal          ( literalType )
  21 import DataCon          ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConResTy, dataConWorkId )
  22 import TysWiredIn       ( tupleCon )
  23 import Var              ( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding )
  24 import VarSet
  25 import Name             ( getSrcLoc )
  26 import PprCore
  27 import ErrUtils         ( dumpIfSet_core, ghcExit, Message, showPass,
  28                           mkLocMessage, debugTraceMsg )
  29 import SrcLoc           ( SrcLoc, noSrcLoc, mkSrcSpan )
  30 import Type             ( Type, tyVarsOfType, coreEqType,
  31                           splitFunTy_maybe, mkTyVarTys,
  32                           splitForAllTy_maybe, splitTyConApp_maybe,
  33                           isUnLiftedType, typeKind,
  34                           isUnboxedTupleType, isSubKind,
  35                           substTyWith, emptyTvSubst, extendTvInScope,
  36                           TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
  37                           extendTvSubst, isInScope )
  38 import TyCon            ( isPrimTyCon )
  39 import BasicTypes       ( RecFlag(..), Boxity(..), isNonRec )
  40 import CmdLineOpts
  41 import Outputable
  42
  43 #ifdef DEBUG
  44 import Util             ( notNull )
  45 #endif
  46
  47 import Maybe
  48
  49 \end{code}
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection{End pass}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 @showPass@ 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 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
  63 endPass dflags pass_name dump_flag binds
  64   = do
  65         -- Report result size if required
  66         -- This has the side effect of forcing the intermediate to be evaluated
  67         debugTraceMsg dflags $
  68                 "    Result size = " ++ show (coreBindsSize binds)
  69
  70         -- Report verbosely, if required
  71         dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
  72
  73         -- Type check
  74         lintCoreBindings dflags pass_name binds
  75
  76         return binds
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 Checks that a set of core bindings is well-formed.  The PprStyle and String
  87 just control what we print in the event of an error.  The Bool value
  88 indicates whether we have done any specialisation yet (in which case we do
  89 some extra checks).
  90
  91 We check for
  92         (a) type errors
  93         (b) Out-of-scope type variables
  94         (c) Out-of-scope local variables
  95         (d) Ill-kinded types
  96
  97 If we have done specialisation the we check that there are
  98         (a) No top-level bindings of primitive (unboxed type)
  99
 100 Outstanding issues:
 101
 102     --
 103     -- Things are *not* OK if:
 104     --
 105     -- * Unsaturated type app before specialisation has been done;
 106     --
 107     -- * Oversaturated type app after specialisation (eta reduction
 108     --   may well be happening...);
 109
 110 \begin{code}
 111 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 112
 113 lintCoreBindings dflags whoDunnit binds
 114   | not (dopt Opt_DoCoreLinting dflags)
 115   = return ()
 116
 117 lintCoreBindings dflags whoDunnit binds
 118   = case (initL (lint_binds binds)) of
 119       Nothing       -> showPass dflags ("Core Linted result of " ++ whoDunnit)
 120       Just bad_news -> printDump (display bad_news)     >>
 121                        ghcExit 1
 122   where
 123         -- Put all the top-level binders in scope at the start
 124         -- This is because transformation rules can bring something
 125         -- into use 'unexpectedly'
 126     lint_binds binds = addInScopeVars (bindersOfBinds binds) $
 127                        mapM lint_bind binds
 128
 129     lint_bind (Rec prs)         = mapM_ (lintSingleBinding Recursive) prs
 130     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 131
 132     display bad_news
 133       = vcat [  text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 134                 bad_news,
 135                 ptext SLIT("*** Offending Program ***"),
 136                 pprCoreBindings binds,
 137                 ptext SLIT("*** End of Offense ***")
 138         ]
 139 \end{code}
 140
 141 %************************************************************************
 142 %*                                                                      *
 143 \subsection[lintUnfolding]{lintUnfolding}
 144 %*                                                                      *
 145 %************************************************************************
 146
 147 We use this to check all unfoldings that come in from interfaces
 148 (it is very painful to catch errors otherwise):
 149
 150 \begin{code}
 151 lintUnfolding :: SrcLoc
 152               -> [Var]          -- Treat these as in scope
 153               -> CoreExpr
 154               -> Maybe Message  -- Nothing => OK
 155
 156 lintUnfolding locn vars expr
 157   = initL (addLoc (ImportedUnfolding locn) $
 158            addInScopeVars vars             $
 159            lintCoreExpr expr)
 160 \end{code}
 161
 162 %************************************************************************
 163 %*                                                                      *
 164 \subsection[lintCoreBinding]{lintCoreBinding}
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 Check a core binding, returning the list of variables bound.
 169
 170 \begin{code}
 171 lintSingleBinding rec_flag (binder,rhs)
 172   = addLoc (RhsOf binder) $
 173          -- Check the rhs
 174     do { ty <- lintCoreExpr rhs
 175        ; lintBinder binder -- Check match to RHS type
 176        ; binder_ty <- applySubst binder_ty
 177        ; checkTys binder_ty ty (mkRhsMsg binder ty)
 178         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 179        ; checkL (not (isUnLiftedType binder_ty)
 180             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 181            (mkRhsPrimMsg binder rhs)
 182         -- Check whether binder's specialisations contain any out-of-scope variables
 183        ; mapM_ (checkBndrIdInScope binder) bndr_vars }
 184
 185         -- We should check the unfolding, if any, but this is tricky because
 186         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 187   where
 188     binder_ty = idType binder
 189     bndr_vars = varSetElems (idFreeVars binder)
 190 \end{code}
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[lintCoreExpr]{lintCoreExpr}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 \begin{code}
 199
 200 lintCoreExpr :: CoreExpr -> LintM Type
 201 -- The returned type has the substitution from the monad
 202 -- already applied to it:
 203 --      lintCoreExpr e subst = exprType (subst e)
 204
 205 lintCoreExpr (Var var)
 206   = do  { checkIdInScope var
 207         ; applySubst (idType var) }
 208
 209 lintCoreExpr (Lit lit)
 210   = return (literalType lit)
 211
 212 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 213   = do  { expr_ty <- lintCoreExpr expr
 214         ; to_ty <- lintTy to_ty
 215         ; from_ty <- lintTy from_ty
 216         ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
 217         ; return to_ty }
 218
 219 lintCoreExpr (Note other_note expr)
 220   = lintCoreExpr expr
 221
 222 lintCoreExpr (Let (NonRec bndr rhs) body)
 223   = do  { lintSingleBinding NonRecursive (bndr,rhs)
 224         ; addLoc (BodyOfLetRec [bndr])
 225                  (addInScopeVars [bndr] (lintCoreExpr body)) }
 226
 227 lintCoreExpr (Let (Rec pairs) body)
 228   = addInScopeVars bndrs        $
 229     do  { mapM (lintSingleBinding Recursive) pairs
 230         ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
 231   where
 232     bndrs = map fst pairs
 233
 234 lintCoreExpr (App fun (Type ty))
 235 -- This is like 'let' for types
 236 -- It's needed when dealing with desugarer output for GADTs. Consider
 237 --   data T = forall a. T a (a->Int) Bool
 238 --    f :: T -> ... ->
 239 --    f (T x f True)  = <e1>
 240 --    f (T y g False) = <e2>
 241 -- After desugaring we get
 242 --      f t b = case t of
 243 --                T a (x::a) (f::a->Int) (b:Bool) ->
 244 --                  case b of
 245 --                      True -> <e1>
 246 --                      False -> (/\b. let y=x; g=f in <e2>) a
 247 -- And for a reason I now forget, the ...<e2>... can mention a; so
 248 -- we want Lint to know that b=a.  Ugh.
 249 --
 250 -- I tried quite hard to make the necessity for this go away, by changing the
 251 -- desugarer, but the fundamental problem is this:
 252 --
 253 --      T a (x::a) (y::Int) -> let fail::a = ...
 254 --                             in (/\b. ...(case ... of
 255 --                                              True  -> x::b
 256 --                                              False -> fail)
 257 --                                ) a
 258 -- Now the inner case look as though it has incompatible branches.
 259   = go fun [ty]
 260   where
 261     go (App fun (Type ty)) tys
 262         = do { go fun (ty:tys) }
 263     go (Lam tv body) (ty:tys)
 264         = do  { checkL (isTyVar tv) (mkKindErrMsg tv ty)        -- Not quite accurate
 265               ; ty' <- lintTy ty;
 266               ; checkKinds tv ty'
 267                 -- Now extend the substitution so we
 268                 -- take advantage of it in the body
 269               ; addInScopeVars [tv] $
 270                 extendSubstL tv ty' $
 271                 go body tys }
 272     go fun tys
 273         = do  { fun_ty <- lintCoreExpr fun
 274               ; lintCoreArgs fun_ty (map Type tys) }
 275
 276 lintCoreExpr e@(App fun arg)
 277   = do  { ty <- lintCoreExpr fun
 278         ; addLoc (AnExpr e) $
 279           lintCoreArg ty arg }
 280
 281 lintCoreExpr (Lam var expr)
 282   = addLoc (LambdaBodyOf var) $
 283     do  { lintBinder var
 284         ; ty <- addInScopeVars [var] $
 285                 lintCoreExpr expr
 286         ; applySubst (mkPiType var ty) }
 287         -- The applySubst is needed to apply the subst to var
 288
 289 lintCoreExpr e@(Case scrut var alt_ty alts) =
 290        -- Check the scrutinee
 291   do { scrut_ty <- lintCoreExpr scrut
 292      ; alt_ty   <- lintTy alt_ty
 293      ; var_ty   <- lintTy (idType var)
 294         -- Don't use lintId on var, because unboxed tuple is legitimate
 295
 296      ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
 297
 298      -- If the binder is an unboxed tuple type, don't put it in scope
 299      ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
 300      ; addInScopeVars vars $
 301        do { -- Check the alternatives
 302             checkCaseAlts e scrut_ty alts
 303           ; mapM (lintCoreAlt scrut_ty alt_ty) alts
 304           ; return alt_ty } }
 305
 306 lintCoreExpr e@(Type ty)
 307   = addErrL (mkStrangeTyMsg e)
 308 \end{code}
 309
 310 %************************************************************************
 311 %*                                                                      *
 312 \subsection[lintCoreArgs]{lintCoreArgs}
 313 %*                                                                      *
 314 %************************************************************************
 315
 316 The basic version of these functions checks that the argument is a
 317 subtype of the required type, as one would expect.
 318
 319 \begin{code}
 320 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
 321 lintCoreArg  :: Type -> CoreArg   -> LintM Type
 322 -- First argument has already had substitution applied to it
 323 \end{code}
 324
 325 \begin{code}
 326 lintCoreArgs ty [] = return ty
 327 lintCoreArgs ty (a : args) =
 328   do { res <- lintCoreArg ty a
 329      ; lintCoreArgs res args }
 330
 331 lintCoreArg ty a@(Type arg_ty) =
 332   do { arg_ty <- lintTy arg_ty
 333      ; lintTyApp ty arg_ty }
 334
 335 lintCoreArg fun_ty arg =
 336        -- Make sure function type matches argument
 337   do { arg_ty <- lintCoreExpr arg
 338      ; let err = mkAppMsg fun_ty arg_ty
 339      ; case splitFunTy_maybe fun_ty of
 340         Just (arg,res) ->
 341           do { checkTys arg arg_ty err
 342              ; return res }
 343         _ -> addErrL err }
 344 \end{code}
 345
 346 \begin{code}
 347 -- Both args have had substitution applied
 348 lintTyApp ty arg_ty
 349   = case splitForAllTy_maybe ty of
 350       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 351
 352       Just (tyvar,body)
 353         -> do   { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
 354                 ; checkKinds tyvar arg_ty
 355                 ; return (substTyWith [tyvar] [arg_ty] body) }
 356
 357 lintTyApps fun_ty [] = return fun_ty
 358
 359 lintTyApps fun_ty (arg_ty : arg_tys) =
 360   do { fun_ty' <- lintTyApp fun_ty arg_ty
 361      ; lintTyApps fun_ty' arg_tys }
 362
 363 checkKinds tyvar arg_ty
 364         -- Arg type might be boxed for a function with an uncommitted
 365         -- tyvar; notably this is used so that we can give
 366         --      error :: forall a:*. String -> a
 367         -- and then apply it to both boxed and unboxed types.
 368   = checkL (argty_kind `isSubKind` tyvar_kind)
 369            (mkKindErrMsg tyvar arg_ty)
 370   where
 371     tyvar_kind = tyVarKind tyvar
 372     argty_kind = typeKind arg_ty
 373 \end{code}
 374
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsection[lintCoreAlts]{lintCoreAlts}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 \begin{code}
 383 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
 384 -- a) Check that the alts are non-empty
 385 -- b1) Check that the DEFAULT comes first, if it exists
 386 -- b2) Check that the others are in increasing order
 387 -- c) Check that there's a default for infinite types
 388 -- NB: Algebraic cases are not necessarily exhaustive, because
 389 --     the simplifer correctly eliminates case that can't
 390 --     possibly match.
 391
 392 checkCaseAlts e ty []
 393   = addErrL (mkNullAltsMsg e)
 394
 395 checkCaseAlts e ty alts =
 396   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
 397      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
 398      ; checkL (isJust maybe_deflt || not is_infinite_ty)
 399            (nonExhaustiveAltsMsg e) }
 400   where
 401     (con_alts, maybe_deflt) = findDefault alts
 402
 403         -- Check that successive alternatives have increasing tags
 404     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
 405     increasing_tag other                     = True
 406
 407     non_deflt (DEFAULT, _, _) = False
 408     non_deflt alt             = True
 409
 410     is_infinite_ty = case splitTyConApp_maybe ty of
 411                         Nothing                     -> False
 412                         Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
 413 \end{code}
 414
 415 \begin{code}
 416 checkAltExpr :: CoreExpr -> Type -> LintM ()
 417 checkAltExpr expr ty
 418   = do { actual_ty <- lintCoreExpr expr
 419        ; ty' <- applySubst ty
 420        ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
 421
 422 lintCoreAlt :: Type                     -- Type of scrutinee; a fixed point of
 423                                         --                    the substitution
 424             -> Type                     -- Type of the alternative
 425             -> CoreAlt
 426             -> LintM ()
 427
 428 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
 429   do { checkL (null args) (mkDefaultArgsMsg args)
 430      ; checkAltExpr rhs alt_ty }
 431
 432 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
 433   do { checkL (null args) (mkDefaultArgsMsg args)
 434      ; checkTys lit_ty scrut_ty
 435           (mkBadPatMsg lit_ty scrut_ty)
 436      ; checkAltExpr rhs alt_ty }
 437   where
 438     lit_ty = literalType lit
 439
 440 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 441   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
 442     tycon == dataConTyCon con
 443   = addLoc (CaseAlt alt) $
 444     addInScopeVars args $       -- Put the args in scope before lintBinder,
 445                                 -- because the Ids mention the type variables
 446     if isVanillaDataCon con then
 447     do  { mapM lintBinder args
 448                 -- FIX! Add check that all args are Ids.
 449                  -- Check the pattern
 450                  -- Scrutinee type must be a tycon applicn; checked by caller
 451                  -- This code is remarkably compact considering what it does!
 452                  -- NB: args must be in scope here so that the lintCoreArgs line works.
 453                  -- NB: relies on existential type args coming *after* ordinary type args
 454
 455         ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
 456                  -- Can just map Var as we know that this is a vanilla datacon
 457         ; con_result_ty <- lintCoreArgs con_type (map Var args)
 458         ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 459                  -- Check the RHS
 460         ; checkAltExpr rhs alt_ty }
 461
 462     else        -- GADT
 463     do  { let (tvs,ids) = span isTyVar args
 464               pat_res_ty = dataConResTy con (mkTyVarTys tvs)
 465
 466         ; subst <- getTvSubst
 467         ; case coreRefineTys tvs subst pat_res_ty scrut_ty of {
 468              Nothing   -> return () ;   -- Alternative is dead code
 469              Just senv -> updateTvSubstEnv senv $
 470     do  { tvs'     <- mapM lintTy (mkTyVarTys tvs)
 471         ; con_type <- lintTyApps (dataConRepType con) tvs'
 472         ; mapM lintBinder ids   -- Lint Ids in the refined world
 473         ; lintCoreArgs con_type (map Var ids)
 474         ; checkAltExpr rhs alt_ty
 475     } } }
 476
 477   | otherwise   -- Scrut-ty is wrong shape
 478   = addErrL (mkBadAltMsg scrut_ty alt)
 479 \end{code}
 480
 481 %************************************************************************
 482 %*                                                                      *
 483 \subsection[lint-types]{Types}
 484 %*                                                                      *
 485 %************************************************************************
 486
 487 \begin{code}
 488 lintBinder :: Var -> LintM ()
 489 lintBinder var | isId var  = lintId var >> return ()
 490                | otherwise = return ()
 491
 492 lintId :: Var -> LintM Type
 493 -- ToDo: lint its rules
 494 lintId id
 495   = do  { checkL (not (isUnboxedTupleType (idType id)))
 496                  (mkUnboxedTupleMsg id)
 497                 -- No variable can be bound to an unboxed tuple.
 498         ; lintTy (idType id) }
 499
 500 lintTy :: Type -> LintM Type
 501 -- Check the type, and apply the substitution to it
 502 -- ToDo: check the kind structure of the type
 503 lintTy ty
 504   = do  { ty' <- applySubst ty
 505         ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
 506         ; return ty' }
 507 \end{code}
 508
 509
 510 %************************************************************************
 511 %*                                                                      *
 512 \subsection[lint-monad]{The Lint monad}
 513 %*                                                                      *
 514 %************************************************************************
 515
 516 \begin{code}
 517 newtype LintM a =
 518    LintM { unLintM ::
 519             [LintLocInfo] ->         -- Locations
 520             TvSubst ->               -- Current type substitution; we also use this
 521                                      -- to keep track of all the variables in scope,
 522                                      -- both Ids and TyVars
 523             Bag Message ->           -- Error messages so far
 524             (Maybe a, Bag Message) } -- Result and error messages (if any)
 525
 526 instance Monad LintM where
 527   return x = LintM (\ loc subst errs -> (Just x, errs))
 528   fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
 529   m >>= k  = LintM (\ loc subst errs ->
 530                        let (res, errs') = unLintM m loc subst errs in
 531                          case res of
 532                            Just r -> unLintM (k r) loc subst errs'
 533                            Nothing -> (Nothing, errs'))
 534
 535 data LintLocInfo
 536   = RhsOf Id            -- The variable bound
 537   | LambdaBodyOf Id     -- The lambda-binder
 538   | BodyOfLetRec [Id]   -- One of the binders
 539   | CaseAlt CoreAlt     -- Pattern of a case alternative
 540   | AnExpr CoreExpr     -- Some expression
 541   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 542 \end{code}
 543
 544
 545 \begin{code}
 546 initL :: LintM a -> Maybe Message {- errors -}
 547 initL m
 548   = case unLintM m [] emptyTvSubst emptyBag of
 549       (_, errs) | isEmptyBag errs -> Nothing
 550                 | otherwise       -> Just (vcat (punctuate (text "") (bagToList errs)))
 551 \end{code}
 552
 553 \begin{code}
 554 checkL :: Bool -> Message -> LintM ()
 555 checkL True  msg = return ()
 556 checkL False msg = addErrL msg
 557
 558 addErrL :: Message -> LintM a
 559 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
 560
 561 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
 562 addErr subst errs_so_far msg locs
 563   = ASSERT( notNull locs )
 564     errs_so_far `snocBag` mk_msg msg
 565   where
 566    (loc, cxt1) = dumpLoc (head locs)
 567    cxts        = [snd (dumpLoc loc) | loc <- locs]
 568    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
 569                                       ptext SLIT("Substitution:") <+> ppr subst
 570                | otherwise          = cxt1
 571
 572    mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
 573
 574 addLoc :: LintLocInfo -> LintM a -> LintM a
 575 addLoc extra_loc m =
 576   LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
 577
 578 addInScopeVars :: [Var] -> LintM a -> LintM a
 579 addInScopeVars vars m =
 580   LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
 581
 582 -- gaw 2004
 583 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
 584 updateTvSubstEnv substenv m =
 585   LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
 586
 587 getTvSubst :: LintM TvSubst
 588 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
 589
 590 applySubst :: Type -> LintM Type
 591 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
 592
 593 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 594 extendSubstL tv ty m
 595   = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
 596 \end{code}
 597
 598 \begin{code}
 599 checkIdInScope :: Var -> LintM ()
 600 checkIdInScope id
 601   = do { checkL (not (id == oneTupleDataConId))
 602                 (ptext SLIT("Illegal one-tuple"))
 603        ; checkInScope (ptext SLIT("is out of scope")) id }
 604
 605 oneTupleDataConId :: Id -- Should not happen
 606 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
 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 =
 617  do { subst <- getTvSubst
 618     ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
 619              (hsep [ppr var, loc_msg]) }
 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 -- Assumes ty1,ty2 are have alrady had the substitution applied
 625 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
 626 \end{code}
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsection{Error messages}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 \begin{code}
 635 dumpLoc (RhsOf v)
 636   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 637
 638 dumpLoc (LambdaBodyOf b)
 639   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 640
 641 dumpLoc (BodyOfLetRec [])
 642   = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
 643
 644 dumpLoc (BodyOfLetRec bs@(_:_))
 645   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 646
 647 dumpLoc (AnExpr e)
 648   = (noSrcLoc, text "In the expression:" <+> ppr e)
 649
 650 dumpLoc (CaseAlt (con, args, rhs))
 651   = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
 652
 653 dumpLoc (ImportedUnfolding locn)
 654   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 655
 656 pp_binders :: [Var] -> SDoc
 657 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 658
 659 pp_binder :: Var -> SDoc
 660 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 661             | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 662 \end{code}
 663
 664 \begin{code}
 665 ------------------------------------------------------
 666 --      Messages for case expressions
 667
 668 mkNullAltsMsg :: CoreExpr -> Message
 669 mkNullAltsMsg e
 670   = hang (text "Case expression with no alternatives:")
 671          4 (ppr e)
 672
 673 mkDefaultArgsMsg :: [Var] -> Message
 674 mkDefaultArgsMsg args
 675   = hang (text "DEFAULT case with binders")
 676          4 (ppr args)
 677
 678 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
 679 mkCaseAltMsg e ty1 ty2
 680   = hang (text "Type of case alternatives not the same as the annotation on case:")
 681          4 (vcat [ppr ty1, ppr ty2, ppr e])
 682
 683 mkScrutMsg :: Id -> Type -> Message
 684 mkScrutMsg var scrut_ty
 685   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 686           text "Result binder type:" <+> ppr (idType var),
 687           text "Scrutinee type:" <+> ppr scrut_ty]
 688
 689
 690 mkNonDefltMsg e
 691   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 692 mkNonIncreasingAltsMsg e
 693   = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
 694
 695 nonExhaustiveAltsMsg :: CoreExpr -> Message
 696 nonExhaustiveAltsMsg e
 697   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 698
 699 mkBadPatMsg :: Type -> Type -> Message
 700 mkBadPatMsg con_result_ty scrut_ty
 701   = vcat [
 702         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 703         text "Pattern result type:" <+> ppr con_result_ty,
 704         text "Scrutinee type:" <+> ppr scrut_ty
 705     ]
 706
 707 mkBadAltMsg :: Type -> CoreAlt -> Message
 708 mkBadAltMsg scrut_ty alt
 709   = vcat [ text "Data alternative when scrutinee is not a tycon application",
 710            text "Scrutinee type:" <+> ppr scrut_ty,
 711            text "Alternative:" <+> pprCoreAlt alt ]
 712
 713 ------------------------------------------------------
 714 --      Other error messages
 715
 716 mkAppMsg :: Type -> Type -> Message
 717 mkAppMsg fun arg
 718   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 719               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 720               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 721
 722 mkKindErrMsg :: TyVar -> Type -> Message
 723 mkKindErrMsg tyvar arg_ty
 724   = vcat [ptext SLIT("Kinds don't match in type application:"),
 725           hang (ptext SLIT("Type variable:"))
 726                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 727           hang (ptext SLIT("Arg type:"))
 728                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 729
 730 mkTyAppMsg :: Type -> Type -> Message
 731 mkTyAppMsg ty arg_ty
 732   = vcat [text "Illegal type application:",
 733               hang (ptext SLIT("Exp type:"))
 734                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 735               hang (ptext SLIT("Arg type:"))
 736                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 737
 738 mkRhsMsg :: Id -> Type -> Message
 739 mkRhsMsg binder ty
 740   = vcat
 741     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 742             ppr binder],
 743      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 744      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 745
 746 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 747 mkRhsPrimMsg binder rhs
 748   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 749                      ppr binder],
 750               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 751              ]
 752
 753 mkUnboxedTupleMsg :: Id -> Message
 754 mkUnboxedTupleMsg binder
 755   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 756           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 757
 758 mkCoerceErr from_ty expr_ty
 759   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 760           ptext SLIT("From-type:") <+> ppr from_ty,
 761           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 762     ]
 763
 764 mkStrangeTyMsg e
 765   = ptext SLIT("Type where expression expected:") <+> ppr e
 766 \end{code}