CoreLint.lhs 43 KB
Newer Older
1

2
%
Simon Marlow's avatar
Simon Marlow committed
3
% (c) The University of Glasgow 2006
4
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
5
%
Simon Marlow's avatar
Simon Marlow committed
6 7

A ``lint'' pass to check for Core correctness
8 9

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
10 11 12 13 14 15 16
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

Ian Lynagh's avatar
Ian Lynagh committed
17 18
{-# OPTIONS_GHC -fprof-auto #-}

19
module CoreLint ( lintCoreBindings, lintUnfolding ) where
20

21
#include "HsVersions.h"
22

23
import Demand
24
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
25 26
import CoreFVs
import CoreUtils
27
import Pair
28
import Bag
Simon Marlow's avatar
Simon Marlow committed
29 30 31
import Literal
import DataCon
import TysWiredIn
batterseapower's avatar
batterseapower committed
32
import TysPrim
Simon Marlow's avatar
Simon Marlow committed
33 34
import Var
import VarEnv
35
import VarSet
Simon Marlow's avatar
Simon Marlow committed
36
import Name
37
import Id
38
import PprCore
Simon Marlow's avatar
Simon Marlow committed
39
import ErrUtils
batterseapower's avatar
batterseapower committed
40
import Coercion
Simon Marlow's avatar
Simon Marlow committed
41
import SrcLoc
42
import Kind
Simon Marlow's avatar
Simon Marlow committed
43
import Type
44
import TypeRep
Simon Marlow's avatar
Simon Marlow committed
45 46 47
import TyCon
import BasicTypes
import StaticFlags
48
import ListSetOps
49
import PrelNames
50
import Outputable
51
import FastString
52
import Util
53
import Control.Monad
54
import MonadUtils
Simon Marlow's avatar
Simon Marlow committed
55
import Data.Maybe
56 57 58 59
\end{code}

%************************************************************************
%*									*
60
\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
61 62 63
%*									*
%************************************************************************

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
Checks that a set of core bindings is well-formed.  The PprStyle and String
just control what we print in the event of an error.  The Bool value
indicates whether we have done any specialisation yet (in which case we do
some extra checks).

We check for
	(a) type errors
	(b) Out-of-scope type variables
	(c) Out-of-scope local variables
	(d) Ill-kinded types

If we have done specialisation the we check that there are
	(a) No top-level bindings of primitive (unboxed type)

Outstanding issues:

    --
    -- Things are *not* OK if:
    --
83
    --  * Unsaturated type app before specialisation has been done;
84
    --
85
    --  * Oversaturated type app after specialisation (eta reduction
86
    --   may well be happening...);
87

88

89 90
Note [Linting type lets]
~~~~~~~~~~~~~~~~~~~~~~~~
91
In the desugarer, it's very very convenient to be able to say (in effect)
92 93 94 95 96 97
	let a = Type Int in <body>
That is, use a type let.   See Note [Type let] in CoreSyn.

However, when linting <body> we need to remember that a=Int, else we might
reject a correct program.  So we carry a type substitution (in this example 
[a -> Int]) and apply this substitution before comparing types.  The functin
98
	lintInTy :: Type -> LintM Type
99 100 101 102 103 104 105 106 107 108
returns a substituted type; that's the only reason it returns anything.

When we encounter a binder (like x::a) we must apply the substitution
to the type of the binding variable.  lintBinders does this.

For Ids, the type-substituted Id is added to the in_scope set (which 
itself is part of the TvSubst we are carrying down), and when we
find an occurence of an Id, we fetch it from the in-scope set.


109
\begin{code}
110
lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
111 112
--   Returns (warnings, errors)
lintCoreBindings binds
113 114 115
  = initL $ 
    addLoc TopLevelBindings $
    addInScopeVars binders  $
116 117 118
	-- Put all the top-level binders in scope at the start
	-- This is because transformation rules can bring something
	-- into use 'unexpectedly'
119 120 121 122 123 124 125 126 127 128 129 130 131
    do { checkL (null dups) (dupVars dups)
       ; checkL (null ext_dups) (dupExtVars ext_dups)
       ; mapM lint_bind binds }
  where
    binders = bindersOfBinds binds
    (_, dups) = removeDups compare binders

    -- dups_ext checks for names with different uniques
    -- but but the same External name M.n.  We don't
    -- allow this at top level:
    --    M.n{r3}  = ...
    --    M.n{r29} = ...
    -- becuase they both get the same linker symbol
132 133 134 135 136
    ext_dups = snd (removeDups ord_ext (map Var.varName binders))
    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
                  , Just m2 <- nameModule_maybe n2
                  = compare (m1, nameOccName n1) (m2, nameOccName n2)
                  | otherwise = LT
137

138 139
    lint_bind (Rec prs)		= mapM_ (lintSingleBinding TopLevel Recursive) prs
    lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
140 141
\end{code}

142 143 144 145 146 147
%************************************************************************
%*									*
\subsection[lintUnfolding]{lintUnfolding}
%*									*
%************************************************************************

148 149
We use this to check all unfoldings that come in from interfaces
(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 MsgDoc	-- Nothing => OK
156

157
lintUnfolding locn vars expr
158
  | isEmptyBag errs = Nothing
159
  | otherwise       = Just (pprMessageBag errs)
160 161 162 163
  where
    (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
                            addInScopeVars vars	           $
                            lintCoreExpr expr)
164 165
\end{code}

166 167 168 169 170
%************************************************************************
%*									*
\subsection[lintCoreBinding]{lintCoreBinding}
%*									*
%************************************************************************
171

172
Check a core binding, returning the list of variables bound.
173 174

\begin{code}
twanvl's avatar
twanvl committed
175
lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
176
lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
177
  = addLoc (RhsOf binder) $
178 179 180
         -- Check the rhs 
    do { ty <- lintCoreExpr rhs	
       ; lintBinder binder -- Check match to RHS type
181
       ; binder_ty <- applySubstTy binder_ty
182 183 184
       ; checkTys binder_ty ty (mkRhsMsg binder ty)
        -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
       ; checkL (not (isUnLiftedType binder_ty)
185
            || (isNonRec rec_flag && exprOkForSpeculation rhs))
186
 	   (mkRhsPrimMsg binder rhs)
187 188 189 190
        -- Check that if the binder is top-level or recursive, it's not demanded
       ; checkL (not (isStrictId binder)
            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
           (mkStrictMsg binder)
191 192 193 194 195 196
        -- Check that if the binder is local, it is not marked as exported
       ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
           (mkNonTopExportedMsg binder)
        -- Check that if the binder is local, it does not have an external name
       ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
           (mkNonTopExternalNameMsg binder)
sof's avatar
sof committed
197
        -- Check whether binder's specialisations contain any out-of-scope variables
198 199
       ; mapM_ (checkBndrIdInScope binder) bndr_vars 

200
       ; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder))
201 202
              (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder))
	      -- Only non-rule loop breakers inhibit inlining
203

204 205 206 207 208 209
      -- Check whether arity and demand type are consistent (only if demand analysis
      -- already happened)
       ; checkL (case maybeDmdTy of
                  Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
                  Nothing -> True)
           (mkArityMsg binder) }
