CoreLint.lhs 42.2 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}
10
module CoreLint ( lintCoreBindings, lintUnfolding ) where
11

12
#include "HsVersions.h"
13

14
import Demand
15
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
16
17
import CoreFVs
import CoreUtils
18
import Pair
19
import Bag
Simon Marlow's avatar
Simon Marlow committed
20
21
22
import Literal
import DataCon
import TysWiredIn
batterseapower's avatar
batterseapower committed
23
import TysPrim
Simon Marlow's avatar
Simon Marlow committed
24
25
import Var
import VarEnv
26
import VarSet
Simon Marlow's avatar
Simon Marlow committed
27
import Name
28
import Id
29
import PprCore
Simon Marlow's avatar
Simon Marlow committed
30
import ErrUtils
batterseapower's avatar
batterseapower committed
31
import Coercion
Simon Marlow's avatar
Simon Marlow committed
32
import SrcLoc
33
import Kind
Simon Marlow's avatar
Simon Marlow committed
34
import Type
35
import TypeRep
Simon Marlow's avatar
Simon Marlow committed
36
import TyCon
37
import TcType
Simon Marlow's avatar
Simon Marlow committed
38
39
import BasicTypes
import StaticFlags
40
import ListSetOps
41
import PrelNames
42
import Outputable
43
import FastString
44
import Util
45
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
46
import Data.Maybe
47
import Data.Traversable (traverse)
48
49
50
51
\end{code}

%************************************************************************
%*									*
52
\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
53
54
55
%*									*
%************************************************************************

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
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:
    --
75
    --  * Unsaturated type app before specialisation has been done;
76
    --
77
    --  * Oversaturated type app after specialisation (eta reduction
78
    --   may well be happening...);
79

80

81
82
Note [Linting type lets]
~~~~~~~~~~~~~~~~~~~~~~~~
83
In the desugarer, it's very very convenient to be able to say (in effect)
84
85
86
87
88
89
	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
90
	lintInTy :: Type -> LintM Type
91
92
93
94
95
96
97
98
99
100
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.


101
\begin{code}
102
lintCoreBindings :: CoreProgram -> (Bag Message, Bag Message)
103
104
--   Returns (warnings, errors)
lintCoreBindings binds
105
106
107
  = initL $ 
    addLoc TopLevelBindings $
    addInScopeVars binders  $
108
109
110
	-- Put all the top-level binders in scope at the start
	-- This is because transformation rules can bring something
	-- into use 'unexpectedly'
111
112
113
114
115
116
117
118
119
120
121
122
123
    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
124
125
126
127
128
    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
129

130
131
    lint_bind (Rec prs)		= mapM_ (lintSingleBinding TopLevel Recursive) prs
    lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
132
133
\end{code}

134
135
136
137
138
139
%************************************************************************
%*									*
\subsection[lintUnfolding]{lintUnfolding}
%*									*
%************************************************************************

140
141
We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):
142

143
\begin{code}
144
lintUnfolding :: SrcLoc
145
	      -> [Var]		-- Treat these as in scope
146
	      -> CoreExpr
147
	      -> Maybe Message	-- Nothing => OK
148

149
lintUnfolding locn vars expr
150
  | isEmptyBag errs = Nothing
151
  | otherwise       = Just (pprMessageBag errs)
152
153
154
155
  where
    (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
                            addInScopeVars vars	           $
                            lintCoreExpr expr)
156
157
\end{code}

158
159
160
161
162
%************************************************************************
%*									*
\subsection[lintCoreBinding]{lintCoreBinding}
%*									*
%************************************************************************
163

164
Check a core binding, returning the list of variables bound.
165
166

\begin{code}
twanvl's avatar
twanvl committed
167
lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
168
lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
169
  = addLoc (RhsOf binder) $
170
171
172
         -- Check the rhs 
    do { ty <- lintCoreExpr rhs	
       ; lintBinder binder -- Check match to RHS type
173
       ; binder_ty <- applySubstTy binder_ty
174
175
176
       ; checkTys binder_ty ty (mkRhsMsg binder ty)
        -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
       ; checkL (not (isUnLiftedType binder_ty)
177
            || (isNonRec rec_flag && exprOkForSpeculation rhs))
178
 	   (mkRhsPrimMsg binder rhs)
179
180
181
182
        -- 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)
sof's avatar
sof committed
183
        -- Check whether binder's specialisations contain any out-of-scope variables
