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