sof's avatar
sof committed
210
	  
211
	-- We should check the unfolding, if any, but this is tricky because
212 213 214
 	-- the unfolding is a SimplifiableCoreExpr. Give up for now.
   where
    binder_ty                  = idType binder
215
    maybeDmdTy                 = idStrictness_maybe binder
216
    bndr_vars                  = varSetElems (idFreeVars binder)
217 218
    lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
	           | otherwise = return ()
219 220
\end{code}

221 222 223 224 225 226
%************************************************************************
%*									*
\subsection[lintCoreExpr]{lintCoreExpr}
%*									*
%************************************************************************

227
\begin{code}
dreixel's avatar
dreixel committed
228 229
--type InKind      = Kind	-- Substitution not yet applied
type InType      = Type	
230 231 232
type InCoercion  = Coercion
type InVar       = Var
type InTyVar     = TyVar
233

234 235 236 237 238 239 240 241 242
type OutKind     = Kind	-- Substitution has been applied to this,
                        -- but has not been linted yet
type LintedKind  = Kind -- Substitution applied, and type is linted

type OutType     = Type	-- Substitution has been applied to this,
                        -- but has not been linted yet

type LintedType  = Type -- Substitution applied, and type is linted

243 244 245
type OutCoercion = Coercion
type OutVar      = Var
type OutTyVar    = TyVar
246

247
lintCoreExpr :: CoreExpr -> LintM OutType
248 249
-- The returned type has the substitution from the monad 
-- already applied to it:
250
--	lintCoreExpr e subst = exprType (subst e)
251 252
--
-- The returned "type" can be a kind, if the expression is (Type ty)
253 254