184
185
       ; mapM_ (checkBndrIdInScope binder) bndr_vars 

186
       ; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder))
187
188
              (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder))
	      -- Only non-rule loop breakers inhibit inlining
189

190
191
192
193
194
195
      -- 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
196
	  
197
	-- We should check the unfolding, if any, but this is tricky because
198
199
200
 	-- the unfolding is a SimplifiableCoreExpr. Give up for now.
   where
    binder_ty                  = idType binder
201
    maybeDmdTy                 = idStrictness_maybe binder
202
    bndr_vars                  = varSetElems (idFreeVars binder)
203
204
    lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
	           | otherwise = return ()
205
206
\end{code}

207
208
209
210
211
212
%************************************************************************
%*									*
\subsection[lintCoreExpr]{lintCoreExpr}
%*									*
%************************************************************************

213
\begin{code}
214
215
216
217
type InType      = Type	-- Substitution not yet applied
type InCoercion  = Coercion
type InVar       = Var
type InTyVar     = TyVar
218

219
220
221
222
type OutType     = Type	-- Substitution has been applied to this
type OutCoercion = Coercion
type OutVar      = Var
type OutTyVar    = TyVar
223

224
lintCoreExpr :: CoreExpr -> LintM OutType
225
226
-- The returned type has the substitution from the monad 
-- already applied to it:
227
--	lintCoreExpr e subst = exprType (subst e)
228
229
--
-- The returned "type" can be a kind, if the expression is (Type ty)
230
231

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

235
236
237
        ; checkL (isId var && not (isCoVar var))
                 (ptext (sLit "Non term variable") <+> ppr var)

238
        ; checkDeadIdOcc var
