TcPat.lhs 41.5 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
module TcPat ( tcLetPat, tcPat, tcPats, tcOverloadedLit,
10
	       addDataConStupidTheta, badFieldCon, polyPatSig ) where
11

12
#include "HsVersions.h"
13

14
import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRho)
15
16
17

import HsSyn
import TcHsSyn
18
import TcRnMonad
19
20
21
22
23
24
25
26
27
import Inst
import Id
import Var
import CoreFVs
import Name
import TcSimplify
import TcEnv
import TcMType
import TcType
Ian Lynagh's avatar
Ian Lynagh committed
28
import VarEnv
29
30
31
32
import VarSet
import TcUnify
import TcHsType
import TysWiredIn
33
import Coercion
34
35
36
37
38
import StaticFlags
import TyCon
import DataCon
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
39
import DynFlags
40
41
42
import SrcLoc
import ErrUtils
import Util
sof's avatar
sof committed
43
import Outputable
44
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
45
import Control.Monad
46
\end{code}
47

48
49
50

%************************************************************************
%*									*
51
		External interface
52
53
54
55
%*									*
%************************************************************************

\begin{code}
56
57
tcLetPat :: (Name -> Maybe TcRhoType)
      	 -> LPat Name -> BoxySigmaType 
58
     	 -> TcM a
59
60
      	 -> TcM (LPat TcId, a)