lintCoreExpr (Var var)
255
  = do	{ checkL (not (var == oneTupleDataConId))
Ian Lynagh's avatar
Ian Lynagh committed
256
		 (ptext (sLit "Illegal one-tuple"))
257

258 259 260
        ; checkL (isId var && not (isCoVar var))
                 (ptext (sLit "Non term variable") <+> ppr var)

261
        ; checkDeadIdOcc var
262
	; var' <- lookupIdInScope var
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
263
        ; return (idType var') }
264

265 266
lintCoreExpr (Lit lit)
  = return (literalType lit)
267

268 269
lintCoreExpr (Cast expr co)
  = do { expr_ty <- lintCoreExpr expr
270
       ; co' <- applySubstCo co
271
       ; (_, from_ty, to_ty) <- lintCoercion co'
272
       ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
273
       ; return to_ty }
274

275 276 277 278 279 280 281
lintCoreExpr (Tick (Breakpoint _ ids) expr)
  = do forM_ ids $ \id -> do
         checkDeadIdOcc id
         lookupIdInScope id
       lintCoreExpr expr

lintCoreExpr (Tick _other_tickish expr)
282
  = lintCoreExpr expr
283

284
lintCoreExpr (Let (NonRec tv (Type ty)) body)
285 286
  | isTyVar tv
  =	-- See Note [Linting type lets]
287
    do	{ ty' <- applySubstTy ty
288
        ; lintTyBndr tv              $ \ tv' -> 
289
    do  { addLoc (RhsOf tv) $ checkTyKind tv' ty'
290 291
		-- Now extend the substitution so we 
		-- take advantage of it in the body
292 293 294
        ; extendSubstL tv' ty'       $ 
          addLoc (BodyOfLetRec [tv]) $ 
          lintCoreExpr body } }
295

296
lintCoreExpr (Let (NonRec bndr rhs) body)
297
  | isId bndr
298
  = do	{ lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
299
	; addLoc (BodyOfLetRec [bndr]) 
300
		 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
301

302 303 304
  | otherwise
  = failWithL (mkLetErr bndr rhs)	-- Not quite accurate

305
lintCoreExpr (Let (Rec pairs) body) 
306
  = lintAndScopeIds bndrs	$ \_ ->
307 308
    do	{ checkL (null dups) (dupVars dups)
        ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs	
309
	; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
310 311
  where
    bndrs = map fst pairs
312
    (_, dups) = removeDups compare bndrs
313

batterseapower's avatar
batterseapower committed
314 315 316 317 318
lintCoreExpr e@(App _ _)
    = do { fun_ty <- lintCoreExpr fun
         ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
  where
    (fun, args) = collectArgs e
319 320

lintCoreExpr (Lam var expr)
321
  = addLoc (LambdaBodyOf var) $
322 323
    lintBinder var $ \ var' ->
    do { body_ty <- lintCoreExpr expr
324 325 326 327 328
       ; if isId var' then 
             return (mkFunTy (idType var') body_ty) 
	 else
	     return (mkForAllTy var' body_ty)
       }
329
	-- The applySubstTy is needed to apply the subst to var
330 331 332 333

lintCoreExpr e@(Case scrut var alt_ty alts) =
       -- Check the scrutinee
  do { scrut_ty <- lintCoreExpr scrut
334 335
     ; alt_ty   <- lintInTy alt_ty  
     ; var_ty   <- lintInTy (idType var)	
336

337 338
     ; case tyConAppTyCon_maybe (idType var) of 
         Just tycon
339 340
              | debugIsOn &&
                isAlgTyCon tycon && 
341
		not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
342
                null (tyConDataCons tycon) -> 
343 344
                  pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
			-- This can legitimately happen for type families
345 346 347
                      $ return ()
         _otherwise -> return ()

348
	-- Don't use lintIdBndr on var, because unboxed tuple is legitimate
349

350 351
     ; subst <- getTvSubst 
     ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
352

353
     ; lintAndScopeId var $ \_ ->
354
       do { -- Check the alternatives
355
            mapM_ (lintCoreAlt scrut_ty alt_ty) alts
356
          ; checkCaseAlts e scrut_ty alts
357
          ; return alt_ty } }
358

359
lintCoreExpr (Type ty)
360
  = do { ty' <- lintInTy ty
361
       ; return (typeKind ty') }
362 363 364 365

lintCoreExpr (Coercion co)
  = do { co' <- lintInCo co
       ; let Pair ty1 ty2 = coercionKind co'
batterseapower's avatar
batterseapower committed
366
       ; return (mkCoercionType ty1 ty2) }
367
\end{code}
368

dreixel's avatar
dreixel committed
369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388
Note [Kind instantiation in coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following coercion axiom:
  ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa

Consider the following instantiation:
  ax_co <* -> *> <Monad>

We need to split the co_ax_tvs into kind and type variables in order
to find out the coercion kind instantiations. Those can only be Refl
since we don't have kind coercions. This is just a way to represent
kind instantiation.

We use the number of kind variables to know how to split the coercions
instantiations between kind coercions and type coercions. We lint the
kind coercions and produce the following substitution which is to be
applied in the type variables:
  k_ag   ~~>   * -> *


389 390 391 392 393
%************************************************************************
%*									*
\subsection[lintCoreArgs]{lintCoreArgs}
%*									*
%************************************************************************
394

395 396
The basic version of these functions checks that the argument is a
subtype of the required type, as one would expect.
397

398
\begin{code}
399
lintCoreArg  :: OutType -> CoreArg -> LintM OutType
400
lintCoreArg fun_ty (Type arg_ty)
401 402
  = do { arg_ty' <- applySubstTy arg_ty
       ; lintTyApp fun_ty arg_ty' }
403 404

lintCoreArg fun_ty arg
405 406
  = do { arg_ty <- lintCoreExpr arg
       ; lintValApp arg fun_ty arg_ty }
407 408 409 410 411 412 413 414 415

-----------------
lintAltBinders :: OutType     -- Scrutinee type
	       -> OutType     -- Constructor type
               -> [OutVar]    -- Binders
               -> LintM ()
lintAltBinders scrut_ty con_ty [] 
  = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) 
lintAltBinders scrut_ty con_ty (bndr:bndrs)
416
  | isTyVar bndr
417 418 419 420 421 422 423 424 425 426
  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
       ; lintAltBinders scrut_ty con_ty' bndrs }
  | otherwise
  = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)
       ; lintAltBinders scrut_ty con_ty' bndrs } 

-----------------
lintTyApp :: OutType -> OutType -> LintM OutType
lintTyApp fun_ty arg_ty
  | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty
427 428 429 430
  , isTyVar tyvar
  = do	{ checkTyKind tyvar arg_ty
        ; return (substTyWith [tyvar] [arg_ty] body_ty) }

431 432
  | otherwise
  = failWithL (mkTyAppMsg fun_ty arg_ty)
433 434 435 436 437 438 439 440 441 442 443 444
   
-----------------
lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
lintValApp arg fun_ty arg_ty
  | Just (arg,res) <- splitFunTy_maybe fun_ty
  = do { checkTys arg arg_ty err1
       ; return res }
  | otherwise
  = failWithL err2
  where
    err1 = mkAppMsg       fun_ty arg_ty arg
    err2 = mkNonFunAppMsg fun_ty arg_ty arg
445
\end{code}
446

447
\begin{code}
448
checkTyKind :: OutTyVar -> OutType -> LintM ()
449
-- Both args have had substitution applied
450
checkTyKind tyvar arg_ty
dreixel's avatar
dreixel committed
451 452
  | isSuperKind tyvar_kind  -- kind forall
  = lintKind arg_ty
453 454 455 456
	-- Arg type might be boxed for a function with an uncommitted
	-- tyvar; notably this is used so that we can give
	-- 	error :: forall a:*. String -> a
	-- and then apply it to both boxed and unboxed types.
dreixel's avatar
dreixel committed
457
  | otherwise  -- type forall
458 459
  = do { arg_kind <- lintType arg_ty
       ; unless (arg_kind `isSubKind` tyvar_kind)
460
                (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) }
461 462
  where
    tyvar_kind = tyVarKind tyvar
463

464 465 466 467 468 469 470 471 472 473
checkDeadIdOcc :: Id -> LintM ()
-- Occurrences of an Id should never be dead....
-- except when we are checking a case pattern
checkDeadIdOcc id
  | isDeadOcc (idOccInfo id)
  = do { in_case <- inCasePat
       ; checkL in_case
		(ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
  | otherwise
  = return ()
474
\end{code}
475 476


477 478 479 480 481 482 483
%************************************************************************
%*									*
\subsection[lintCoreAlts]{lintCoreAlts}
%*									*
%************************************************************************

\begin{code}
484
checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
485
-- a) Check that the alts are non-empty
486 487
-- b1) Check that the DEFAULT comes first, if it exists
-- b2) Check that the others are in increasing order
488 489 490 491 492
-- c) Check that there's a default for infinite types
-- NB: Algebraic cases are not necessarily exhaustive, because
--     the simplifer correctly eliminates case that can't 
--     possibly match.

493 494
checkCaseAlts e ty alts = 
  do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
495
     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
496 497
     ; checkL (isJust maybe_deflt || not is_infinite_ty)
	   (nonExhaustiveAltsMsg e) }
498 499
  where
    (con_alts, maybe_deflt) = findDefault alts
500

501 502
	-- Check that successive alternatives have increasing tags 
    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
twanvl's avatar
twanvl committed
503
    increasing_tag _                         = True
504

505
    non_deflt (DEFAULT, _, _) = False
twanvl's avatar
twanvl committed
506
    non_deflt _               = True
507

508 509 510
    is_infinite_ty = case tyConAppTyCon_maybe ty of
                        Nothing    -> False
                        Just tycon -> isPrimTyCon tycon
511 512 513
\end{code}

\begin{code}
514 515
checkAltExpr :: CoreExpr -> OutType -> LintM ()
checkAltExpr expr ann_ty
516
  = do { actual_ty <- lintCoreExpr expr 
517
       ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
518

519 520
lintCoreAlt :: OutType 		-- Type of scrutinee
            -> OutType          -- Type of the alternative
521
	    -> CoreAlt
522
	    -> LintM ()
523

twanvl's avatar
twanvl committed
524
lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
525 526
  do { checkL (null args) (mkDefaultArgsMsg args)
     ; checkAltExpr rhs alt_ty }
527

528
lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
529 530
  | litIsLifted lit
  = failWithL integerScrutinisedMsg
531
  | otherwise
532 533 534
  = do { checkL (null args) (mkDefaultArgsMsg args)
       ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
       ; checkAltExpr rhs alt_ty }
535 536
  where
    lit_ty = literalType lit
537

538
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
539 540
  | isNewTyCon (dataConTyCon con) 
  = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
541
  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
542 543 544
  = addLoc (CaseAlt alt) $  do
    {   -- First instantiate the universally quantified 
	-- type variables of the data constructor
545 546 547
	-- We've already check
      checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
    ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
548 549

	-- And now bring the new binders into scope
550 551
    ; lintBinders args $ \ args' -> do
    { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
552
    ; checkAltExpr rhs alt_ty } }
553 554 555

  | otherwise	-- Scrut-ty is wrong shape
  = addErrL (mkBadAltMsg scrut_ty alt)
556
\end{code}
557

sof's avatar
sof committed
558 559
%************************************************************************
%*									*
560
\subsection[lint-types]{Types}
sof's avatar
sof committed
561 562 563 564
%*									*
%************************************************************************

\begin{code}
565 566 567 568 569 570 571 572 573 574 575 576
-- When we lint binders, we (one at a time and in order):
--  1. Lint var types or kinds (possibly substituting)
--  2. Add the binder to the in scope set, and if its a coercion var,
--     we may extend the substitution to reflect its (possibly) new kind
lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders [] linterF = linterF []
lintBinders (var:vars) linterF = lintBinder var $ \var' ->
				 lintBinders vars $ \ vars' ->
				 linterF (var':vars')

lintBinder :: Var -> (Var -> LintM a) -> LintM a
lintBinder var linterF
577 578 579 580 581 582
  | isId var  = lintIdBndr var linterF
  | otherwise = lintTyBndr var linterF

lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
lintTyBndr tv thing_inside
  = do { subst <- getTvSubst
583
       ; let (subst', tv') = Type.substTyVarBndr subst tv
584 585
       ; lintTyBndrKind tv'
       ; updateTvSubst subst' (thing_inside tv') }
586

587
lintIdBndr :: Id -> (Id -> LintM a) -> LintM a
588 589
-- Do substitution on the type of a binder and add the var with this 
-- new type to the in-scope set of the second argument
590
-- ToDo: lint its rules
591

592
lintIdBndr id linterF 
593
  = do 	{ lintAndScopeId id $ \id' -> linterF id' }
594 595 596 597 598 599

lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
lintAndScopeIds ids linterF 
  = go ids
  where
    go []       = linterF []
600 601 602
    go (id:ids) = lintAndScopeId id $ \id ->
                  lintAndScopeIds ids $ \ids ->
                  linterF (id:ids)
603

604
lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a
605
lintAndScopeId id linterF 
606
  = do { ty <- lintInTy (idType id)
607
       ; let id' = setIdType id ty
608 609 610 611 612 613
       ; addInScopeVar id' $ (linterF id') }
\end{code}


%************************************************************************
%*									*
614
             Types and kinds
615 616
%*									*
%************************************************************************
617

618 619 620 621
We have a single linter for types and kinds.  That is convenient
because sometimes it's not clear whether the thing we are looking
at is a type or a kind.

622
\begin{code}
623 624
lintInTy :: InType -> LintM LintedType
-- Types only, not kinds
625
-- Check the type, and apply the substitution to it
626
-- See Note [Linting type lets]
627 628
lintInTy ty 
  = addLoc (InType ty) $
629
    do	{ ty' <- applySubstTy ty
630
	; _k  <- lintType ty'
631
	; return ty' }
sof's avatar
sof committed
632

633 634
-------------------
lintTyBndrKind :: OutTyVar -> LintM ()
dreixel's avatar
dreixel committed
635
-- Handles both type and kind foralls.
636
lintTyBndrKind tv = lintKind (tyVarKind tv)
637

638
-------------------
639
lintType :: OutType -> LintM LintedKind
640 641 642
-- The returned Kind has itself been linted
lintType (TyVarTy tv)
  = do { checkTyCoVarInScope tv
643 644
       ; return (tyVarKind tv) }
         -- We checked its kind when we added it to the envt
645 646 647

lintType ty@(AppTy t1 t2) 
  = do { k1 <- lintType t1
648 649
       ; k2 <- lintType t2
       ; lint_ty_app ty k1 [(t2,k2)] }
650

651 652 653 654
lintType ty@(FunTy t1 t2)    -- (->) has two different rules, for types and kinds
  = do { k1 <- lintType t1
       ; k2 <- lintType t2
       ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 }
655 656

lintType ty@(TyConApp tc tys)
657
  | not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc
658 659
       -- Check that primitive types are saturated
       -- See Note [The kind invariant] in TypeRep
660 661
  = do { ks <- mapM lintType tys
       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
662 663 664 665 666 667 668
  | otherwise
  = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))

lintType (ForAllTy tv ty)
  = do { lintTyBndrKind tv
       ; addInScopeVar tv (lintType ty) }

669 670
lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)

671
\end{code}
672

673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689

\begin{code}
lintKind :: OutKind -> LintM ()
lintKind k = do { sk <- lintType k 
                ; unless (isSuperKind sk) 
                         (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k)
                                      2 (ptext (sLit "has kind:") <+> ppr sk))) }
\end{code}


\begin{code}
lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
lintArrow what k1 k2   -- Eg lintArrow "type or kind `blah'" k1 k2
                       -- or lintarrow "coercion `blah'" k1 k2
  | isSuperKind k1 
  = return superKind
  | otherwise
690 691
  = do { unless (okArrowArgKind k1)    (addErrL (msg (ptext (sLit "argument")) k1))
       ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result"))   k2))
692 693 694 695 696 697 698 699
       ; return liftedTypeKind }
  where
    msg ar k
      = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar)
                  2 (ptext (sLit "in") <+> what)
             , what <+> ptext (sLit "kind:") <+> ppr k ]

lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
700
lint_ty_app ty k tys 
701
  = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
702 703

----------------
704
lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
705
lint_co_app ty k tys 
706
  = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys
707

708 709 710 711 712 713 714 715
----------------
lintTyLit :: TyLit -> LintM ()
lintTyLit (NumTyLit n)
  | n >= 0    = return ()
  | otherwise = failWithL msg
    where msg = ptext (sLit "Negative type literal:") <+> integer n
lintTyLit (StrTyLit _) = return ()

716 717
lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
-- (lint_app d fun_kind arg_tys)
718 719 720
--    We have an application (f arg_ty1 .. arg_tyn),
--    where f :: fun_kind
-- Takes care of linting the OutTypes
721 722
lint_app doc kfn kas
    = foldlM go_app kfn kas
723 724 725
  where
    fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc
                    , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn)