239
	; var' <- lookupIdInScope var
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
240
        ; return (idType var') }
241

242
243
lintCoreExpr (Lit lit)
  = return (literalType lit)
244

245
246
lintCoreExpr (Cast expr co)
  = do { expr_ty <- lintCoreExpr expr
247
       ; co' <- applySubstCo co
248
       ; (from_ty, to_ty) <- lintCoercion co'
249
250
       ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
       ; return to_ty }
251

twanvl's avatar
twanvl committed
252
lintCoreExpr (Note _ expr)
253
  = lintCoreExpr expr
254

255
lintCoreExpr (Let (NonRec tv (Type ty)) body)
256
257
258
  | isTyVar tv
  =	-- See Note [Linting type lets]
    do	{ ty' <- addLoc (RhsOf tv) $ lintInTy ty
259
260
261
        ; lintTyBndr tv              $ \ tv' -> 
          addLoc (BodyOfLetRec [tv]) $ 
          extendSubstL tv' ty'       $ do
262
        { checkTyKind tv' ty'
263
264
		-- Now extend the substitution so we 
		-- take advantage of it in the body
265
        ; lintCoreExpr body } }
266

267
lintCoreExpr (Let (NonRec bndr rhs) body)
268
  | isId bndr
269
  = do	{ lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
270
	; addLoc (BodyOfLetRec [bndr]) 
271
		 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
272

273
274
275
  | otherwise
  = failWithL (mkLetErr bndr rhs)	-- Not quite accurate

276
lintCoreExpr (Let (Rec pairs) body) 
277
  = lintAndScopeIds bndrs	$ \_ ->
278
279
    do	{ checkL (null dups) (dupVars dups)
        ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs	
280
	; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
281
282
  where
    bndrs = map fst pairs
283
    (_, dups) = removeDups compare bndrs
284

batterseapower's avatar
batterseapower committed
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
lintCoreExpr e@(App _ _)
    | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
                   -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
                   -- we should do this properly
    , Just dc <- isDataConWorkId_maybe x
    , dc == eqBoxDataCon
    , [Type arg_ty1, Type arg_ty2, co_e] <- args
    = do arg_kind1 <- lintType arg_ty1
         arg_kind2 <- lintType arg_ty2
         unless (arg_kind1 `eqKind` arg_kind2)
                (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2))
         
         lintCoreArg (mkCoercionType arg_ty1 arg_ty2 `mkFunTy` mkEqPred (arg_ty1, arg_ty2)) co_e
    | otherwise
    = do { fun_ty <- lintCoreExpr fun
         ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
  where
    (fun, args) = collectArgs e
303
304

lintCoreExpr (Lam var expr)
305
  = addLoc (LambdaBodyOf var) $
306
307
308
    lintBinders [var] $ \ vars' ->
    do { let [var'] = vars'  
       ; body_ty <- lintCoreExpr expr
309
310
311
312
313
       ; if isId var' then 
             return (mkFunTy (idType var') body_ty) 
	 else
	     return (mkForAllTy var' body_ty)
       }
314
	-- The applySubstTy is needed to apply the subst to var
315
316
317
318

lintCoreExpr e@(Case scrut var alt_ty alts) =
       -- Check the scrutinee
  do { scrut_ty <- lintCoreExpr scrut
319
320
     ; alt_ty   <- lintInTy alt_ty  
     ; var_ty   <- lintInTy (idType var)	
321

322
323
     ; case tyConAppTyCon_maybe (idType var) of 
         Just tycon
324
325
              | debugIsOn &&
                isAlgTyCon tycon && 
326
		not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
327
                null (tyConDataCons tycon) -> 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
328
329
                  pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
			-- This can legitimately happen for type families
330
331
332
                      $ return ()
         _otherwise -> return ()

333
	-- Don't use lintIdBndr on var, because unboxed tuple is legitimate
334

335
336
     ; subst <- getTvSubst 
     ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
337
338

     -- If the binder is an unboxed tuple type, don't put it in scope
339
340
341
342
     ; let scope = if (isUnboxedTupleType (idType var)) then 
                       pass_var 
                   else lintAndScopeId var
     ; scope $ \_ ->
343
       do { -- Check the alternatives
344
            mapM_ (lintCoreAlt scrut_ty alt_ty) alts
345
          ; checkCaseAlts e scrut_ty alts
346
          ; return alt_ty } }
347
348
  where
    pass_var f = f var
349

350
lintCoreExpr (Type ty)
351
  = do { ty' <- lintInTy ty
352
       ; return (typeKind ty') }
353
354
355
356

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

360
361
362
363
364
%************************************************************************
%*									*
\subsection[lintCoreArgs]{lintCoreArgs}
%*									*
%************************************************************************
365

366
367
The basic version of these functions checks that the argument is a
subtype of the required type, as one would expect.
368

369
\begin{code}
370
lintCoreArg  :: OutType -> CoreArg -> LintM OutType
371
lintCoreArg fun_ty (Type arg_ty)
372
373
  = do { arg_ty' <- applySubstTy arg_ty
       ; lintTyApp fun_ty arg_ty' }
374
375

lintCoreArg fun_ty arg
376
377
  = do { arg_ty <- lintCoreExpr arg
       ; lintValApp arg fun_ty arg_ty }
378
379
380
381
382
383
384
385
386

-----------------
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)
387
  | isTyVar bndr
388
389
390
391
392
393
394
395
396
397
  = 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
398
399
400
401
  , isTyVar tyvar
  = do	{ checkTyKind tyvar arg_ty
        ; return (substTyWith [tyvar] [arg_ty] body_ty) }

402
403
  | otherwise
  = failWithL (mkTyAppMsg fun_ty arg_ty)
404
405
406
407
408
409
410
411
412
413
414
415
   
-----------------
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
416
\end{code}
417

418
\begin{code}
419
checkTyKind :: OutTyVar -> OutType -> LintM ()
420
-- Both args have had substitution applied
421
checkTyKind tyvar arg_ty
422
423
424
425
	-- 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.
426
427
428
  = do { arg_kind <- lintType arg_ty
       ; unless (arg_kind `isSubKind` tyvar_kind)
                (addErrL (mkKindErrMsg tyvar arg_ty)) }
429
430
  where
    tyvar_kind = tyVarKind tyvar
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446

-- Check that the kinds of a type variable and a coercion match, that
-- is, if tv :: k  then co :: t1 ~ t2  where t1 :: k and t2 :: k.
checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
checkTyCoKind tv co
  = do { (t1,t2) <- lintCoercion co
       ; k1      <- lintType t1
       ; k2      <- lintType t2
       ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
                (addErrL (mkTyCoAppErrMsg tv co))
       ; return (t1,t2) }
  where 
    tyvar_kind = tyVarKind tv

checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
checkTyCoKinds = zipWithM checkTyCoKind
447
448
449
450
451
452
453
454
455
456
457

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 ()
458
\end{code}
459
460


461
462
463
464
465
466
467
%************************************************************************
%*									*
\subsection[lintCoreAlts]{lintCoreAlts}
%*									*
%************************************************************************

\begin{code}
468
checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
469
-- a) Check that the alts are non-empty
470
471
-- b1) Check that the DEFAULT comes first, if it exists
-- b2) Check that the others are in increasing order
472
473
474
475
476
-- 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.

twanvl's avatar
twanvl committed
477
checkCaseAlts e _ []
478
479
  = addErrL (mkNullAltsMsg e)

480
481
checkCaseAlts e ty alts = 
  do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
482
     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
483
484
     ; checkL (isJust maybe_deflt || not is_infinite_ty)
	   (nonExhaustiveAltsMsg e) }
485
486
  where
    (con_alts, maybe_deflt) = findDefault alts
487

488
489
	-- Check that successive alternatives have increasing tags 
    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
twanvl's avatar
twanvl committed
490
    increasing_tag _                         = True
491

492
    non_deflt (DEFAULT, _, _) = False
twanvl's avatar
twanvl committed
493
    non_deflt _               = True
494

495
496
497
    is_infinite_ty = case tyConAppTyCon_maybe ty of
                        Nothing    -> False
                        Just tycon -> isPrimTyCon tycon
498
499
500
\end{code}

\begin{code}
501
502
checkAltExpr :: CoreExpr -> OutType -> LintM ()
checkAltExpr expr ann_ty
503
  = do { actual_ty <- lintCoreExpr expr 
504
       ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
505

506
507
lintCoreAlt :: OutType 		-- Type of scrutinee
            -> OutType          -- Type of the alternative
508
	    -> CoreAlt
509
	    -> LintM ()
510

twanvl's avatar
twanvl committed
511
lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
512
513
  do { checkL (null args) (mkDefaultArgsMsg args)
     ; checkAltExpr rhs alt_ty }
514

515
lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
516
  | isIntegerTy scrut_ty
517
518
519
520
521
    = failWithL integerScrutinisedMsg
  | otherwise
    = do { checkL (null args) (mkDefaultArgsMsg args)
         ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
         ; checkAltExpr rhs alt_ty }
522
523
  where
    lit_ty = literalType lit
524

525
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
526
527
  | isNewTyCon (dataConTyCon con) 
  = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
528
  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
529
530
531
  = addLoc (CaseAlt alt) $  do
    {   -- First instantiate the universally quantified 
	-- type variables of the data constructor
532
533
534
	-- We've already check
      checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
    ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
535
536

	-- And now bring the new binders into scope
537
538
    ; lintBinders args $ \ args' -> do
    { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
539
    ; checkAltExpr rhs alt_ty } }
540
541
542

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

sof's avatar
sof committed
545
546
%************************************************************************
%*									*
547
\subsection[lint-types]{Types}
sof's avatar
sof committed
548
549
550
551
%*									*
%************************************************************************

\begin{code}
552
553
554
555
556
557
558
559
560
561
562
563
-- 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
564
565
566
567
568
569
  | isId var  = lintIdBndr var linterF
  | otherwise = lintTyBndr var linterF

lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
lintTyBndr tv thing_inside
  = do { subst <- getTvSubst
570
       ; let (subst', tv') = Type.substTyVarBndr subst tv
571
572
       ; lintTyBndrKind tv'
       ; updateTvSubst subst' (thing_inside tv') }
573

574
lintIdBndr :: Id -> (Id -> LintM a) -> LintM a
575
576
-- 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
577
-- ToDo: lint its rules
578

579
lintIdBndr id linterF 
580
581
582
  = do 	{ checkL (not (isUnboxedTupleType (idType id))) 
		 (mkUnboxedTupleMsg id)
		-- No variable can be bound to an unboxed tuple.
583
        ; lintAndScopeId id $ \id' -> linterF id' }
584
585
586
587
588
589

lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
lintAndScopeIds ids linterF 
  = go ids
  where
    go []       = linterF []
590
591
592
    go (id:ids) = lintAndScopeId id $ \id ->
                  lintAndScopeIds ids $ \ids ->
                  linterF (id:ids)
593

594
lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a
595
lintAndScopeId id linterF 
596
  = do { ty <- lintInTy (idType id)
597
       ; let id' = setIdType id ty
598
599
600
601
602
603
604
605
606
       ; addInScopeVar id' $ (linterF id') }
\end{code}


%************************************************************************
%*									*
\subsection[lint-monad]{The Lint monad}
%*									*
%************************************************************************
607

608
609
\begin{code}
lintInTy :: InType -> LintM OutType
610
-- Check the type, and apply the substitution to it
611
-- See Note [Linting type lets]
612
-- ToDo: check the kind structure of the type
613
614
lintInTy ty 
  = addLoc (InType ty) $
615
    do	{ ty' <- applySubstTy ty
616
	; _ <- lintType ty'
617
	; return ty' }
sof's avatar
sof committed
618

619
620
621
622
623
624
625
626
627
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' }

628
629
630
631
-------------------
lintKind :: Kind -> LintM ()
-- Check well-formedness of kinds: *, *->*, etc
lintKind (TyConApp tc []) 
632
  | tyConKind tc `eqKind` tySuperKind
633
634
635
636
637
638
639
640
  = return ()
lintKind (FunTy k1 k2)
  = lintKind k1 >> lintKind k2
lintKind kind 
  = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)))

-------------------
lintTyBndrKind :: OutTyVar -> LintM ()
641
lintTyBndrKind tv = lintKind (tyVarKind tv)
642
643

-------------------
644
lintCoercion :: OutCoercion -> LintM (OutType, OutType)
645
-- Check the kind of a coercion term, returning the kind
646
647
648
lintCoercion (Refl ty)
  = do { ty' <- lintInTy ty
       ; return (ty', ty') }
649

650
651
652
653
lintCoercion co@(TyConAppCo tc cos)
  = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
       ; check_co_app co (tyConKind tc) ss
       ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
654

655
656
657
658
659
lintCoercion co@(AppCo co1 co2)
  = do { (s1,t1) <- lintCoercion co1
       ; (s2,t2) <- lintCoercion co2
       ; check_co_app co (typeKind s1) [s2]
       ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
660

661
662
663
664
lintCoercion (ForAllCo v co)
  = do { lintKind (tyVarKind v)
       ; (s,t) <- addInScopeVar v (lintCoercion co)
       ; return (ForAllTy v s, ForAllTy v t) }
665

666
lintCoercion (CoVarCo cv)
batterseapower's avatar
batterseapower committed
667
668
669
670
  | not (isCoVar cv)
  = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv)
                  2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
  | otherwise
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
  = do { checkTyCoVarInScope cv
       ; return (coVarKind cv) }

lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs
                                   , co_ax_lhs = lhs
                                   , co_ax_rhs = rhs }) 
                           cos)
  = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos)
       ; return (substTyWith tvs tys1 lhs,
                 substTyWith tvs tys2 rhs) }

