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