726 727 728 729 730 731 732 733 734 735 736 737 738
                    , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ]

    go_app kfn ka
      | Just kfn' <- coreView kfn
      = go_app kfn' ka

    go_app (FunTy kfa kfb) (_,ka)
      = do { unless (ka `isSubKind` kfa) (addErrL fail_msg)
           ; return kfb }

    go_app (ForAllTy kv kfn) (ta,ka)
      = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg)
           ; return (substKiWith [kv] [ta] kfn) }
739

740
    go_app _ _ = failWithL fail_msg
741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758
\end{code}

%************************************************************************
%*									*
         Linting coercions
%*									*
%************************************************************************

\begin{code}
lintInCo :: InCoercion -> LintM OutCoercion
-- Check the coercion, and apply the substitution to it
-- See Note [Linting type lets]
lintInCo co
  = addLoc (InCo co) $
    do  { co' <- applySubstCo co
        ; _   <- lintCoercion co'
        ; return co' }

759
lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType)
760
-- Check the kind of a coercion term, returning the kind
761 762
-- Post-condition: the returned OutTypes are lint-free
--                 and have the same kind as each other
763
lintCoercion (Refl ty)
764 765
  = do { k <- lintType ty
       ; return (k, ty, ty) }
766

767
lintCoercion co@(TyConAppCo tc cos)
768 769 770 771 772 773
  | tc `hasKey` funTyConKey
  , [co1,co2] <- cos
  = do { (k1,s1,t1) <- lintCoercion co1
       ; (k2,s2,t2) <- lintCoercion co2
       ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2
       ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2) }