lintCoercion (UnsafeCo ty1 ty2)
  = do { ty1' <- lintInTy ty1
       ; ty2' <- lintInTy ty2
       ; return (ty1', ty2') }

lintCoercion (SymCo co) 
  = do { (ty1, ty2) <- lintCoercion co
       ; return (ty2, ty1) }

lintCoercion co@(TransCo co1 co2)
692
693
  = do { (ty1a, ty1b) <- lintCoercion co1
       ; (ty2a, ty2b) <- lintCoercion co2
694
       ; checkL (ty1b `eqType` ty2a)
695
696
697
698
                (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
                    2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
       ; return (ty1a, ty2b) }

699
700
701
702
703
704
705
706
lintCoercion the_co@(NthCo d co)
  = do { (s,t) <- lintCoercion co
       ; sn <- checkTcApp the_co d s
       ; tn <- checkTcApp the_co d t
       ; return (sn, tn) }

lintCoercion (InstCo co arg_ty)
  = do { co_tys    <- lintCoercion co
707
       ; arg_kind  <- lintType arg_ty
708
709
       ; case splitForAllTy_maybe `traverse` toPair co_tys of
          Just (Pair (tv1,ty1) (tv2,ty2))
710
711
712
713
714
715
716
717
            | arg_kind `isSubKind` tyVarKind tv1
            -> return (substTyWith [tv1] [arg_ty] ty1, 
                       substTyWith [tv2] [arg_ty] ty2) 
            | otherwise
            -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
	  Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }

----------
718
719
checkTcApp :: Coercion -> Int -> Type -> LintM Type
checkTcApp co n ty
720
  | Just tys <- tyConAppArgs_maybe ty
721
722
723
724
725
  , n < length tys
  = return (tys !! n)
  | otherwise
  = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co)
                  2 (ptext (sLit "Offending type:") <+> ppr ty))
