TcPat.lhs 39.6 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
5
6

TcPat: Typechecking patterns
7
8

\begin{code}
9
{-# OPTIONS -w #-}
10
11
12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14
15
-- for details

16
module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcProcPat, tcOverloadedLit,
17
	       addDataConStupidTheta, badFieldCon, polyPatSig ) where
18

19
#include "HsVersions.h"
20

21
import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRho)
22
23
24

import HsSyn
import TcHsSyn
25
import TcRnMonad
26
27
28
29
30
31
32
33
34
35
36
37
38
39
import Inst
import Id
import Var
import CoreFVs
import Name
import TcSimplify
import TcEnv
import TcMType
import TcType
import VarSet
import TcUnify
import TcHsType
import TysWiredIn
import Type
40
import Coercion
41
42
43
import StaticFlags
import TyCon
import DataCon
44
import DynFlags
45
46
47
48
49
50
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import SrcLoc
import ErrUtils
import Util
import Maybes
sof's avatar
sof committed
51
import Outputable
52
import FastString
53
import Monad
54
\end{code}
55

56
57
58

%************************************************************************
%*									*
59
		External interface
60
61
62
63
%*									*
%************************************************************************

\begin{code}
64
65
tcLetPat :: (Name -> Maybe TcRhoType)
      	 -> LPat Name -> BoxySigmaType 
66
     	 -> TcM a
67
68
      	 -> TcM (LPat TcId, a)