774

775 776 777 778
  | otherwise
  = do { (ks,ss,ts) <- mapAndUnzip3M lintCoercion cos
       ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks)
       ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts) }
779

780
lintCoercion co@(AppCo co1 co2)
781 782 783 784 785 786 787 788 789
  = do { (k1,s1,t1) <- lintCoercion co1
       ; (k2,s2,t2) <- lintCoercion co2
       ; rk <- lint_co_app co k1 [(s2,k2)]
       ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2) }

lintCoercion (ForAllCo tv co)
  = do { lintTyBndrKind tv
       ; (k, s, t) <- addInScopeVar tv (lintCoercion co)
       ; return (k, mkForAllTy tv s, mkForAllTy tv t) }
790

791
lintCoercion (CoVarCo cv)
batterseapower's avatar
batterseapower committed
792 793 794 795
  | not (isCoVar cv)
  = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv)
                  2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
  | otherwise
796
  = do { checkTyCoVarInScope cv
797
       ; cv' <- lookupIdInScope cv 
798
       ; let (s,t) = coVarKind cv'
799 800 801 802 803
             k     = typeKind s
       ; when (isSuperKind k) $
         checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality"))
                                   2 (ppr cv))
       ; return (k, s, t) }
804 805

lintCoercion (UnsafeCo ty1 ty2)
806 807 808 809 810 811
  = do { k1 <- lintType ty1
       ; _k2 <- lintType ty2
--       ; unless (k1 `eqKind` k2) $ 
--         failWithL (hang (ptext (sLit "Unsafe coercion changes kind"))
--                       2 (ppr co))
       ; return (k1, ty1, ty2) }