726

727
728
729
-------------------
lintType :: OutType -> LintM Kind
lintType (TyVarTy tv)
730
  = do { checkTyCoVarInScope tv
731
732
733
734
735
736
737
738
739
740
       ; return (tyVarKind tv) }

lintType ty@(AppTy t1 t2) 
  = do { k1 <- lintType t1
       ; lint_ty_app ty k1 [t2] }

lintType ty@(FunTy t1 t2)
  = lint_ty_app ty (tyConKind funTyCon) [t1,t2]

lintType ty@(TyConApp tc tys)
batterseapower's avatar
batterseapower committed
741
742
743
  | tc `hasKey` eqPrimTyConKey	-- See Note [The ~# TyCon] in TysPrim
  = lint_prim_eq_pred ty tys
  | tc `hasKey` eqTyConKey
744
  = lint_eq_pred ty tys
745
746
747
748
749
750
751
752
753
754
755
756
757
758
  | tyConHasKind tc
  = lint_ty_app ty (tyConKind tc) tys
  | otherwise
  = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))

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

----------------
lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
lint_ty_app ty k tys 
  = do { ks <- mapM lintType tys
       ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
759
760

lint_eq_pred :: Type -> [OutType] -> LintM Kind
batterseapower's avatar
batterseapower committed
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
lint_eq_pred ty arg_tys = case arg_tys of
  [ty1, ty2] ->  do { k1 <- lintType ty1
                    ; k2 <- lintType ty2
                    ; unless (k1 `eqKind` k2) 
                             (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
                                           , nest 2 (ppr ty) ]))
                    ; return constraintKind }
  [ty1] -> do { k1 <- lintType ty1;
                return (k1 `mkFunTy` constraintKind) }
  []    -> do { return (typeKind ty) }
  _     -> failWithL (ptext (sLit "Oversaturated (~) type") <+> ppr ty)