tcLetPat sig_fn pat pat_ty thing_inside
61
  = do	{ let init_state = PS { pat_ctxt = LetPat sig_fn,
62
				pat_eqs  = False }
63
64
	; (pat', ex_tvs, res) <- tc_lpat pat pat_ty init_state 
                                   (\ _ -> thing_inside)
65
66
67
68
69
70
71

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

	; return (pat', res) }

-----------------
72
73
74
75
76
77
tcPats :: HsMatchContext Name
       -> [LPat Name]		 -- Patterns,
       -> [BoxySigmaType]	 --   and their types
       -> BoxyRhoType 		 -- Result type,
       -> (BoxyRhoType -> TcM a) --   and the checker for the body
       -> TcM ([LPat TcId], a)
78
79
80
81
82
83
84
85
86

-- 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
87
88
--   3. Check the body
--   4. Check that no existentials escape
89

90
91
tcPats ctxt pats tys res_ty thing_inside
  = tc_lam_pats (APat ctxt) (zipEqual "tcLamPats" pats tys)
92
	        res_ty thing_inside
93

94
95
96
97
98
99
100
tcPat :: HsMatchContext Name
      -> LPat Name -> BoxySigmaType 
      -> BoxyRhoType             -- Result type
      -> (BoxyRhoType -> TcM a)  -- Checker for body, given
                                 -- its result type
      -> TcM (LPat TcId, a)
tcPat ctxt = tc_lam_pat (APat ctxt)
101

Ian Lynagh's avatar
Ian Lynagh committed
102
103
tc_lam_pat :: PatCtxt -> LPat Name -> BoxySigmaType -> BoxyRhoType
           -> (BoxyRhoType -> TcM a) -> TcM (LPat TcId, a)
104
105
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
106
	; return (pat', thing) }
107

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

117
118
119
	; (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))
120
				     then nonRigidResult ctxt res_ty
121
	     			     else thing_inside res_ty }
122

123
124
	; let tys = map snd pat_ty_prs
	; tcCheckExistentialPat pats' ex_tvs tys res_ty
125

126
	; return (pats', res) }
127
128
129


-----------------
130
tcCheckExistentialPat :: [LPat TcId]		-- Patterns (just for error message)
131
132
133
134
135
136
137
138
139
140
141
		      -> [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).

Ian Lynagh's avatar
Ian Lynagh committed
142
tcCheckExistentialPat _ [] _ _
143
144
  = return ()	-- Short cut for case when there are no existentials

145
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
146
  = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty)	$
147
148
149
150
    checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs

data PatState = PS {
	pat_ctxt :: PatCtxt,
151
152
153
	pat_eqs  :: Bool        -- <=> there are any equational constraints 
				-- Used at the end to say whether the result
				-- type must be rigid
154
155
156
  }

data PatCtxt 
157
  = APat (HsMatchContext Name)
158
159
  | LetPat (Name -> Maybe TcRhoType)	-- Used for let(rec) bindings

160
161
162
163
notProcPat :: PatCtxt -> Bool
notProcPat (APat ProcExpr) = False
notProcPat _	  	   = True

164
165
patSigCtxt :: PatState -> UserTypeCtxt
patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
Ian Lynagh's avatar
Ian Lynagh committed
166
patSigCtxt _                            = LamPatSigCtxt
167
168
169
\end{code}


170

171
172
%************************************************************************
%*									*
173
		Binders
174
175
176
%*									*
%************************************************************************

177
\begin{code}
178
179
180
181
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
182
	; _ <- boxyUnify mono_ty pat_ty
183
	; return (Id.mkLocalId mono_name mono_ty) }
184
185

  | otherwise
186
  = do	{ pat_ty' <- unBoxPatBndrType pat_ty bndr_name
187
	; mono_name <- newLocalName bndr_name
188
	; return (Id.mkLocalId mono_name pat_ty') }
189

190
191
192
193
194
195
196
197
198
199
200
201
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') }

202
203
204
205
206
207
208
209
210
211

-------------------
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) }
212
213

-------------------
Ian Lynagh's avatar
Ian Lynagh committed
214
unBoxPatBndrType :: BoxyType -> Name -> TcM TcType
215
unBoxPatBndrType  ty name = unBoxArgType ty (ptext (sLit "The variable") <+> quotes (ppr name))
Ian Lynagh's avatar
Ian Lynagh committed
216
217

unBoxWildCardType :: BoxyType -> TcM TcType
218
unBoxWildCardType ty      = unBoxArgType ty (ptext (sLit "A wild-card pattern"))
Ian Lynagh's avatar
Ian Lynagh committed
219
220

unBoxViewPatType :: BoxyType -> Pat Name -> TcM TcType
221
unBoxViewPatType  ty pat  = unBoxArgType ty (ptext (sLit "The view pattern") <+> ppr pat)
222
223
224
225
226
227
228
229
230
231
232
233
234

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
235
	  else if isSubArgTypeKind (typeKind ty') then
236
237
238
		return ty'
	  else do 	-- OpenTypeKind, so constrain it
	{ ty2 <- newFlexiTyVarTy argTypeKind
239
	; _ <- unifyType ty' ty2
240
241
	; return ty' }}
  where
242
    msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple")
243
244
\end{code}

245

246
247
%************************************************************************
%*									*
248
		The main worker functions
249
250
251
%*									*
%************************************************************************

252
253
Note [Nesting]
~~~~~~~~~~~~~~
lennart@augustsson.net's avatar
lennart@augustsson.net committed
254
tcPat takes a "thing inside" over which the pattern scopes.  This is partly
255
256
257
258
259
260
261
262
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.

263
\begin{code}
264
--------------------
265
266
267
268
269
270
271
272
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
273
  = do	{ err_ctxt <- getErrCtxt
274
	; let loop pstate []
275
276
277
		= do { res <- thing_inside pstate
		     ; return ([], [], res) }

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

288
	; loop pstate args }
289
290

--------------------
291
292
293
294
295
296
297
298
299
300
301
302
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
303
304
  = setSrcSpan span		  $
    maybeAddErrCtxt (patCtxt pat) $
305
306
    do	{ (pat', tvs, res) <- tc_pat pstate pat pat_ty thing_inside
	; return (L span pat', tvs, res) }
307
308
309

--------------------
tc_pat	:: PatState
310
311
312
313
314
315
        -> 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
316

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

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

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

335
-- There's a wrinkle with irrefutable patterns, namely that we
336
337
338
339
340
341
342
343
344
-- 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
345
346
347
348
349
350
351
352
353
354
355
356
--
-- 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.

357
tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
358
359
360
361
362
363
364
  = 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]

365
	-- Check no existentials
Ian Lynagh's avatar
Ian Lynagh committed
366
	; unless (null pat_tvs) $ lazyPatErr lpat pat_tvs
367

368
369
370
371
	-- Check there are no unlifted types under the lazy pattern
	; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $
               lazyUnliftedPatErr lpat

372
373
	-- Check that the pattern has a lifted type
	; pat_tv <- newBoxyTyVar liftedTypeKind
374
	; _ <- boxyUnify pat_ty (mkTyVarTy pat_tv)
375

376
377
	; return (LazyPat pat', [], res) }

378
379
380
tc_pat _ p@(QuasiQuotePat _) _ _
  = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p)

381
tc_pat pstate (WildPat _) pat_ty thing_inside
382
  = do	{ pat_ty' <- unBoxWildCardType pat_ty	-- Make sure it's filled in with monotypes
383
	; res <- thing_inside pstate
384
385
	; return (WildPat pat_ty', [], res) }

386
387
tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside
  = do	{ bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
388
	; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
389
			      tc_lpat pat (idType bndr_id) pstate thing_inside
390
391
392
393
394
395
396
397
398
	    -- 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) }

399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
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
417
418
419
	; (expr_coerc, pat_ty) <- tcInfer $ \ pat_ty -> 
		tcSubExp ViewPatOrigin (expr'_expected pat_ty) expr'_inferred

420
421
422
423
424
425
426
         -- 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) }

427
428
429
-- Type signatures in patterns
-- See Note [Pattern coercions] below
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
430
431
  = do	{ (inner_ty, tv_binds, coi) <- tcPatSig (patSigCtxt pstate) sig_ty 
                                                                    pat_ty
432
        ; unless (isIdentityCoI coi) $ 
433
            failWithTc (badSigPat pat_ty)
434
	; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
435
			      tc_lpat pat inner_ty pstate thing_inside
436
437
438
439
440
        ; return (SigPatOut pat' inner_ty, tvs, res) }

-- Use this when we add pattern coercions back in
--	  return (mkCoPatCoI (mkSymCoI coi) (SigPatOut pat' inner_ty) pat_ty
--                 , tvs, res) }
441

Ian Lynagh's avatar
Ian Lynagh committed
442
tc_pat _ pat@(TypePat _) _ _
443
  = failWithTc (badTypePat pat)
444

445
446
------------------------
-- Lists, tuples, arrays
447
tc_pat pstate (ListPat pats _) pat_ty thing_inside
448
  = do	{ (elt_ty, coi) <- boxySplitListTy pat_ty
449
        ; let scoi = mkSymCoI coi
450
451
	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
					 	pats pstate thing_inside
452
453
 	; return (mkCoPatCoI scoi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) 
        }
454
455

tc_pat pstate (PArrPat pats _) pat_ty thing_inside
456
  = do	{ (elt_ty, coi) <- boxySplitPArrTy pat_ty
457
        ; let scoi = mkSymCoI coi
458
459
	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
						pats pstate thing_inside 
460
	; when (null pats) (zapToMonotype pat_ty >> return ())  -- c.f. ExplicitPArr in TcExpr
461
462
	; return (mkCoPatCoI scoi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res)
        }
463

464
tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
465
466
  = do	{ let tc = tupleTyCon boxity (length pats)
        ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
467
        ; let scoi = mkSymCoI coi
468
469
	; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
					       pstate thing_inside
470
471
472
473
474

	-- 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.
475
476
477
	; let pat_ty'          = mkTyConApp tc arg_tys
                                     -- pat_ty /= pat_ty iff coi /= IdCo
              unmangled_result = TuplePat pats' boxity pat_ty'
478
	      possibly_mangled_result
479
480
481
	        | opt_IrrefutableTuples && 
                  isBoxed boxity            = LazyPat (noLoc unmangled_result)
	        | otherwise		    = unmangled_result
482

483
 	; ASSERT( length arg_tys == length pats )      -- Syntactically enforced
484
	  return (mkCoPatCoI scoi possibly_mangled_result pat_ty, pats_tvs, res)
485
        }
486
487
488

------------------------
-- Data constructors
Ian Lynagh's avatar
Ian Lynagh committed
489
tc_pat pstate (ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
490
491
  = do	{ data_con <- tcLookupDataCon con_name
	; let tycon = dataConTyCon data_con
492
	; tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside }
493
494
495

------------------------
-- Literal patterns
496
tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
497
498
499
  = do	{ let lit_ty = hsLitType simple_lit
	; coi <- boxyUnify lit_ty pat_ty
			-- coi is of kind: lit_ty ~ pat_ty
500
	; res <- thing_inside pstate
501
502
503
			-- pattern coercions have to
			-- be of kind: pat_ty ~ lit_ty
			-- hence, sym coi
504
	; return (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, 
505
                   [], res) }
506
507
508

------------------------
-- Overloaded patterns: n, and n+k
Ian Lynagh's avatar
Ian Lynagh committed
509
tc_pat pstate (NPat over_lit mb_neg eq) pat_ty thing_inside
510
511
512
  = do	{ let orig = LiteralOrigin over_lit
	; lit'    <- tcOverloadedLit orig over_lit pat_ty
	; eq'     <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
513
514
	; mb_neg' <- case mb_neg of
			Nothing  -> return Nothing	-- Positive literal
515
516
			Just neg -> 	-- Negative literal
					-- The 'negate' is re-mappable syntax
517
 			    do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
518
			       ; return (Just neg') }
519
	; res <- thing_inside pstate
520
	; return (NPat lit' mb_neg' eq', [], res) }
521

Ian Lynagh's avatar
Ian Lynagh committed
522
tc_pat pstate (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
523
  = do	{ bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
524
 	; let pat_ty' = idType bndr_id
525
526
	      orig    = LiteralOrigin lit
	; lit' <- tcOverloadedLit orig lit pat_ty'
527

528
529
530
	-- 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')
531

532
533
	-- The Report says that n+k patterns must be in Integral
	-- We may not want this when using re-mappable syntax, though (ToDo?)
534
	; icls <- tcLookupClass integralClassName
535
	; instStupidTheta orig [mkClassPred icls [pat_ty']]	
536
    
537
	; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
538
	; return (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
539

540
tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut, VarPatOut
541
\end{code}
542

543

544
545
%************************************************************************
%*									*
546
547
	Most of the work for constructors is here
	(the rest is in the ConPatIn case of tc_pat)
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
576
577
578
579
[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 

580
  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
581
582
583
584
585
586

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.

587
Now it might appear seem as if we could have used the previous GADT type
588
589
590
591
592
593
594
595
596
597
598
599
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.

600
601
602
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.
603

604
\begin{code}
605
--	Running example:
606
-- MkT :: forall a b c. (a~[b]) => b -> c -> T a
607
608
-- 	 with scrutinee of type (T ty)

609
610
tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon 
	 -> BoxySigmaType	-- Type of the pattern
611
	 -> HsConPatDetails Name -> (PatState -> TcM a)
612
	 -> TcM (Pat TcId, [TcTyVar], a)
613
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
614
615
  = do	{ let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
                = dataConFullSig data_con
616
617
618
	      skol_info  = PatSkol data_con
	      origin     = SigOrigin skol_info
	      full_theta = eq_theta ++ dict_theta
619
620

	  -- Instantiate the constructor type variables [a->ty]
621
622
	  -- This may involve doing a family-instance coercion, and building a
	  -- wrapper 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
623
624
	; (ctxt_res_tys, coi, unwrap_ty) <- boxySplitTyConAppWithFamily tycon 
                                                                        pat_ty
625
626
627
628
629
630
        ; 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
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
631
632
                  uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys
                                                   unwrap_ty res_pat
633

634
	  -- Add the stupid theta
635
	; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
636

637
638
639
	; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs	
                     -- Get location from monad, not from ex_tvs

640
	; let tenv     = zipTopTvSubst (univ_tvs ++ ex_tvs)
641
				       (ctxt_res_tys ++ mkTyVarTys ex_tvs')
642
643
644
	      arg_tys' = substTys tenv arg_tys

	; if null ex_tvs && null eq_spec && null full_theta
645
646
	  then do { -- The common case; no class bindings etc 
                    -- (see Note [Arrows and patterns])
647
		    (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys' 
648
						    arg_pats pstate thing_inside
649
		  ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
650
651
652
653
			            	      pat_tvs = [], pat_dicts = [], 
                                              pat_binds = emptyLHsBinds,
					      pat_args = arg_pats', 
                                              pat_ty = pat_ty' }
654

655
656
		    ; return (wrap_res_pat res_pat, inner_tvs, res) }

657
658
	  else do   -- The general case, with existential, and local equality 
                    -- constraints
659
	{ checkTc (notProcPat (pat_ctxt pstate))
660
		  (existentialProcPat data_con)
661
		  -- See Note [Arrows and patterns]
662
663
664
665
666
667
668

          -- 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
669
          --   if we explicitly or implicitly (by a GADT def) have equality 
670
          --   constraints.
671
672
673
674
675
676
677
678
        ; 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 }

679
680
681
682
683
684
        ; gadts_on <- doptM Opt_GADTs
	; checkTc (no_equalities || gadts_on)
	  	  (ptext (sLit "A pattern match on a GADT requires -XGADTs"))
		  -- Trac #2905 decided that a *pattern-match* of a GADT
		  -- should require the GADT language flag

685
686
	; unless no_equalities $ checkTc (isRigidTy pat_ty) $
                                 nonRigidMatch (pat_ctxt pstate) data_con
687

688
	; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
689
		tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
690

691
692
	; loc <- getInstLoc origin
	; dicts <- newDictBndrs loc theta'
693
	; dict_binds <- tcSimplifyCheckPat loc ex_tvs' dicts lie_req
694

695
        ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
696
			            pat_tvs = ex_tvs',
697
698
699
			            pat_dicts = map instToVar dicts, 
			            pat_binds = dict_binds,
			            pat_args = arg_pats', pat_ty = pat_ty' }
700
701
	; return (wrap_res_pat res_pat, ex_tvs' ++ inner_tvs, res)
	} }
702
  where
703
    -- Split against the family tycon if the pattern constructor 
704
    -- belongs to a family instance tycon.
705
    boxySplitTyConAppWithFamily tycon pat_ty =
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
706
      traceTc traceMsg >>
707
      case tyConFamInst_maybe tycon of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
708
709
710
711
        Nothing                   -> 
          do { (scrutinee_arg_tys, coi1) <- boxySplitTyConApp tycon pat_ty
             ; return (scrutinee_arg_tys, coi1, pat_ty)
             }
712
	Just (fam_tycon, instTys) -> 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
713
	  do { (scrutinee_arg_tys, coi1) <- boxySplitTyConApp fam_tycon pat_ty
714
	     ; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
715
716
             ; let instTys' = substTys subst instTys
	     ; cois <- boxyUnifyList instTys' scrutinee_arg_tys
717
             ; let coi = if isIdentityCoI coi1
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
718
719
720
721
722
723
724
725
726
727
                         then  -- pat_ty was splittable
                               -- => boxyUnifyList had real work to do
                           mkTyConAppCoI fam_tycon instTys' cois
                         else  -- pat_ty was not splittable
                               -- => scrutinee_arg_tys are fresh tvs and
                               --    boxyUnifyList just instantiated those
                           coi1
	     ; return (freshTvs, coi, mkTyConApp fam_tycon instTys')
                                      -- this is /= pat_ty 
                                      -- iff cois is non-trivial
728
	     }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
729
730
731
732
733
734
      where
        traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+>
		         ppr tycon <+> ppr pat_ty
		       , text "  family instance:" <+> 
			 ppr (tyConFamInst_maybe tycon)
                       ]
735
736
737
738

    -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion
    -- pattern if the tycon is an instance of a family.
    --
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
739
740
    unwrapFamInstScrutinee :: TyCon -> [Type] -> Type -> Pat Id -> Pat Id
    unwrapFamInstScrutinee tycon args unwrap_ty pat
741
      | Just co_con <- tyConFamilyCoercion_maybe tycon 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
742
743
--      , not (isNewTyCon tycon)       -- newtypes are explicitly unwrapped by
				     -- the desugarer
744
745
746
          -- 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.
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
747
      = CoPat (WpCast $ mkTyConApp co_con args)       -- co fam ty to repr ty
748
	      (pat {pat_ty = mkTyConApp tycon args})    -- representation type
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
749
	      unwrap_ty					-- family inst type
750
751
752
      | otherwise
      = pat

753
tcConArgs :: DataCon -> [TcSigmaType]
754
	  -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
755

756
tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
757
758
  = do	{ checkTc (con_arity == no_of_args)	-- Check correct arity
		  (arityErr "Constructor" data_con con_arity no_of_args)
759
760
761
	; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
	; (arg_pats', tvs, res) <- tcMultiple tcConArg pats_w_tys
					      pstate thing_inside 
762
	; return (PrefixCon arg_pats', tvs, res) }
763
764
765
  where
    con_arity  = dataConSourceArity data_con
    no_of_args = length arg_pats
766

767
tcConArgs data_con arg_tys (InfixCon p1 p2) pstate thing_inside
768
769
  = do	{ checkTc (con_arity == 2)	-- Check correct arity
	 	  (arityErr "Constructor" data_con con_arity 2)
770
	; let [arg_ty1,arg_ty2] = arg_tys	-- This can't fail after the arity check
771
772
	; ([p1',p2'], tvs, res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
					      pstate thing_inside
773
	; return (InfixCon p1' p2', tvs, res) }
774
775
776
  where
    con_arity  = dataConSourceArity data_con

777
tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
778
  = do	{ (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
779
	; return (RecCon (HsRecFields rpats' dd), tvs, res) }
780
  where
781
    tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
782
    tc_field (HsRecField field_lbl pat pun) pstate thing_inside
783
      = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
784
	   ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
785
	   ; return (HsRecField sel_id pat' pun, tvs, res) }
786

787
    find_field_ty :: FieldLabel -> TcM (Id, TcType)
788
789
    find_field_ty field_lbl
	= case [ty | (f,ty) <- field_tys, f == field_lbl] of
790
791
792
793
794
795
796
797
798

		-- 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".
799
	   [] -> do { addErrTc (badFieldCon data_con field_lbl)
800
		    ; bogus_ty <- newFlexiTyVarTy liftedTypeKind
801
		    ; return (error "Bogus selector Id", bogus_ty) }
802
803
804
805

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

809
    field_tys :: [(FieldLabel, TcType)]
810
811
812
813
    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).
814
815
816
817

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

820
\begin{code}
821
addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
822
823
-- Instantiate the "stupid theta" of the data con, and throw 
-- the constraints into the constraint set
824
addDataConStupidTheta data_con inst_tys
825
826
827
  | null stupid_theta = return ()
  | otherwise	      = instStupidTheta origin inst_theta
  where
828
829
830
    origin = OccurrenceOf (dataConName data_con)
	-- The origin should always report "occurrence of C"
	-- even when C occurs in a pattern
831
    stupid_theta = dataConStupidTheta data_con
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
832
833
834
    tenv = mkTopTvSubst (dataConUnivTyVars data_con `zip` inst_tys)
    	 -- NB: inst_tys can be longer than the univ tyvars
	 --     because the constructor might have existentials
835
836
837
    inst_theta = substTheta tenv stupid_theta
\end{code}

838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
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.

862

863
864
865
866
867
868
869
870
871
872
%************************************************************************
%*									*
		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).
873
874

\begin{code}
875
876
877
878
tcOverloadedLit :: InstOrigin
		 -> HsOverLit Name
		 -> BoxyRhoType
		 -> TcM (HsOverLit TcId)
879
880
881
882
tcOverloadedLit orig lit@(OverLit { ol_val = val, ol_rebindable = rebindable
				  , ol_witness = meth_name }) res_ty
  | rebindable
	-- Do not generate a LitInst for rebindable syntax.  
883
884
885
886
	-- Reason: If we do, tcSimplify will call lookupInst, which
	--	   will call tcSyntaxName, which does unification, 
	--	   which tcSimplify doesn't like
	-- ToDo: noLoc sadness
887
888
889
  = do	{ hs_lit <- mkOverLit val
	; let lit_ty = hsLitType hs_lit
	; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
890
891
892
893
	 	-- 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
894
895
	; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
	; return (lit { ol_witness = witness, ol_type = res_ty }) }
896

897
898
  | Just expr <- shortCutLit val res_ty 
  = return (lit { ol_witness = expr, ol_type = res_ty })
899
900
901
902
903

  | otherwise
  = do 	{ loc <- getInstLoc orig
	; res_tau <- zapToMonotype res_ty
	; new_uniq <- newUnique
904
	; let	lit_nm   = mkSystemVarName new_uniq (fsLit "lit")
905
906
		lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit, 
				    tci_ty = res_tau, tci_loc = loc}
907
		witness = HsVar (instToId lit_inst)
908
	; extendLIE lit_inst
909
	; return (lit { ol_witness = witness, ol_type = res_ty }) }
910
911
\end{code}

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
971
972
%************************************************************************
%*									*
		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)

973

974
975
976
977
978
979
%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

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

988
989
-----------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
990
existentialExplode :: LPat Name -> SDoc
991
existentialExplode pat
992
  = hang (vcat [text "My brain just exploded.",
993
	        text "I can't handle pattern bindings for existential or GADT data constructors.",
994
	        text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
995
		text "In the binding group for"])
996
	4 (ppr pat)
997

Ian Lynagh's avatar
Ian Lynagh committed
998
999
sigPatCtxt :: [LPat Var] -> [Var] -> [TcType] -> TcType -> TidyEnv
           -> TcM (TidyEnv, SDoc)
1000
sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env