812 813

lintCoercion (SymCo co) 
814 815
  = do { (k, ty1, ty2) <- lintCoercion co
       ; return (k, ty2, ty1) }
816 817

lintCoercion co@(TransCo co1 co2)
818 819
  = do { (k1, ty1a, ty1b) <- lintCoercion co1
       ; (_,  ty2a, ty2b) <- lintCoercion co2
820
       ; checkL (ty1b `eqType` ty2a)
821 822
                (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
                    2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839
       ; return (k1, ty1a, ty2b) }

lintCoercion the_co@(NthCo n co)
  = do { (_,s,t) <- lintCoercion co
       ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
           (Just (tc_s, tys_s), Just (tc_t, tys_t)) 
             | tc_s == tc_t
             , tys_s `equalLength` tys_t
             , n < length tys_s
             -> return (ks, ts, tt)
             where
               ts = tys_s !! n
               tt = tys_t !! n
               ks = typeKind ts

           _ -> failWithL (hang (ptext (sLit "Bad getNth:"))
                              2 (ppr the_co $$ ppr s $$ ppr t)) }
840 841

lintCoercion (InstCo co arg_ty)
842 843 844 845
  = do { (k,s,t)  <- lintCoercion co
       ; arg_kind <- lintType arg_ty
       ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
          (Just (tv1,ty1), Just (tv2,ty2))
846
            | arg_kind `isSubKind` tyVarKind tv1
847 848
            -> return (k, substTyWith [tv1] [arg_ty] ty1, 
                          substTyWith [tv2] [arg_ty] ty2) 
849 850
            | otherwise
            -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
851 852 853 854 855 856 857
	  _ -> failWithL (ptext (sLit "Bad argument of inst")) }

lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
                                      , co_ax_lhs = lhs
                                      , co_ax_rhs = rhs })
                             cos)
  = do {  -- See Note [Kind instantiation in coercions]
858 859 860 861 862 863 864 865
         unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
       ; in_scope <- getInScope
       ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
       ; (subst_l, subst_r) <- foldlM check_ki 
                                      (empty_subst, empty_subst) 
                                      (ktvs `zip` cos)
       ; let lhs' = Type.substTy subst_l lhs
             rhs' = Type.substTy subst_r rhs
866 867 868 869
       ; return (typeKind lhs', lhs', rhs') }
  where
    bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what)
                        2 (ppr co))