tcLetPat sig_fn pat pat_ty thing_inside
69
  = do	{ let init_state = PS { pat_ctxt = LetPat sig_fn,
70
				pat_eqs  = False }
71
72
	; (pat', ex_tvs, res) <- tc_lpat pat pat_ty init_state 
                                   (\ _ -> thing_inside)
73
74
75
76
77
78
79

	-- Don't know how to deal with pattern-bound existentials yet
	; checkTc (null ex_tvs) (existentialExplode pat)

	; return (pat', res) }

-----------------
80
81
82
83
tcLamPats :: [LPat Name]		-- Patterns,
	  -> [BoxySigmaType]		--   and their types
	  -> BoxyRhoType 		-- Result type,
	  -> (BoxyRhoType -> TcM a)	--   and the checker for the body
84
	  -> TcM ([LPat TcId], a)
85
86
87
88
89
90
91
92
93

-- This is the externally-callable wrapper function
-- Typecheck the patterns, extend the environment to bind the variables,
-- do the thing inside, use any existentially-bound dictionaries to 
-- discharge parts of the returning LIE, and deal with pattern type
-- signatures

--   1. Initialise the PatState
--   2. Check the patterns
94
95
--   3. Check the body
--   4. Check that no existentials escape
96

97
tcLamPats pats tys res_ty thing_inside
98
  = tc_lam_pats LamPat (zipEqual "tcLamPats" pats tys)
99
	        res_ty thing_inside
100
101

tcLamPat :: LPat Name -> BoxySigmaType 
102
103
      	 -> BoxyRhoType		    -- Result type
      	 -> (BoxyRhoType -> TcM a)  -- Checker for body, given its result type
104
      	 -> TcM (LPat TcId, a)
105
106
107
108
109
110

tcProcPat = tc_lam_pat ProcPat
tcLamPat  = tc_lam_pat LamPat

tc_lam_pat ctxt pat pat_ty res_ty thing_inside
  = do	{ ([pat'],thing) <- tc_lam_pats ctxt [(pat, pat_ty)] res_ty thing_inside
111
	; return (pat', thing) }
112

113
-----------------
114
115
tc_lam_pats :: PatCtxt
	    -> [(LPat Name,BoxySigmaType)]
116
117
       	    -> BoxyRhoType            -- Result type
       	    -> (BoxyRhoType -> TcM a) -- Checker for body, given its result type
118
       	    -> TcM ([LPat TcId], a)
119
120
tc_lam_pats ctxt pat_ty_prs res_ty thing_inside 
  =  do	{ let init_state = PS { pat_ctxt = ctxt, pat_eqs = False }
121

122
123
124
125
126
	; (pats', ex_tvs, res) <- do { traceTc (text "tc_lam_pats" <+> (ppr pat_ty_prs $$ ppr res_ty)) 
				  ; tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
				    if (pat_eqs pstate' && (not $ isRigidTy res_ty))
				     then nonRigidResult res_ty
	     			     else thing_inside res_ty }
127

128
129
	; let tys = map snd pat_ty_prs
	; tcCheckExistentialPat pats' ex_tvs tys res_ty
130

131
	; return (pats', res) }
132
133
134


-----------------
135
tcCheckExistentialPat :: [LPat TcId]		-- Patterns (just for error message)
136
137
138
139
140
141
142
143
144
145
146
		      -> [TcTyVar]		-- Existentially quantified tyvars bound by pattern
		      -> [BoxySigmaType]	-- Types of the patterns
		      -> BoxyRhoType		-- Type of the body of the match
		      				-- Tyvars in either of these must not escape
		      -> TcM ()
-- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
-- For example, we must reject this program:
--	data C = forall a. C (a -> Int) 
-- 	f (C g) x = g x
-- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).

147
tcCheckExistentialPat pats [] pat_tys body_ty
148
149
  = return ()	-- Short cut for case when there are no existentials

150
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
151
  = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty)	$
152
153
154
155
    checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs

data PatState = PS {
	pat_ctxt :: PatCtxt,
156
157
158
	pat_eqs  :: Bool        -- <=> there are any equational constraints 
				-- Used at the end to say whether the result
				-- type must be rigid
159
160
161
162
  }

data PatCtxt 
  = LamPat 
163
164
  | ProcPat				-- The pattern in (proc pat -> ...)
					--	see Note [Arrows and patterns]
165
166
167
168
169
  | LetPat (Name -> Maybe TcRhoType)	-- Used for let(rec) bindings

patSigCtxt :: PatState -> UserTypeCtxt
patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
patSigCtxt other			= LamPatSigCtxt
170
171
172
\end{code}


173

174
175
%************************************************************************
%*									*
176
		Binders
177
178
179
%*									*
%************************************************************************

180
\begin{code}
181
182
183
184
185
tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId
tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
  | Just mono_ty <- lookup_sig bndr_name
  = do	{ mono_name <- newLocalName bndr_name
	; boxyUnify mono_ty pat_ty
186
	; return (Id.mkLocalId mono_name mono_ty) }
187
188

  | otherwise
189
  = do	{ pat_ty' <- unBoxPatBndrType pat_ty bndr_name
190
	; mono_name <- newLocalName bndr_name
191
	; return (Id.mkLocalId mono_name pat_ty') }
192

193
194
195
196
197
198
199
200
201
202
203
204
tcPatBndr (PS { pat_ctxt = _lam_or_proc }) bndr_name pat_ty
  = do	{ pat_ty' <- unBoxPatBndrType pat_ty bndr_name
		-- We have an undecorated binder, so we do rule ABS1,
		-- by unboxing the boxy type, forcing any un-filled-in
		-- boxes to become monotypes
		-- NB that pat_ty' can still be a polytype:
		-- 	data T = MkT (forall a. a->a)
		-- 	f t = case t of { MkT g -> ... }
		-- Here, the 'g' must get type (forall a. a->a) from the
		-- MkT context
	; return (Id.mkLocalId bndr_name pat_ty') }

205
206
207
208
209
210
211
212
213
214

-------------------
bindInstsOfPatId :: TcId -> TcM a -> TcM (a, LHsBinds TcId)
bindInstsOfPatId id thing_inside
  | not (isOverloadedTy (idType id))
  = do { res <- thing_inside; return (res, emptyLHsBinds) }
  | otherwise
  = do	{ (res, lie) <- getLIE thing_inside
	; binds <- bindInstsOfLocalFuns lie [id]
	; return (res, binds) }
215
216
217
218

-------------------
unBoxPatBndrType  ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name))
unBoxWildCardType ty      = unBoxArgType ty (ptext SLIT("A wild-card pattern"))
219
unBoxViewPatType  ty pat  = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat)
220
221
222
223
224
225
226
227
228
229
230
231
232

unBoxArgType :: BoxyType -> SDoc -> TcM TcType
-- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind; 
-- that is, it can't be an unboxed tuple.  For example, 
--	case (f x) of r -> ...
-- should fail if 'f' returns an unboxed tuple.
unBoxArgType ty pp_this
  = do	{ ty' <- unBox ty	-- Returns a zonked type

	-- Neither conditional is strictly necesssary (the unify alone will do)
	-- but they improve error messages, and allocate fewer tyvars
	; if isUnboxedTupleType ty' then
		failWithTc msg
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
233
	  else if isSubArgTypeKind (typeKind ty') then
234
235
236
237
238
239
240
		return ty'
	  else do 	-- OpenTypeKind, so constrain it
	{ ty2 <- newFlexiTyVarTy argTypeKind
	; unifyType ty' ty2
	; return ty' }}
  where
    msg = pp_this <+> ptext SLIT("cannot be bound to an unboxed tuple")
241
242
\end{code}

243

244
245
%************************************************************************
%*									*
246
		The main worker functions
247
248
249
%*									*
%************************************************************************

250
251
Note [Nesting]
~~~~~~~~~~~~~~
lennart@augustsson.net's avatar
lennart@augustsson.net committed
252
tcPat takes a "thing inside" over which the pattern scopes.  This is partly
253
254
255
256
257
258
259
260
so that tcPat can extend the environment for the thing_inside, but also 
so that constraints arising in the thing_inside can be discharged by the
pattern.

This does not work so well for the ErrCtxt carried by the monad: we don't
want the error-context for the pattern to scope over the RHS. 
Hence the getErrCtxt/setErrCtxt stuff in tc_lpats.

261
\begin{code}
262
--------------------
263
264
265
266
267
268
269
270
type Checker inp out =  forall r.
			  inp
		       -> PatState
		       -> (PatState -> TcM r)
		       -> TcM (out, [TcTyVar], r)

tcMultiple :: Checker inp out -> Checker [inp] [out]
tcMultiple tc_pat args pstate thing_inside
271
  = do	{ err_ctxt <- getErrCtxt
272
	; let loop pstate []
273
274
275
		= do { res <- thing_inside pstate
		     ; return ([], [], res) }

276
	      loop pstate (arg:args)
277
		= do { (p', p_tvs, (ps', ps_tvs, res)) 
278
				<- tc_pat arg pstate $ \ pstate' ->
279
				   setErrCtxt err_ctxt $
280
				   loop pstate' args
281
282
283
284
285
		-- setErrCtxt: restore context before doing the next pattern
		-- See note [Nesting] above
				
		     ; return (p':ps', p_tvs ++ ps_tvs, res) }

286
	; loop pstate args }
287
288

--------------------
289
290
291
292
293
294
295
296
297
298
299
300
tc_lpat_pr :: (LPat Name, BoxySigmaType)
	   -> PatState
	   -> (PatState -> TcM a)
	   -> TcM (LPat TcId, [TcTyVar], a)
tc_lpat_pr (pat, ty) = tc_lpat pat ty

tc_lpat :: LPat Name 
	-> BoxySigmaType
	-> PatState
	-> (PatState -> TcM a)
	-> TcM (LPat TcId, [TcTyVar], a)
tc_lpat (L span pat) pat_ty pstate thing_inside
301
302
  = setSrcSpan span		  $
    maybeAddErrCtxt (patCtxt pat) $
303
304
    do	{ (pat', tvs, res) <- tc_pat pstate pat pat_ty thing_inside
	; return (L span pat', tvs, res) }
305
306
307

--------------------
tc_pat	:: PatState
308
309
310
311
312
313
        -> Pat Name 
        -> BoxySigmaType	-- Fully refined result type
        -> (PatState -> TcM a)	-- Thing inside
        -> TcM (Pat TcId, 	-- Translated pattern
                [TcTyVar], 	-- Existential binders
                a)		-- Result of thing inside
314

315
316
tc_pat pstate (VarPat name) pat_ty thing_inside
  = do	{ id <- tcPatBndr pstate name pat_ty
317
318
319
	; (res, binds) <- bindInstsOfPatId id $
			  tcExtendIdEnv1 name id $
			  (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
320
			   >> thing_inside pstate)
321
322
323
324
	; let pat' | isEmptyLHsBinds binds = VarPat id
		   | otherwise		   = VarPatOut id binds
	; return (pat', [], res) }

325
tc_pat pstate (ParPat pat) pat_ty thing_inside
326
  = do	{ (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
327
328
	; return (ParPat pat', tvs, res) }

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
329
tc_pat pstate (BangPat pat) pat_ty thing_inside
330
  = do	{ (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
331
332
	; return (BangPat pat', tvs, res) }

333
-- There's a wrinkle with irrefutable patterns, namely that we
334
335
336
337
338
339
340
341
342
-- must not propagate type refinement from them.  For example
--	data T a where { T1 :: Int -> T Int; ... }
--	f :: T a -> Int -> a
--	f ~(T1 i) y = y
-- It's obviously not sound to refine a to Int in the right
-- hand side, because the arugment might not match T1 at all!
--
-- Nor should a lazy pattern bind any existential type variables
-- because they won't be in scope when we do the desugaring
343
344
345
346
347
348
349
350
351
352
353
354
--
-- Note [Hopping the LIE in lazy patterns]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In a lazy pattern, we must *not* discharge constraints from the RHS
-- from dictionaries bound in the pattern.  E.g.
--	f ~(C x) = 3
-- We can't discharge the Num constraint from dictionaries bound by
-- the pattern C!  
--
-- So we have to make the constraints from thing_inside "hop around" 
-- the pattern.  Hence the getLLE and extendLIEs later.

355
tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
356
357
358
359
360
361
362
  = do	{ (pat', pat_tvs, (res,lie)) 
		<- tc_lpat pat pat_ty pstate $ \ _ ->
		   getLIE (thing_inside pstate)
		-- Ignore refined pstate', revert to pstate
	; extendLIEs lie
	-- getLIE/extendLIEs: see Note [Hopping the LIE in lazy patterns]

363
	-- Check no existentials
364
365
	; if (null pat_tvs) then return ()
	  else lazyPatErr lpat pat_tvs
366
367
368
369
370

	-- Check that the pattern has a lifted type
	; pat_tv <- newBoxyTyVar liftedTypeKind
	; boxyUnify pat_ty (mkTyVarTy pat_tv)

371
372
	; return (LazyPat pat', [], res) }

373
374
375
tc_pat _ p@(QuasiQuotePat _) _ _
  = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p)

376
tc_pat pstate (WildPat _) pat_ty thing_inside
377
  = do	{ pat_ty' <- unBoxWildCardType pat_ty	-- Make sure it's filled in with monotypes
378
	; res <- thing_inside pstate
379
380
	; return (WildPat pat_ty', [], res) }

381
382
tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside
  = do	{ bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
383
	; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
384
			      tc_lpat pat (idType bndr_id) pstate thing_inside
385
386
387
388
389
390
391
392
393
	    -- NB: if we do inference on:
	    --		\ (y@(x::forall a. a->a)) = e
	    -- we'll fail.  The as-pattern infers a monotype for 'y', which then
	    -- fails to unify with the polymorphic type for 'x'.  This could 
	    -- perhaps be fixed, but only with a bit more work.
	    --
	    -- If you fix it, don't forget the bindInstsOfPatIds!
	; return (AsPat (L nm_loc bndr_id) pat', tvs, res) }

394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside 
  = do	{ -- morally, expr must have type
         -- `forall a1...aN. OPT' -> B` 
         -- where overall_pat_ty is an instance of OPT'.
         -- Here, we infer a rho type for it,
         -- which replaces the leading foralls and constraints
         -- with fresh unification variables.
         (expr',expr'_inferred) <- tcInferRho expr
         -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty`
       ; let expr'_expected = \ pat_ty -> (mkFunTy overall_pat_ty pat_ty)
         -- tcSubExp: expected first, offered second
         -- returns coercion
         -- 
         -- NOTE: this forces pat_ty to be a monotype (because we use a unification 
         -- variable to find it).  this means that in an example like
         -- (view -> f)    where view :: _ -> forall b. b
         -- we will only be able to use view at one instantation in the
         -- rest of the view
412
413
414
	; (expr_coerc, pat_ty) <- tcInfer $ \ pat_ty -> 
		tcSubExp ViewPatOrigin (expr'_expected pat_ty) expr'_inferred

415
416
417
418
419
420
421
         -- pattern must have pat_ty
       ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
         -- this should get zonked later on, but we unBox it here
         -- so that we do the same checks as above
	; annotation_ty <- unBoxViewPatType overall_pat_ty orig        
	; return (ViewPat (mkLHsWrap expr_coerc expr') pat' annotation_ty, tvs, res) }

422
423
424
425
426
-- Type signatures in patterns
-- See Note [Pattern coercions] below
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
  = do	{ (inner_ty, tv_binds) <- tcPatSig (patSigCtxt pstate) sig_ty pat_ty
	; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
427
			      tc_lpat pat inner_ty pstate thing_inside
428
	; return (SigPatOut pat' inner_ty, tvs, res) }
429

430
tc_pat pstate pat@(TypePat ty) pat_ty thing_inside
431
  = failWithTc (badTypePat pat)
432

433
434
------------------------
-- Lists, tuples, arrays
435
tc_pat pstate (ListPat pats _) pat_ty thing_inside
436
  = do	{ (elt_ty, coi) <- boxySplitListTy pat_ty
437
        ; let scoi = mkSymCoI coi
438
439
	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
					 	pats pstate thing_inside
440
441
 	; return (mkCoPatCoI scoi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) 
        }
442
443

tc_pat pstate (PArrPat pats _) pat_ty thing_inside
444
  = do	{ (elt_ty, coi) <- boxySplitPArrTy pat_ty
445
        ; let scoi = mkSymCoI coi
446
447
	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
						pats pstate thing_inside 
448
	; when (null pats) (zapToMonotype pat_ty >> return ())  -- c.f. ExplicitPArr in TcExpr
449
450
	; return (mkCoPatCoI scoi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res)
        }
451

452
tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
453
454
  = do	{ let tc = tupleTyCon boxity (length pats)
        ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
455
        ; let scoi = mkSymCoI coi
456
457
	; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
					       pstate thing_inside
458
459
460
461
462

	-- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
	-- so that we can experiment with lazy tuple-matching.
	-- This is a pretty odd place to make the switch, but
	-- it was easy to do.
463
464
465
	; let pat_ty'          = mkTyConApp tc arg_tys
                                     -- pat_ty /= pat_ty iff coi /= IdCo
              unmangled_result = TuplePat pats' boxity pat_ty'
466
	      possibly_mangled_result
467
468
469
	        | opt_IrrefutableTuples && 
                  isBoxed boxity            = LazyPat (noLoc unmangled_result)
	        | otherwise		    = unmangled_result
470

471
 	; ASSERT( length arg_tys == length pats )      -- Syntactically enforced
472
	  return (mkCoPatCoI scoi possibly_mangled_result pat_ty, pats_tvs, res)
473
        }
474
475
476

------------------------
-- Data constructors
477
tc_pat pstate pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
478
479
  = do	{ data_con <- tcLookupDataCon con_name
	; let tycon = dataConTyCon data_con
480
	; tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside }
481
482
483

------------------------
-- Literal patterns
484
tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
485
486
487
  = do	{ let lit_ty = hsLitType simple_lit
	; coi <- boxyUnify lit_ty pat_ty
			-- coi is of kind: lit_ty ~ pat_ty
488
	; res <- thing_inside pstate
489
490
491
492
	; span <- getSrcSpanM
			-- pattern coercions have to
			-- be of kind: pat_ty ~ lit_ty
			-- hence, sym coi
493
	; return (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, 
494
                   [], res) }
495
496
497

------------------------
-- Overloaded patterns: n, and n+k
498
tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside
499
500
501
  = do	{ let orig = LiteralOrigin over_lit
	; lit'    <- tcOverloadedLit orig over_lit pat_ty
	; eq'     <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
502
503
	; mb_neg' <- case mb_neg of
			Nothing  -> return Nothing	-- Positive literal
504
505
			Just neg -> 	-- Negative literal
					-- The 'negate' is re-mappable syntax
506
 			    do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
507
			       ; return (Just neg') }
508
	; res <- thing_inside pstate
509
	; return (NPat lit' mb_neg' eq', [], res) }
510

511
512
tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
  = do	{ bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
513
 	; let pat_ty' = idType bndr_id
514
515
	      orig    = LiteralOrigin lit
	; lit' <- tcOverloadedLit orig lit pat_ty'
516

517
518
519
	-- The '>=' and '-' parts are re-mappable syntax
	; ge'    <- tcSyntaxOp orig ge    (mkFunTys [pat_ty', pat_ty'] boolTy)
	; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty')
520

521
522
	-- The Report says that n+k patterns must be in Integral
	-- We may not want this when using re-mappable syntax, though (ToDo?)
523
	; icls <- tcLookupClass integralClassName
524
	; instStupidTheta orig [mkClassPred icls [pat_ty']]	
525
    
526
	; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
527
	; return (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
528

529
tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut, VarPatOut
530
\end{code}
531

532

533
534
%************************************************************************
%*									*
535
536
	Most of the work for constructors is here
	(the rest is in the ConPatIn case of tc_pat)
537
538
%*									*
%************************************************************************
539

540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
[Pattern matching indexed data types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following declarations:

  data family Map k :: * -> *
  data instance Map (a, b) v = MapPair (Map a (Pair b v))

and a case expression

  case x :: Map (Int, c) w of MapPair m -> ...

As explained by [Wrappers for data instance tycons] in MkIds.lhs, the
worker/wrapper types for MapPair are

  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v

So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is
:R123Map, which means the straight use of boxySplitTyConApp would give a type
error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls
boxySplitTyConApp with the family tycon Map instead, which gives us the family
type list {(Int, c), w}.  To get the correct split for :R123Map, we need to
unify the family type list {(Int, c), w} with the instance types {(a, b), v}
(provided by tyConFamInst_maybe together with the family tycon).  This
unification yields the substitution [a -> Int, b -> c, v -> w], which gives us
the split arguments for the representation tycon :R123Map as {Int, c, w}

In other words, boxySplitTyConAppWithFamily implicitly takes the coercion 

  Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v}

moving between representation and family type into account.  To produce type
correct Core, this coercion needs to be used to case the type of the scrutinee
from the family to the representation type.  This is achieved by
unwrapFamInstScrutinee using a CoPat around the result pattern.

576
Now it might appear seem as if we could have used the previous GADT type
577
578
579
580
581
582
583
584
585
586
587
588
refinement infrastructure of refineAlt and friends instead of the explicit
unification and CoPat generation.  However, that would be wrong.  Why?  The
whole point of GADT refinement is that the refinement is local to the case
alternative.  In contrast, the substitution generated by the unification of
the family type list and instance types needs to be propagated to the outside.
Imagine that in the above example, the type of the scrutinee would have been
(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the
substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the
instantiation of x with (a, b) must be global; ie, it must be valid in *all*
alternatives of the case expression, whereas in the GADT case it might vary
between alternatives.

589
590
591
RIP GADT refinement: refinements have been replaced by the use of explicit
equality constraints that are used in conjunction with implication constraints
to express the local scope of GADT refinements.
592

593
\begin{code}
594
595
596
597
--	Running example:
-- MkT :: forall a b c. (a:=:[b]) => b -> c -> T a
-- 	 with scrutinee of type (T ty)

598
599
tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon 
	 -> BoxySigmaType	-- Type of the pattern
600
	 -> HsConPatDetails Name -> (PatState -> TcM a)
601
	 -> TcM (Pat TcId, [TcTyVar], a)
602
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
603
604
  = do	{ let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
                = dataConFullSig data_con
605
606
607
	      skol_info  = PatSkol data_con
	      origin     = SigOrigin skol_info
	      full_theta = eq_theta ++ dict_theta
608
609

	  -- Instantiate the constructor type variables [a->ty]
610
611
	  -- This may involve doing a family-instance coercion, and building a
	  -- wrapper 
612
	; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty
613
614
615
616
617
618
619
620
621
622
623
        ; let sym_coi = mkSymCoI coi  -- boxy split coercion oriented wrongly
	      pat_ty' = mkTyConApp tycon ctxt_res_tys
                                      -- pat_ty' /= pat_ty iff coi /= IdCo
              
              wrap_res_pat res_pat = mkCoPatCoI sym_coi uwScrut pat_ty
                where
                  uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys res_pat

        ; traceTc $ case sym_coi of
                      IdCo -> text "sym_coi:IdCo" 
                      ACo co -> text "sym_coi: ACoI" <+> ppr co
624
625
626
627

	  -- Add the stupid theta
	; addDataConStupidTheta data_con ctxt_res_tys

628
629
630
	; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs	
                     -- Get location from monad, not from ex_tvs

631
	; let tenv     = zipTopTvSubst (univ_tvs ++ ex_tvs)
632
				       (ctxt_res_tys ++ mkTyVarTys ex_tvs')
633
634
635
	      arg_tys' = substTys tenv arg_tys

	; if null ex_tvs && null eq_spec && null full_theta
636
637
	  then do { -- The common case; no class bindings etc 
                    -- (see Note [Arrows and patterns])
638
		    (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys' 
639
						    arg_pats pstate thing_inside
640
		  ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
641
642
643
644
			            	      pat_tvs = [], pat_dicts = [], 
                                              pat_binds = emptyLHsBinds,
					      pat_args = arg_pats', 
                                              pat_ty = pat_ty' }
645

646
647
		    ; return (wrap_res_pat res_pat, inner_tvs, res) }

648
649
	  else do   -- The general case, with existential, and local equality 
                    -- constraints
650
	{ checkTc (case pat_ctxt pstate of { ProcPat -> False; other -> True })
651
		  (existentialProcPat data_con)
652
653
654
655
656
657
658
659
660

          -- Need to test for rigidity if *any* constraints in theta as class
          -- constraints may have superclass equality constraints.  However,
          -- we don't want to check for rigidity if we got here only because
          -- ex_tvs was non-null.
--        ; unless (null theta') $
          -- FIXME: AT THE MOMENT WE CHEAT!  We only perform the rigidity test
          --   if we explicit or implicit (by a GADT def) have equality 
          --   constraints.
661
662
663
664
665
666
667
668
669
670
        ; let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
	      theta'   = substTheta tenv (eq_preds ++ full_theta)
                           -- order is *important* as we generate the list of
                           -- dictionary binders from theta'
	      no_equalities = not (any isEqPred theta')
	      pstate' | no_equalities = pstate
		      | otherwise     = pstate { pat_eqs = True }

	; unless no_equalities (checkTc (isRigidTy pat_ty)
                                        (nonRigidMatch data_con))
671

672
	; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
673
		tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
674

675
676
	; loc <- getInstLoc origin
	; dicts <- newDictBndrs loc theta'
677
	; dict_binds <- tcSimplifyCheckPat loc ex_tvs' dicts lie_req
678

679
        ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
680
			            pat_tvs = ex_tvs',
681
682
683
			            pat_dicts = map instToVar dicts, 
			            pat_binds = dict_binds,
			            pat_args = arg_pats', pat_ty = pat_ty' }
684
685
	; return (wrap_res_pat res_pat, ex_tvs' ++ inner_tvs, res)
	} }
686
  where
687
    -- Split against the family tycon if the pattern constructor 
688
    -- belongs to a family instance tycon.
689
    boxySplitTyConAppWithFamily tycon pat_ty =
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
690
      traceTc traceMsg >>
691
692
693
      case tyConFamInst_maybe tycon of
        Nothing                   -> boxySplitTyConApp tycon pat_ty
	Just (fam_tycon, instTys) -> 
694
	  do { (scrutinee_arg_tys, coi) <- boxySplitTyConApp fam_tycon pat_ty
695
696
	     ; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon)
	     ; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys
697
	     ; return (freshTvs, coi)
698
	     }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
699
700
701
702
703
704
      where
        traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+>
		         ppr tycon <+> ppr pat_ty
		       , text "  family instance:" <+> 
			 ppr (tyConFamInst_maybe tycon)
                       ]
705
706
707
708
709
710
711

    -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion
    -- pattern if the tycon is an instance of a family.
    --
    unwrapFamInstScrutinee :: TyCon -> [Type] -> Pat Id -> Pat Id
    unwrapFamInstScrutinee tycon args pat
      | Just co_con <- tyConFamilyCoercion_maybe tycon 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
712
713
--      , not (isNewTyCon tycon)       -- newtypes are explicitly unwrapped by
				     -- the desugarer
714
715
716
          -- NB: We can use CoPat directly, rather than mkCoPat, as we know the
          --	 coercion is not the identity; mkCoPat is inconvenient as it
          --	 wants a located pattern.
717
      = CoPat (WpCo $ mkTyConApp co_con args)       -- co fam ty to repr ty
718
719
720
721
722
723
	      (pat {pat_ty = mkTyConApp tycon args})    -- representation type
	      pat_ty					-- family inst type
      | otherwise
      = pat


724
tcConArgs :: DataCon -> [TcSigmaType]
725
	  -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
726

727
tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
728
729
  = do	{ checkTc (con_arity == no_of_args)	-- Check correct arity
		  (arityErr "Constructor" data_con con_arity no_of_args)
730
731
732
	; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
	; (arg_pats', tvs, res) <- tcMultiple tcConArg pats_w_tys
					      pstate thing_inside 
733
	; return (PrefixCon arg_pats', tvs, res) }
734
735
736
  where
    con_arity  = dataConSourceArity data_con
    no_of_args = length arg_pats
737

738
tcConArgs data_con arg_tys (InfixCon p1 p2) pstate thing_inside
739
740
  = do	{ checkTc (con_arity == 2)	-- Check correct arity
	 	  (arityErr "Constructor" data_con con_arity 2)
741
	; let [arg_ty1,arg_ty2] = arg_tys	-- This can't fail after the arity check
742
743
	; ([p1',p2'], tvs, res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
					      pstate thing_inside
744
	; return (InfixCon p1' p2', tvs, res) }
745
746
747
  where
    con_arity  = dataConSourceArity data_con

748
749
750
tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
  = pprPanic "tcConArgs" (ppr data_con)	-- InfixCon always has two arguments

751
tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
752
  = do	{ (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
753
	; return (RecCon (HsRecFields rpats' dd), tvs, res) }
754
  where
755
    tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
756
    tc_field (HsRecField field_lbl pat pun) pstate thing_inside
757
      = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
758
	   ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
759
	   ; return (HsRecField sel_id pat' pun, tvs, res) }
760

761
    find_field_ty :: FieldLabel -> TcM (Id, TcType)
762
763
    find_field_ty field_lbl
	= case [ty | (f,ty) <- field_tys, f == field_lbl] of
764
765
766
767
768
769
770
771
772

		-- No matching field; chances are this field label comes from some
		-- other record type (or maybe none).  As well as reporting an
		-- error we still want to typecheck the pattern, principally to
		-- make sure that all the variables it binds are put into the
		-- environment, else the type checker crashes later:
		--	f (R { foo = (a,b) }) = a+b
		-- If foo isn't one of R's fields, we don't want to crash when
		-- typechecking the "a+b".
773
	   [] -> do { addErrTc (badFieldCon data_con field_lbl)
774
		    ; bogus_ty <- newFlexiTyVarTy liftedTypeKind
775
		    ; return (error "Bogus selector Id", bogus_ty) }
776
777
778
779

		-- The normal case, when the field comes from the right constructor
	   (pat_ty : extras) -> 
		ASSERT( null extras )
780
		do { sel_id <- tcLookupField field_lbl
781
		   ; return (sel_id, pat_ty) }
782

783
    field_tys :: [(FieldLabel, TcType)]
784
785
786
787
    field_tys = zip (dataConFieldLabels data_con) arg_tys
	-- Don't use zipEqual! If the constructor isn't really a record, then
	-- dataConFieldLabels will be empty (and each field in the pattern
	-- will generate an error below).
788
789
790
791

tcConArg :: Checker (LPat Name, BoxySigmaType) (LPat Id)
tcConArg (arg_pat, arg_ty) pstate thing_inside
  = tc_lpat arg_pat arg_ty pstate thing_inside
792
793
\end{code}

794
\begin{code}
795
addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
796
797
-- Instantiate the "stupid theta" of the data con, and throw 
-- the constraints into the constraint set
798
addDataConStupidTheta data_con inst_tys
799
800
801
  | null stupid_theta = return ()
  | otherwise	      = instStupidTheta origin inst_theta
  where
802
803
804
    origin = OccurrenceOf (dataConName data_con)
	-- The origin should always report "occurrence of C"
	-- even when C occurs in a pattern
805
806
807
808
809
    stupid_theta = dataConStupidTheta data_con
    tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
    inst_theta = substTheta tenv stupid_theta
\end{code}

810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
Note [Arrows and patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~
(Oct 07) Arrow noation has the odd property that it involves "holes in the scope". 
For example:
  expr :: Arrow a => a () Int
  expr = proc (y,z) -> do
          x <- term -< y
          expr' -< x

Here the 'proc (y,z)' binding scopes over the arrow tails but not the
arrow body (e.g 'term').  As things stand (bogusly) all the
constraints from the proc body are gathered together, so constraints
from 'term' will be seen by the tcPat for (y,z).  But we must *not*
bind constraints from 'term' here, becuase the desugarer will not make
these bindings scope over 'term'.

The Right Thing is not to confuse these constraints together. But for
now the Easy Thing is to ensure that we do not have existential or
GADT constraints in a 'proc', and to short-cut the constraint
simplification for such vanilla patterns so that it binds no
constraints. Hence the 'fast path' in tcConPat; but it's also a good
plan for ordinary vanilla patterns to bypass the constraint
simplification step.

834

835
836
837
838
839
840
841
842
843
844
%************************************************************************
%*									*
		Overloaded literals
%*									*
%************************************************************************

In tcOverloadedLit we convert directly to an Int or Integer if we
know that's what we want.  This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).
845
846

\begin{code}
847
848
849
850
tcOverloadedLit :: InstOrigin
		 -> HsOverLit Name
		 -> BoxyRhoType
		 -> TcM (HsOverLit TcId)
851
tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty
852
853
854
855
856
857
858
  | not (fi `isHsVar` fromIntegerName)	-- Do not generate a LitInst for rebindable syntax.  
	-- Reason: If we do, tcSimplify will call lookupInst, which
	--	   will call tcSyntaxName, which does unification, 
	--	   which tcSimplify doesn't like
	-- ToDo: noLoc sadness
  = do	{ integer_ty <- tcMetaTy integerTyConName
	; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty)
859
	; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) }
860
861

  | Just expr <- shortCutIntLit i res_ty 
862
  = return (HsIntegral i expr res_ty)
863
864
865

  | otherwise
  = do 	{ expr <- newLitInst orig lit res_ty
866
	; return (HsIntegral i expr res_ty) }
867

868
tcOverloadedLit orig lit@(HsFractional r fr _) res_ty
869
870
871
872
873
874
875
  | not (fr `isHsVar` fromRationalName)	-- c.f. HsIntegral case
  = do	{ rat_ty <- tcMetaTy rationalTyConName
	; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty)
	 	-- Overloaded literals must have liftedTypeKind, because
	 	-- we're instantiating an overloaded function here,
	 	-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
		-- However this'll be picked up by tcSyntaxOp if necessary
876
	; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) }
877
878

  | Just expr <- shortCutFracLit r res_ty 
879
  = return (HsFractional r expr res_ty)
880
881
882

  | otherwise
  = do 	{ expr <- newLitInst orig lit res_ty
883
	; return (HsFractional r expr res_ty) }
884

885
tcOverloadedLit orig lit@(HsIsString s fr _) res_ty
886
887
888
  | not (fr `isHsVar` fromStringName)	-- c.f. HsIntegral case
  = do	{ str_ty <- tcMetaTy stringTyConName
	; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
889
	; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s))) res_ty) }
890
891

  | Just expr <- shortCutStringLit s res_ty 
892
  = return (HsIsString s expr res_ty)
893
894
895

  | otherwise
  = do 	{ expr <- newLitInst orig lit res_ty
896
	; return (HsIsString s expr res_ty) }
897

898
899
900
901
902
newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
newLitInst orig lit res_ty	-- Make a LitInst
  = do 	{ loc <- getInstLoc orig
	; res_tau <- zapToMonotype res_ty
	; new_uniq <- newUnique
903
	; let	lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
904
905
		lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit, 
				    tci_ty = res_tau, tci_loc = loc}
906
907
	; extendLIE lit_inst
	; return (HsVar (instToId lit_inst)) }
908
909
\end{code}

910

911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
%************************************************************************
%*									*
		Note [Pattern coercions]
%*									*
%************************************************************************

In principle, these program would be reasonable:
	
	f :: (forall a. a->a) -> Int
	f (x :: Int->Int) = x 3

	g :: (forall a. [a]) -> Bool
	g [] = True

In both cases, the function type signature restricts what arguments can be passed
in a call (to polymorphic ones).  The pattern type signature then instantiates this
type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we
generate the translated term
	f = \x' :: (forall a. a->a).  let x = x' Int in x 3

From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.
And it requires a significant amount of code to implement, becuase we need to decorate
the translated pattern with coercion functions (generated from the subsumption check 
by tcSub).  

So for now I'm just insisting on type *equality* in patterns.  No subsumption. 

Old notes about desugaring, at a time when pattern coercions were handled:

A SigPat is a type coercion and must be handled one at at time.  We can't
combine them unless the type of the pattern inside is identical, and we don't
bother to check for that.  For example:

	data T = T1 Int | T2 Bool
	f :: (forall a. a -> a) -> T -> t
	f (g::Int->Int)   (T1 i) = T1 (g i)
	f (g::Bool->Bool) (T2 b) = T2 (g b)

We desugar this as follows:

	f = \ g::(forall a. a->a) t::T ->
	    let gi = g Int
	    in case t of { T1 i -> T1 (gi i)
			   other ->
	    let	gb = g Bool
	    in case t of { T2 b -> T2 (gb b)
			   other -> fail }}

Note that we do not treat the first column of patterns as a
column of variables, because the coerced variables (gi, gb)
would be of different types.  So we get rather grotty code.
But I don't think this is a common case, and if it was we could
doubtless improve it.

Meanwhile, the strategy is:
	* treat each SigPat coercion (always non-identity coercions)
		as a separate block
	* deal with the stuff inside, and then wrap a binding round
		the result to bind the new variable (gi, gb, etc)

971

972
973
974
975
976
977
%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

978
\begin{code}
979
980
981
982
patCtxt :: Pat Name -> Maybe Message	-- Not all patterns are worth pushing a context
patCtxt (VarPat _)  = Nothing
patCtxt (ParPat _)  = Nothing
patCtxt (AsPat _ _) = Nothing
983
patCtxt pat 	    = Just (hang (ptext SLIT("In the pattern:")) 
984
			       4 (ppr pat))
985

986
987
-----------------------------------------------

988
existentialExplode pat
989
990
  = hang (vcat [text "My brain just exploded.",
	        text "I can't handle pattern bindings for existentially-quantified constructors.",
991
	        text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
992
		text "In the binding group for"])
993
	4 (ppr pat)
994

995
sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env 
996
997
998
999
1000
1001
  = do	{ pat_tys' <- mapM zonkTcType pat_tys
	; body_ty' <- zonkTcType body_ty
	; let (env1,  tidy_tys)    = tidyOpenTypes tidy_env (map idType show_ids)
	      (env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys'
	      (env3, tidy_body_ty) = tidyOpenType  env2 body_ty'
	; return (env3,
1002
1003
1004
		 sep [ptext SLIT("When checking an existential match that binds"),
		      nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
		      ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
1005
		      ptext SLIT("The body has type:") <+> ppr tidy_body_ty
1006
		]) }
1007
  where
1008
    bound_ids = collectPatsBinders pats
1009
    show_ids = filter is_interesting bound_ids
1010
    is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs
1011
1012
1013
1014

    ppr_id id ty = ppr id <+> dcolon <+> ppr ty
	-- Don't zonk the types so we get the separate, un-unified versions

1015
badFieldCon :: DataCon -> Name -> SDoc
1016
badFieldCon con field
1017
  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
1018
	  ptext SLIT("does not have field"), quotes (ppr field)]
1019
1020
1021

polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
1022
  = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
1023
       2 (ppr sig_ty)
1024
1025

badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
1026

1027
1028
1029
1030
1031
existentialProcPat :: DataCon -> SDoc
existentialProcPat con
  = hang (ptext SLIT("Illegal constructor") <+> quotes (ppr con) <+> ptext SLIT("in a 'proc' pattern"))
       2 (ptext SLIT("Proc patterns cannot use existentials or GADTs"))

1032
1033
lazyPatErr pat tvs
  = failWithTc $
1034
    hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))
1035
       2 (vcat (map pprSkolTvBinding tvs))
1036

1037
1038
nonRigidMatch con
  =  hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
1039
	2 (ptext SLIT("Solution: add a type signature"))
1040

1041
nonRigidResult res_ty
1042
1043
1044
1045
1046
1047
  = do	{ env0 <- tcInitTidyEnv
	; let (env1, res_ty') = tidyOpenType env0 res_ty
	      msg = hang (ptext SLIT("GADT pattern match with non-rigid result type")
				<+> quotes (ppr res_ty'))
		  	 2 (ptext SLIT("Solution: add a type signature"))
	; failWithTcM (env1, msg) }
1048

1049
1050
1051
inaccessibleAlt msg
  = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
\end{code}