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 )
  18 import Unify            ( coreRefineTys )
  19 import Bag
  20 import Literal          ( literalType )
  21 import DataCon          ( dataConRepType, isVanillaDataCon, dataConTyCon, 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, mkForAllTy, mkFunTy,
  34                           isUnboxedTupleType, isSubKind,
  35                           substTyWith, emptyTvSubst, extendTvInScope,
  36                           TvSubst, TvSubstEnv, mkTvSubst, 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 type InType  = Type     -- Substitution not yet applied
 201 type OutType = Type     -- Substitution has been applied to this
 202
 203 lintCoreExpr :: CoreExpr -> LintM OutType
 204 -- The returned type has the substitution from the monad
 205 -- already applied to it:
 206 --      lintCoreExpr e subst = exprType (subst e)
 207
 208 lintCoreExpr (Var var)
 209   = do  { checkIdInScope var
 210         ; applySubst (idType var) }
 211
 212 lintCoreExpr (Lit lit)
 213   = return (literalType lit)
 214
 215 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 216   = do  { expr_ty <- lintCoreExpr expr
 217         ; to_ty <- lintTy to_ty
 218         ; from_ty <- lintTy from_ty
 219         ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
 220         ; return to_ty }
 221
 222 lintCoreExpr (Note other_note expr)
 223   = lintCoreExpr expr
 224
 225 lintCoreExpr (Let (NonRec bndr rhs) body)
 226   = do  { lintSingleBinding NonRecursive (bndr,rhs)
 227         ; addLoc (BodyOfLetRec [bndr])
 228                  (addInScopeVars [bndr] (lintCoreExpr body)) }
 229
 230 lintCoreExpr (Let (Rec pairs) body)
 231   = addInScopeVars bndrs        $
 232     do  { mapM (lintSingleBinding Recursive) pairs
 233         ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
 234   where
 235     bndrs = map fst pairs
 236
 237 lintCoreExpr (App fun (Type ty))
 238 -- This is like 'let' for types
 239 -- It's needed when dealing with desugarer output for GADTs. Consider
 240 --   data T = forall a. T a (a->Int) Bool
 241 --    f :: T -> ... ->
 242 --    f (T x f True)  = <e1>
 243 --    f (T y g False) = <e2>
 244 -- After desugaring we get
 245 --      f t b = case t of
 246 --                T a (x::a) (f::a->Int) (b:Bool) ->
 247 --                  case b of
 248 --                      True -> <e1>
 249 --                      False -> (/\b. let y=x; g=f in <e2>) a
 250 -- And for a reason I now forget, the ...<e2>... can mention a; so
 251 -- we want Lint to know that b=a.  Ugh.
 252 --
 253 -- I tried quite hard to make the necessity for this go away, by changing the
 254 -- desugarer, but the fundamental problem is this:
 255 --
 256 --      T a (x::a) (y::Int) -> let fail::a = ...
 257 --                             in (/\b. ...(case ... of
 258 --                                              True  -> x::b
 259 --                                              False -> fail)
 260 --                                ) a
 261 -- Now the inner case look as though it has incompatible branches.
 262   = go fun [ty]
 263   where
 264     go (App fun (Type ty)) tys
 265         = do { go fun (ty:tys) }
 266     go (Lam tv body) (ty:tys)
 267         = do  { checkL (isTyVar tv) (mkKindErrMsg tv ty)        -- Not quite accurate
 268               ; ty' <- lintTy ty;
 269               ; checkKinds tv ty'
 270                 -- Now extend the substitution so we
 271                 -- take advantage of it in the body
 272               ; addInScopeVars [tv] $
 273                 extendSubstL tv ty' $
 274                 go body tys }
 275     go fun tys
 276         = do  { fun_ty <- lintCoreExpr fun
 277               ; lintCoreArgs fun_ty (map Type tys) }
 278
 279 lintCoreExpr e@(App fun arg)
 280   = do  { ty <- lintCoreExpr fun
 281         ; addLoc (AnExpr e) $
 282           lintCoreArg ty arg }
 283
 284 lintCoreExpr (Lam var expr)
 285   = addLoc (LambdaBodyOf var) $
 286     do  { body_ty <- addInScopeVars [var] $
 287                      lintCoreExpr expr
 288         ; if isId var then do
 289                 { var_ty <- lintId var
 290                 ; return (mkFunTy var_ty body_ty) }
 291           else
 292                 return (mkForAllTy var body_ty)
 293         }
 294         -- The applySubst is needed to apply the subst to var
 295
 296 lintCoreExpr e@(Case scrut var alt_ty alts) =
 297        -- Check the scrutinee
 298   do { scrut_ty <- lintCoreExpr scrut
 299      ; alt_ty   <- lintTy alt_ty
 300      ; var_ty   <- lintTy (idType var)
 301         -- Don't use lintId on var, because unboxed tuple is legitimate
 302
 303      ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
 304
 305      -- If the binder is an unboxed tuple type, don't put it in scope
 306      ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
 307      ; addInScopeVars vars $
 308        do { -- Check the alternatives
 309             checkCaseAlts e scrut_ty alts
 310           ; mapM (lintCoreAlt scrut_ty alt_ty) alts
 311           ; return alt_ty } }
 312
 313 lintCoreExpr e@(Type ty)
 314   = addErrL (mkStrangeTyMsg e)
 315 \end{code}
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection[lintCoreArgs]{lintCoreArgs}
 320 %*                                                                      *
 321 %************************************************************************
 322
 323 The basic version of these functions checks that the argument is a
 324 subtype of the required type, as one would expect.
 325
 326 \begin{code}
 327 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
 328 lintCoreArg  :: Type -> CoreArg   -> LintM Type
 329 -- First argument has already had substitution applied to it
 330 \end{code}
 331
 332 \begin{code}
 333 lintCoreArgs ty [] = return ty
 334 lintCoreArgs ty (a : args) =
 335   do { res <- lintCoreArg ty a
 336      ; lintCoreArgs res args }
 337
 338 lintCoreArg ty a@(Type arg_ty) =
 339   do { arg_ty <- lintTy arg_ty
 340      ; lintTyApp ty arg_ty }
 341
 342 lintCoreArg fun_ty arg =
 343        -- Make sure function type matches argument
 344   do { arg_ty <- lintCoreExpr arg
 345      ; let err = mkAppMsg fun_ty arg_ty
 346      ; case splitFunTy_maybe fun_ty of
 347         Just (arg,res) ->
 348           do { checkTys arg arg_ty err
 349              ; return res }
 350         _ -> addErrL err }
 351 \end{code}
 352
 353 \begin{code}
 354 -- Both args have had substitution applied
 355 lintTyApp ty arg_ty
 356   = case splitForAllTy_maybe ty of
 357       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 358
 359       Just (tyvar,body)
 360         -> do   { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
 361                 ; checkKinds tyvar arg_ty
 362                 ; return (substTyWith [tyvar] [arg_ty] body) }
 363
 364 lintTyApps fun_ty [] = return fun_ty
 365
 366 lintTyApps fun_ty (arg_ty : arg_tys) =
 367   do { fun_ty' <- lintTyApp fun_ty arg_ty
 368      ; lintTyApps fun_ty' arg_tys }
 369
 370 checkKinds tyvar arg_ty
 371         -- Arg type might be boxed for a function with an uncommitted
 372         -- tyvar; notably this is used so that we can give
 373         --      error :: forall a:*. String -> a
 374         -- and then apply it to both boxed and unboxed types.
 375   = checkL (argty_kind `isSubKind` tyvar_kind)
 376            (mkKindErrMsg tyvar arg_ty)
 377   where
 378     tyvar_kind = tyVarKind tyvar
 379     argty_kind = typeKind arg_ty
 380 \end{code}
 381
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsection[lintCoreAlts]{lintCoreAlts}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 \begin{code}
 390 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 391 -- a) Check that the alts are non-empty
 392 -- b1) Check that the DEFAULT comes first, if it exists
 393 -- b2) Check that the others are in increasing order
 394 -- c) Check that there's a default for infinite types
 395 -- NB: Algebraic cases are not necessarily exhaustive, because
 396 --     the simplifer correctly eliminates case that can't
 397 --     possibly match.
 398
 399 checkCaseAlts e ty []
 400   = addErrL (mkNullAltsMsg e)
 401
 402 checkCaseAlts e ty alts =
 403   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
 404      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
 405      ; checkL (isJust maybe_deflt || not is_infinite_ty)
 406            (nonExhaustiveAltsMsg e) }
 407   where
 408     (con_alts, maybe_deflt) = findDefault alts
 409
 410         -- Check that successive alternatives have increasing tags
 411     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
 412     increasing_tag other                     = True
 413
 414     non_deflt (DEFAULT, _, _) = False
 415     non_deflt alt             = True
 416
 417     is_infinite_ty = case splitTyConApp_maybe ty of
 418                         Nothing                     -> False
 419                         Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
 420 \end{code}
 421
 422 \begin{code}
 423 checkAltExpr :: CoreExpr -> OutType -> LintM ()
 424 checkAltExpr expr ann_ty
 425   = do { actual_ty <- lintCoreExpr expr
 426        ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
 427
 428 lintCoreAlt :: OutType          -- Type of scrutinee
 429             -> OutType          -- Type of the alternative
 430             -> CoreAlt
 431             -> LintM ()
 432
 433 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
 434   do { checkL (null args) (mkDefaultArgsMsg args)
 435      ; checkAltExpr rhs alt_ty }
 436
 437 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
 438   do { checkL (null args) (mkDefaultArgsMsg args)
 439      ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
 440      ; checkAltExpr rhs alt_ty }
 441   where
 442     lit_ty = literalType lit
 443
 444 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 445   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
 446     tycon == dataConTyCon con
 447   = addLoc (CaseAlt alt) $
 448     addInScopeVars args $       -- Put the args in scope before lintBinder,
 449                                 -- because the Ids mention the type variables
 450     if isVanillaDataCon con then
 451     do  { mapM lintBinder args
 452                 -- FIX! Add check that all args are Ids.
 453                  -- Check the pattern
 454                  -- Scrutinee type must be a tycon applicn; checked by caller
 455                  -- This code is remarkably compact considering what it does!
 456                  -- NB: args must be in scope here so that the lintCoreArgs line works.
 457                  -- NB: relies on existential type args coming *after* ordinary type args
 458
 459         ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
 460                  -- Can just map Var as we know that this is a vanilla datacon
 461         ; con_result_ty <- lintCoreArgs con_type (map Var args)
 462         ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 463                  -- Check the RHS
 464         ; checkAltExpr rhs alt_ty }
 465
 466     else        -- GADT
 467     do  { let (tvs,ids) = span isTyVar args
 468         ; subst <- getTvSubst
 469         ; let in_scope  = getTvInScope subst
 470               subst_env = getTvSubstEnv subst
 471         ; case coreRefineTys in_scope con tvs scrut_ty of {
 472              Nothing          -> return () ;    -- Alternative is dead code
 473              Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
 474     do  { tvs'     <- mapM lintTy (mkTyVarTys tvs)
 475         ; con_type <- lintTyApps (dataConRepType con) tvs'
 476         ; mapM lintBinder ids   -- Lint Ids in the refined world
 477         ; lintCoreArgs con_type (map Var ids)
 478         ; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
 479                 -- alt_ty is already an OutType, so don't re-apply
 480                 -- the current substitution.  But we must apply the
 481                 -- refinement so that the check in checkAltExpr is ok
 482         ; checkAltExpr rhs refined_alt_ty
 483     } } }
 484
 485   | otherwise   -- Scrut-ty is wrong shape
 486   = addErrL (mkBadAltMsg scrut_ty alt)
 487 \end{code}
 488
 489 %************************************************************************
 490 %*                                                                      *
 491 \subsection[lint-types]{Types}
 492 %*                                                                      *
 493 %************************************************************************
 494
 495 \begin{code}
 496 lintBinder :: Var -> LintM ()
 497 lintBinder var | isId var  = lintId var >> return ()
 498                | otherwise = return ()
 499
 500 lintId :: Var -> LintM OutType
 501 -- ToDo: lint its rules
 502 lintId id
 503   = do  { checkL (not (isUnboxedTupleType (idType id)))
 504                  (mkUnboxedTupleMsg id)
 505                 -- No variable can be bound to an unboxed tuple.
 506         ; lintTy (idType id) }
 507
 508 lintTy :: InType -> LintM OutType
 509 -- Check the type, and apply the substitution to it
 510 -- ToDo: check the kind structure of the type
 511 lintTy ty
 512   = do  { ty' <- applySubst ty
 513         ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
 514         ; return ty' }
 515 \end{code}
 516
 517
 518 %************************************************************************
 519 %*                                                                      *
 520 \subsection[lint-monad]{The Lint monad}
 521 %*                                                                      *
 522 %************************************************************************
 523
 524 \begin{code}
 525 newtype LintM a =
 526    LintM { unLintM ::
 527             [LintLocInfo] ->         -- Locations
 528             TvSubst ->               -- Current type substitution; we also use this
 529                                      -- to keep track of all the variables in scope,
 530                                      -- both Ids and TyVars
 531             Bag Message ->           -- Error messages so far
 532             (Maybe a, Bag Message) } -- Result and error messages (if any)
 533
 534 instance Monad LintM where
 535   return x = LintM (\ loc subst errs -> (Just x, errs))
 536   fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
 537   m >>= k  = LintM (\ loc subst errs ->
 538                        let (res, errs') = unLintM m loc subst errs in
 539                          case res of
 540                            Just r -> unLintM (k r) loc subst errs'
 541                            Nothing -> (Nothing, errs'))
 542
 543 data LintLocInfo
 544   = RhsOf Id            -- The variable bound
 545   | LambdaBodyOf Id     -- The lambda-binder
 546   | BodyOfLetRec [Id]   -- One of the binders
 547   | CaseAlt CoreAlt     -- Pattern of a case alternative
 548   | AnExpr CoreExpr     -- Some expression
 549   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 550 \end{code}
 551
 552
 553 \begin{code}
 554 initL :: LintM a -> Maybe Message {- errors -}
 555 initL m
 556   = case unLintM m [] emptyTvSubst emptyBag of
 557       (_, errs) | isEmptyBag errs -> Nothing
 558                 | otherwise       -> Just (vcat (punctuate (text "") (bagToList errs)))
 559 \end{code}
 560
 561 \begin{code}
 562 checkL :: Bool -> Message -> LintM ()
 563 checkL True  msg = return ()
 564 checkL False msg = addErrL msg
 565
 566 addErrL :: Message -> LintM a
 567 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
 568
 569 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
 570 addErr subst errs_so_far msg locs
 571   = ASSERT( notNull locs )
 572     errs_so_far `snocBag` mk_msg msg
 573   where
 574    (loc, cxt1) = dumpLoc (head locs)
 575    cxts        = [snd (dumpLoc loc) | loc <- locs]
 576    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
 577                                       ptext SLIT("Substitution:") <+> ppr subst
 578                | otherwise          = cxt1
 579
 580    mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
 581
 582 addLoc :: LintLocInfo -> LintM a -> LintM a
 583 addLoc extra_loc m =
 584   LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
 585
 586 addInScopeVars :: [Var] -> LintM a -> LintM a
 587 addInScopeVars vars m =
 588   LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
 589
 590 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
 591 updateTvSubstEnv substenv m =
 592   LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
 593
 594 getTvSubst :: LintM TvSubst
 595 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
 596
 597 applySubst :: Type -> LintM Type
 598 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
 599
 600 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 601 extendSubstL tv ty m
 602   = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
 603 \end{code}
 604
 605 \begin{code}
 606 checkIdInScope :: Var -> LintM ()
 607 checkIdInScope id
 608   = do { checkL (not (id == oneTupleDataConId))
 609                 (ptext SLIT("Illegal one-tuple"))
 610        ; checkInScope (ptext SLIT("is out of scope")) id }
 611
 612 oneTupleDataConId :: Id -- Should not happen
 613 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
 614
 615 checkBndrIdInScope :: Var -> Var -> LintM ()
 616 checkBndrIdInScope binder id
 617   = checkInScope msg id
 618     where
 619      msg = ptext SLIT("is out of scope inside info for") <+>
 620            ppr binder
 621
 622 checkInScope :: SDoc -> Var -> LintM ()
 623 checkInScope loc_msg var =
 624  do { subst <- getTvSubst
 625     ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
 626              (hsep [ppr var, loc_msg]) }
 627
 628 checkTys :: Type -> Type -> Message -> LintM ()
 629 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 630 -- annotations need only be consistent, not equal)
 631 -- Assumes ty1,ty2 are have alrady had the substitution applied
 632 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
 633 \end{code}
 634
 635 %************************************************************************
 636 %*                                                                      *
 637 \subsection{Error messages}
 638 %*                                                                      *
 639 %************************************************************************
 640
 641 \begin{code}
 642 dumpLoc (RhsOf v)
 643   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 644
 645 dumpLoc (LambdaBodyOf b)
 646   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 647
 648 dumpLoc (BodyOfLetRec [])
 649   = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
 650
 651 dumpLoc (BodyOfLetRec bs@(_:_))
 652   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 653
 654 dumpLoc (AnExpr e)
 655   = (noSrcLoc, text "In the expression:" <+> ppr e)
 656
 657 dumpLoc (CaseAlt (con, args, rhs))
 658   = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
 659
 660 dumpLoc (ImportedUnfolding locn)
 661   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 662
 663 pp_binders :: [Var] -> SDoc
 664 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 665
 666 pp_binder :: Var -> SDoc
 667 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 668             | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 669 \end{code}
 670
 671 \begin{code}
 672 ------------------------------------------------------
 673 --      Messages for case expressions
 674
 675 mkNullAltsMsg :: CoreExpr -> Message
 676 mkNullAltsMsg e
 677   = hang (text "Case expression with no alternatives:")
 678          4 (ppr e)
 679
 680 mkDefaultArgsMsg :: [Var] -> Message
 681 mkDefaultArgsMsg args
 682   = hang (text "DEFAULT case with binders")
 683          4 (ppr args)
 684
 685 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
 686 mkCaseAltMsg e ty1 ty2
 687   = hang (text "Type of case alternatives not the same as the annotation on case:")
 688          4 (vcat [ppr ty1, ppr ty2, ppr e])
 689
 690 mkScrutMsg :: Id -> Type -> Message
 691 mkScrutMsg var scrut_ty
 692   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 693           text "Result binder type:" <+> ppr (idType var),
 694           text "Scrutinee type:" <+> ppr scrut_ty]
 695
 696
 697 mkNonDefltMsg e
 698   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 699 mkNonIncreasingAltsMsg e
 700   = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
 701
 702 nonExhaustiveAltsMsg :: CoreExpr -> Message
 703 nonExhaustiveAltsMsg e
 704   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 705
 706 mkBadPatMsg :: Type -> Type -> Message
 707 mkBadPatMsg con_result_ty scrut_ty
 708   = vcat [
 709         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 710         text "Pattern result type:" <+> ppr con_result_ty,
 711         text "Scrutinee type:" <+> ppr scrut_ty
 712     ]
 713
 714 mkBadAltMsg :: Type -> CoreAlt -> Message
 715 mkBadAltMsg scrut_ty alt
 716   = vcat [ text "Data alternative when scrutinee is not a tycon application",
 717            text "Scrutinee type:" <+> ppr scrut_ty,
 718            text "Alternative:" <+> pprCoreAlt alt ]
 719
 720 ------------------------------------------------------
 721 --      Other error messages
 722
 723 mkAppMsg :: Type -> Type -> Message
 724 mkAppMsg fun arg
 725   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 726               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 727               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 728
 729 mkKindErrMsg :: TyVar -> Type -> Message
 730 mkKindErrMsg tyvar arg_ty
 731   = vcat [ptext SLIT("Kinds don't match in type application:"),
 732           hang (ptext SLIT("Type variable:"))
 733                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 734           hang (ptext SLIT("Arg type:"))
 735                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 736
 737 mkTyAppMsg :: Type -> Type -> Message
 738 mkTyAppMsg ty arg_ty
 739   = vcat [text "Illegal type application:",
 740               hang (ptext SLIT("Exp type:"))
 741                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 742               hang (ptext SLIT("Arg type:"))
 743                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 744
 745 mkRhsMsg :: Id -> Type -> Message
 746 mkRhsMsg binder ty
 747   = vcat
 748     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 749             ppr binder],
 750      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 751      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 752
 753 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 754 mkRhsPrimMsg binder rhs
 755   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 756                      ppr binder],
 757               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 758              ]
 759
 760 mkUnboxedTupleMsg :: Id -> Message
 761 mkUnboxedTupleMsg binder
 762   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 763           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 764
 765 mkCoerceErr from_ty expr_ty
 766   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 767           ptext SLIT("From-type:") <+> ppr from_ty,
 768           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 769     ]
 770
 771 mkStrangeTyMsg e
 772   = ptext SLIT("Type where expression expected:") <+> ppr e
 773 \end{code}