lint_prim_eq_pred :: Type -> [OutType] -> LintM Kind
lint_prim_eq_pred ty arg_tys
776
777
778
779
780
781
782
  | [ty1,ty2] <- arg_tys
  = do { k1 <- lintType ty1
       ; k2 <- lintType ty2
       ; checkL (k1 `eqKind` k2) 
                (ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
       ; return unliftedTypeKind }
  | otherwise
batterseapower's avatar
batterseapower committed
783
  = failWithL (ptext (sLit "Unsaturated ~# type") <+> ppr ty)
784

785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
----------------
check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
check_co_app ty k tys 
  = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty))  
                            k (map typeKind tys)
       ; return () }
                      
----------------
lint_kind_app :: SDoc -> Kind -> [Kind] -> LintM Kind
lint_kind_app doc kfn ks = go kfn ks
  where
    fail_msg = vcat [hang (ptext (sLit "Kind application error in")) 2 doc,
               	     nest 2 (ptext (sLit "Function kind =") <+> ppr kfn),
               	     nest 2 (ptext (sLit "Arg kinds =") <+> ppr ks)]

    go kfn []     = return kfn
    go kfn (k:ks) = case splitKindFunTy_maybe kfn of
       	              Nothing         -> failWithL fail_msg
		      Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
                                                     (addErrL fail_msg)
                                            ; go kfb ks } 
\end{code}
807
    
808
809
810
811
812
813
814
%************************************************************************
%*									*
\subsection[lint-monad]{The Lint monad}
%*									*
%************************************************************************

\begin{code}
815
816
817
818
819
820
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
821
822
823
824
	    WarnsAndErrs ->           -- Error and warning messages so far
	    (Maybe a, WarnsAndErrs) } -- Result and messages (if any)

type WarnsAndErrs = (Bag Message, Bag Message)
825

826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
{-	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.
-}

841
instance Monad LintM where
twanvl's avatar
twanvl committed
842
  return x = LintM (\ _   _     errs -> (Just x, errs))
843
  fail err = failWithL (text err)
844
845
846
847
848
  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'))
849
850

data LintLocInfo
851
852
853
  = RhsOf Id		-- The variable bound
  | LambdaBodyOf Id	-- The lambda-binder
  | BodyOfLetRec [Id]	-- One of the binders
854
  | CaseAlt CoreAlt	-- Case alternative
Thomas Schilling's avatar
Thomas Schilling committed
855
  | CasePat CoreAlt	-- The *pattern* of the case alternative