870 871 872 873 874 875 876 877 878

    check_ki (subst_l, subst_r) (ktv, co)
      = do { (k, t1, t2) <- lintCoercion co
           ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
                  -- Using subst_l is ok, because subst_l and subst_r
                  -- must agree on kind equalities
           ; unless (k `isSubKind` ktv_kind) (bad_ax (ptext (sLit "check_ki2")))
           ; return (Type.extendTvSubst subst_l ktv t1, 
                     Type.extendTvSubst subst_r ktv t2) } 
879
\end{code}
dreixel's avatar
dreixel committed
880

881 882 883 884 885 886 887
%************************************************************************
%*									*
\subsection[lint-monad]{The Lint monad}
%*									*
%************************************************************************

\begin{code}
888 889 890 891 892 893
newtype LintM a = 
   LintM { unLintM :: 
            [LintLocInfo] ->         -- Locations
            TvSubst ->               -- Current type substitution; we also use this
				     -- to keep track of all the variables in scope,
				     -- both Ids and TyVars
894 895 896
	    WarnsAndErrs ->           -- Error and warning messages so far
	    (Maybe a, WarnsAndErrs) } -- Result and messages (if any)

897
type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
898

899 900 901 902 903 904 905 906 907 908 909 910 911 912 913
{-	Note [Type substitution]
	~~~~~~~~~~~~~~~~~~~~~~~~
Why do we need a type substitution?  Consider
	/\(a:*). \(x:a). /\(a:*). id a x
This is ill typed, because (renaming variables) it is really
	/\(a:*). \(x:a). /\(b:*). id b x
Hence, when checking an application, we can't naively compare x's type
(at its binding site) with its expected type (at a use site).  So we
rename type binders as we go, maintaining a substitution.

The same substitution also supports let-type, current expressed as
	(/\(a:*). body) ty
Here we substitute 'ty' for 'a' in 'body', on the fly.
-}

914
instance Monad LintM where
twanvl's avatar
twanvl committed
915
  return x = LintM (\ _   _     errs -> (Just x, errs))
916
  fail err = failWithL (text err)
917 918 919 920 921
  m >>= k  = LintM (\ loc subst errs -> 
                       let (res, errs') = unLintM m loc subst errs in
                         case res of
                           Just r -> unLintM (k r) loc subst errs'
                           Nothing -> (Nothing, errs'))
922 923

data LintLocInfo
924 925 926
  = RhsOf Id		-- The variable bound
  | LambdaBodyOf Id	-- The lambda-binder
  | BodyOfLetRec [Id]	-- One of the binders
927
  | CaseAlt CoreAlt	-- Case alternative
Thomas Schilling's avatar
Thomas Schilling committed
928
  | CasePat CoreAlt	-- The *pattern* of the case alternative
929 930
  | AnExpr CoreExpr	-- Some expression
  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
931
  | TopLevelBindings
932
  | InType Type		-- Inside a type
933
  | InCo   Coercion     -- Inside a coercion
934 935
\end{code}

936
                 
937
\begin{code}
938
initL :: LintM a -> WarnsAndErrs    -- Errors and warnings
939
initL m
940 941
  = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of
      (_, errs) -> errs
942 943 944
\end{code}

\begin{code}
945
checkL :: Bool -> MsgDoc -> LintM ()
twanvl's avatar
twanvl committed
946
checkL True  _   = return ()
947 948
checkL False msg = failWithL msg

949
failWithL :: MsgDoc -> LintM a
950 951
failWithL msg = LintM $ \ loc subst (warns,errs) ->
                (Nothing, (warns, addMsg subst errs msg loc))
sof's avatar
sof committed
952

953
addErrL :: MsgDoc -> LintM ()
954 955
addErrL msg = LintM $ \ loc subst (warns,errs) -> 
              (Just (), (warns, addMsg subst errs msg loc))
956

957
addWarnL :: MsgDoc -> LintM ()
958 959 960
addWarnL msg = LintM $ \ loc subst (warns,errs) -> 
              (Just (), (addMsg subst warns msg loc, errs))

961
addMsg :: TvSubst ->  Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
962
addMsg subst msgs msg locs
sof's avatar
sof committed
963
  = ASSERT( notNull locs )
964
    msgs `snocBag` mk_msg msg
sof's avatar
sof committed
965
  where
966 967
   (loc, cxt1) = dumpLoc (head locs)
   cxts        = [snd (dumpLoc loc) | loc <- locs]   
968
   context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
Ian Lynagh's avatar
Ian Lynagh committed
969
				      ptext (sLit "Substitution:") <+> ppr subst
970 971
	       | otherwise	    = cxt1
 
972
   mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
973 974

addLoc :: LintLocInfo -> LintM a -> LintM a
975 976
addLoc extra_loc m =
  LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
977

978 979 980 981 982 983
inCasePat :: LintM Bool		-- A slight hack; see the unique call site
inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
  where
    is_case_pat (CasePat {} : _) = True
    is_case_pat _other           = False

984
addInScopeVars :: [Var] -> LintM a -> LintM a
985
addInScopeVars vars m
986
  = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs)
987

988 989 990 991
addInScopeVar :: Var -> LintM a -> LintM a
addInScopeVar var m
  = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst var) errs)

