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:"))