856
857
  | AnExpr CoreExpr	-- Some expression
  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
858
  | TopLevelBindings
859
  | InType Type		-- Inside a type
860
  | InCo   Coercion     -- Inside a coercion
861
862
\end{code}

863
                 
864
\begin{code}
865
initL :: LintM a -> WarnsAndErrs    -- Errors and warnings
866
initL m
867
868
  = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of
      (_, errs) -> errs
869
870
871
\end{code}

\begin{code}
sof's avatar
sof committed
872
checkL :: Bool -> Message -> LintM ()
twanvl's avatar
twanvl committed
873
checkL True  _   = return ()
874
875
876
877
878
checkL False msg = failWithL msg

failWithL :: Message -> LintM a
failWithL msg = LintM $ \ loc subst (warns,errs) ->
                (Nothing, (warns, addMsg subst errs msg loc))
sof's avatar
sof committed
879

880
881
882
addErrL :: Message -> LintM ()
addErrL msg = LintM $ \ loc subst (warns,errs) -> 
              (Just (), (warns, addMsg subst errs msg loc))
883

884
885
886
887
888
889
addWarnL :: Message -> LintM ()
addWarnL msg = LintM $ \ loc subst (warns,errs) -> 
              (Just (), (addMsg subst warns msg loc, errs))

addMsg :: TvSubst ->  Bag Message -> Message -> [LintLocInfo] -> Bag Message
addMsg subst msgs msg locs
sof's avatar
sof committed
890
  = ASSERT( notNull locs )
891
    msgs `snocBag` mk_msg msg
sof's avatar
sof committed
892
  where
893
894
   (loc, cxt1) = dumpLoc (head locs)
   cxts        = [snd (dumpLoc loc) | loc <- locs]   
895
   context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
Ian Lynagh's avatar
Ian Lynagh committed
896
				      ptext (sLit "Substitution:") <+> ppr subst
897
898
	       | otherwise	    = cxt1
 
899
   mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
900
901

addLoc :: LintLocInfo -> LintM a -> LintM a
902
903
addLoc extra_loc m =
  LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
904

905
906
907
908
909
910
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

911
addInScopeVars :: [Var] -> LintM a -> LintM a
912
addInScopeVars vars m
913
  = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs)
914

915
916
917
918
addInScopeVar :: Var -> LintM a -> LintM a
addInScopeVar var m
  = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst var) errs)

919
920
updateTvSubst :: TvSubst -> LintM a -> LintM a
updateTvSubst subst' m = 
twanvl's avatar
twanvl committed
921
  LintM (\ loc _ errs -> unLintM m loc subst' errs)
922
923

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

926
927
928
929
930
applySubstTy :: Type -> LintM Type
applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }

applySubstCo :: Coercion -> LintM Coercion
applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
931
932
933

extendSubstL :: TyVar -> Type -> LintM a -> LintM a
extendSubstL tv ty m
934
  = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs)
935
936
937
\end{code}

\begin{code}
938
939
940
941
942
943
944
945
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
946
		Nothing -> do { addErrL out_of_scope
947
948
			      ; return id } }
  where
Ian Lynagh's avatar
Ian Lynagh committed
949
    out_of_scope = ppr id <+> ptext (sLit "is out of scope")
950

951
952

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

955
checkBndrIdInScope :: Var -> Var -> LintM ()
956
checkBndrIdInScope binder id 
sof's avatar
sof committed
957
958
  = checkInScope msg id
    where
Ian Lynagh's avatar
Ian Lynagh committed
959
     msg = ptext (sLit "is out of scope inside info for") <+> 
sof's avatar
sof committed
960
961
	   ppr binder

962
checkTyCoVarInScope :: Var -> LintM ()
963
checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v
964

965
checkInScope :: SDoc -> Var -> LintM ()
966
967
968
969
checkInScope loc_msg var =
 do { subst <- getTvSubst
    ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
             (hsep [ppr var, loc_msg]) }
sof's avatar
sof committed
970

971
checkTys :: OutType -> OutType -> Message -> LintM ()
972
973
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
974
-- Assumes ty1,ty2 are have alrady had the substitution applied
975
checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
976
977
\end{code}

978
979
980
981
982
983
%************************************************************************
%*									*
\subsection{Error messages}
%*									*
%************************************************************************

