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