992 993
updateTvSubst :: TvSubst -> LintM a -> LintM a
updateTvSubst subst' m = 
twanvl's avatar
twanvl committed
994
  LintM (\ loc _ errs -> unLintM m loc subst' errs)
995 996

getTvSubst :: LintM TvSubst
twanvl's avatar
twanvl committed
997
getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
998

999 1000 1001
getInScope :: LintM InScopeSet
getInScope = LintM (\ _ subst errs -> (Just (getTvInScope subst), errs))

1002
applySubstTy :: InType -> LintM OutType
1003 1004
applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }

1005
applySubstCo :: InCoercion -> LintM OutCoercion
1006
applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
1007 1008 1009

extendSubstL :: TyVar -> Type -> LintM a -> LintM a
extendSubstL tv ty m
1010
  = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs)
1011 1012 1013
\end{code}

\begin{code}
1014 1015 1016 1017 1018 1019 1020 1021
lookupIdInScope :: Id -> LintM Id
lookupIdInScope id 
  | not (mustHaveLocalBinding id)
  = return id	-- An imported Id
  | otherwise	
  = do	{ subst <- getTvSubst
	; case lookupInScope (getTvInScope subst) id of
		Just v  -> return v
1022
		Nothing -> do { addErrL out_of_scope
1023 1024
			      ; return id } }
  where
1025
    out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope")
1026

1027 1028

oneTupleDataConId :: Id	-- Should not happen
batterseapower's avatar
batterseapower committed
1029
oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1)
sof's avatar
sof committed
1030

1031
checkBndrIdInScope :: Var -> Var -> LintM ()
1032
checkBndrIdInScope binder id 
sof's avatar
sof committed
1033 1034
  = checkInScope msg id
    where
Ian Lynagh's avatar
Ian Lynagh committed
1035
     msg = ptext (sLit "is out of scope inside info for") <+> 
sof's avatar
sof committed
1036 1037
	   ppr binder

1038
checkTyCoVarInScope :: Var -> LintM ()
1039
checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v
1040

1041
checkInScope :: SDoc -> Var -> LintM ()
1042 1043 1044
checkInScope loc_msg var =
 do { subst <- getTvSubst
    ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
1045
             (hsep [pprBndr LetBind var, loc_msg]) }
sof's avatar
sof committed
1046

1047
checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
1048 1049
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
1050
-- Assumes ty1,ty2 are have alrady had the substitution applied
1051
checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
1052 1053
\end{code}

1054 1055 1056 1057 1058 1059
%************************************************************************
%*									*
\subsection{Error messages}
%*									*
%************************************************************************

1060
\begin{code}
twanvl's avatar
twanvl committed
1061 1062
dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)

sof's avatar
sof committed
1063
dumpLoc (RhsOf v)
Ian Lynagh's avatar
Ian Lynagh committed
1064
  = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
1065

sof's avatar
sof committed
1066
dumpLoc (LambdaBodyOf b)
Ian Lynagh's avatar
Ian Lynagh committed
1067
  = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
sof's avatar
sof committed
1068

1069
dumpLoc (BodyOfLetRec [])
Ian Lynagh's avatar
Ian Lynagh committed
1070
  = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
1071 1072

dumpLoc (BodyOfLetRec bs@(_:_))
Ian Lynagh's avatar
Ian Lynagh committed
1073
  = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
1074

sof's avatar
sof committed
1075 1076
dumpLoc (AnExpr e)
  = (noSrcLoc, text "In the expression:" <+> ppr e)
sof's avatar
sof committed
1077

twanvl's avatar
twanvl committed
1078
dumpLoc (CaseAlt (con, args, _))
1079 1080
  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))

twanvl's avatar
twanvl committed
1081
dumpLoc (CasePat (con, args, _))
1082
  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
1083

sof's avatar
sof committed
1084
dumpLoc (ImportedUnfolding locn)
Ian Lynagh's avatar
Ian Lynagh committed
1085
  = (locn, brackets (ptext (sLit "in an imported unfolding")))
1086 1087
dumpLoc TopLevelBindings
  = (noSrcLoc, empty)
1088 1089
dumpLoc (InType ty)
  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
1090 1091
dumpLoc (InCo co)
  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
1092