984
\begin{code}
twanvl's avatar
twanvl committed
985
986
dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)

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

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

993
dumpLoc (BodyOfLetRec [])
Ian Lynagh's avatar
Ian Lynagh committed
994
  = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
995
996

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

sof's avatar
sof committed
999
1000
dumpLoc (AnExpr e)
  = (noSrcLoc, text "In the expression:" <+> ppr e)
sof's avatar
sof committed
1001

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

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

sof's avatar
sof committed
1008
dumpLoc (ImportedUnfolding locn)
Ian Lynagh's avatar
Ian Lynagh committed
1009
  = (locn, brackets (ptext (sLit "in an imported unfolding")))
1010
1011
dumpLoc TopLevelBindings
  = (noSrcLoc, empty)
1012
1013
dumpLoc (InType ty)
  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
1014
1015
dumpLoc (InCo co)
  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
1016

1017
pp_binders :: [Var] -> SDoc
1018
1019
pp_binders bs = sep (punctuate comma (map pp_binder bs))

1020
1021
pp_binder :: Var -> SDoc
pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
twanvl's avatar
twanvl committed
1022
            | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
1023
\end{code}
1024

1025
1026
1027
1028
\begin{code}
------------------------------------------------------
--	Messages for case expressions

sof's avatar
sof committed
1029
mkNullAltsMsg :: CoreExpr -> Message
1030
1031
1032
1033
mkNullAltsMsg e 
  = hang (text "Case expression with no alternatives:")
	 4 (ppr e)

1034
mkDefaultArgsMsg :: [Var] -> Message
1035
1036
1037
1038
mkDefaultArgsMsg args 
  = hang (text "DEFAULT case with binders")
	 4 (ppr args)

1039
1040
1041
1042
mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
mkCaseAltMsg e ty1 ty2
  = hang (text "Type of case alternatives not the same as the annotation on case:")
	 4 (vcat [ppr ty1, ppr ty2, ppr e])
1043

1044
1045
mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
mkScrutMsg var var_ty scrut_ty subst
1046
  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
1047
1048
	  text "Result binder type:" <+> ppr var_ty,--(idType var),
	  text "Scrutinee type:" <+> ppr scrut_ty,
Ian Lynagh's avatar
Ian Lynagh committed
1049
     hsep [ptext (sLit "Current TV subst"), ppr subst]]
1050

twanvl's avatar
twanvl committed
1051
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
1052
1053
mkNonDefltMsg e
  = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
1054
1055
mkNonIncreasingAltsMsg e
  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
1056

sof's avatar
sof committed
1057
nonExhaustiveAltsMsg :: CoreExpr -> Message
1058
nonExhaustiveAltsMsg e
1059
  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
1060

1061
1062
1063
1064
1065
1066
1067
1068
mkBadConMsg :: TyCon -> DataCon -> Message
mkBadConMsg tycon datacon
  = vcat [
	text "In a case alternative, data constructor isn't in scrutinee type:",
	text "Scrutinee type constructor:" <+> ppr tycon,
	text "Data con:" <+> ppr datacon
    ]

sof's avatar
sof committed
1069
mkBadPatMsg :: Type -> Type -> Message
1070
1071
1072
1073
1074
1075
mkBadPatMsg con_result_ty scrut_ty
  = vcat [
	text "In a case alternative, pattern result type doesn't match scrutinee type:",
	text "Pattern result type:" <+> ppr con_result_ty,
	text "Scrutinee type:" <+> ppr scrut_ty
    ]
1076

1077
1078
1079
1080
integerScrutinisedMsg :: Message
integerScrutinisedMsg
  = text "In a case alternative, scrutinee type is Integer"

1081
1082
1083
1084
1085
1086
mkBadAltMsg :: Type -> CoreAlt -> Message
mkBadAltMsg scrut_ty alt
  = vcat [ text "Data alternative when scrutinee is not a tycon application",
	   text "Scrutinee type:" <+> ppr scrut_ty,
	   text "Alternative:" <+> pprCoreAlt alt ]

1087
1088
1089
1090
1091
1092
1093
mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
mkNewTyDataConAltMsg scrut_ty alt
  = vcat [ text "Data alternative for newtype datacon",
	   text "Scrutinee type:" <+> ppr scrut_ty,
	   text "Alternative:" <+> pprCoreAlt alt ]


1094
1095
------------------------------------------------------
--	Other error messages
1096