compiler/typecheck/TcPat.lhs

   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 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
  17                addDataConStupidTheta, badFieldCon, polyPatSig ) where
  18
  19 #include "HsVersions.h"
  20
  21 import {-# SOURCE #-}   TcExpr( tcSyntaxOp )
  22
  23 import HsSyn
  24 import TcHsSyn
  25 import TcRnMonad
  26 import Inst
  27 import Id
  28 import Var
  29 import CoreFVs
  30 import Name
  31 import TcSimplify
  32 import TcEnv
  33 import TcMType
  34 import TcType
  35 import VarSet
  36 import TcUnify
  37 import TcHsType
  38 import TysWiredIn
  39 import TcGadt
  40 import Type
  41 import Coercion
  42 import StaticFlags
  43 import TyCon
  44 import DataCon
  45 import DynFlags
  46 import PrelNames
  47 import BasicTypes hiding (SuccessFlag(..))
  48 import SrcLoc
  49 import ErrUtils
  50 import Util
  51 import Maybes
  52 import Outputable
  53 import FastString
  54 \end{code}
  55
  56
  57 %************************************************************************
  58 %*                                                                      *
  59                 External interface
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 \begin{code}
  64 tcLetPat :: (Name -> Maybe TcRhoType)
  65          -> LPat Name -> BoxySigmaType
  66          -> TcM a
  67          -> TcM (LPat TcId, a)
  68 tcLetPat sig_fn pat pat_ty thing_inside
  69   = do  { let init_state = PS { pat_ctxt = LetPat sig_fn,
  70                                 pat_reft = emptyRefinement,
  71                                 pat_eqs  = False }
  72         ; (pat', ex_tvs, res) <- tc_lpat pat pat_ty init_state (\ _ -> thing_inside)
  73
  74         -- Don't know how to deal with pattern-bound existentials yet
  75         ; checkTc (null ex_tvs) (existentialExplode pat)
  76
  77         ; return (pat', res) }
  78
  79 -----------------
  80 tcLamPats :: [LPat Name]                                -- Patterns,
  81           -> [BoxySigmaType]                            --   and their types
  82           -> BoxyRhoType                                -- Result type,
  83           -> ((Refinement, BoxyRhoType) -> TcM a)       --   and the checker for the body
  84           -> TcM ([LPat TcId], a)
  85
  86 -- This is the externally-callable wrapper function
  87 -- Typecheck the patterns, extend the environment to bind the variables,
  88 -- do the thing inside, use any existentially-bound dictionaries to
  89 -- discharge parts of the returning LIE, and deal with pattern type
  90 -- signatures
  91
  92 --   1. Initialise the PatState
  93 --   2. Check the patterns
  94 --   3. Apply the refinement to the environment and result type
  95 --   4. Check the body
  96 --   5. Check that no existentials escape
  97
  98 tcLamPats pats tys res_ty thing_inside
  99   = tc_lam_pats (zipEqual "tcLamPats" pats tys)
 100                 (emptyRefinement, res_ty) thing_inside
 101
 102 tcLamPat :: LPat Name -> BoxySigmaType
 103          -> (Refinement,BoxyRhoType)            -- Result type
 104          -> ((Refinement,BoxyRhoType) -> TcM a) -- Checker for body, given its result type
 105          -> TcM (LPat TcId, a)
 106 tcLamPat pat pat_ty res_ty thing_inside
 107   = do  { ([pat'],thing) <- tc_lam_pats [(pat, pat_ty)] res_ty thing_inside
 108         ; return (pat', thing) }
 109
 110 -----------------
 111 tc_lam_pats :: [(LPat Name,BoxySigmaType)]
 112             -> (Refinement,BoxyRhoType)                 -- Result type
 113             -> ((Refinement,BoxyRhoType) -> TcM a)      -- Checker for body, given its result type
 114             -> TcM ([LPat TcId], a)
 115 tc_lam_pats pat_ty_prs (reft, res_ty) thing_inside
 116   =  do { let init_state = PS { pat_ctxt = LamPat, pat_reft = reft, pat_eqs = False }
 117
 118         ; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
 119                                   refineEnvironment (pat_reft pstate') (pat_eqs pstate') $
 120                                   if (pat_eqs pstate' && (not $ isRigidTy res_ty))
 121                                      then failWithTc (nonRigidResult res_ty)
 122                                      else thing_inside (pat_reft pstate', res_ty)
 123
 124         ; let tys = map snd pat_ty_prs
 125         ; tcCheckExistentialPat pats' ex_tvs tys res_ty
 126
 127         ; returnM (pats', res) }
 128
 129
 130 -----------------
 131 tcCheckExistentialPat :: [LPat TcId]            -- Patterns (just for error message)
 132                       -> [TcTyVar]              -- Existentially quantified tyvars bound by pattern
 133                       -> [BoxySigmaType]        -- Types of the patterns
 134                       -> BoxyRhoType            -- Type of the body of the match
 135                                                 -- Tyvars in either of these must not escape
 136                       -> TcM ()
 137 -- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
 138 -- For example, we must reject this program:
 139 --      data C = forall a. C (a -> Int)
 140 --      f (C g) x = g x
 141 -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
 142
 143 tcCheckExistentialPat pats [] pat_tys body_ty
 144   = return ()   -- Short cut for case when there are no existentials
 145
 146 tcCheckExistentialPat pats ex_tvs pat_tys body_ty
 147   = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty)        $
 148     checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
 149
 150 data PatState = PS {
 151         pat_ctxt :: PatCtxt,
 152         pat_reft :: Refinement, -- Binds rigid TcTyVars to their refinements
 153         pat_eqs  :: Bool        -- <=> there are GADT equational constraints
 154                                 --     for refinement
 155   }
 156
 157 data PatCtxt
 158   = LamPat
 159   | LetPat (Name -> Maybe TcRhoType)    -- Used for let(rec) bindings
 160
 161 patSigCtxt :: PatState -> UserTypeCtxt
 162 patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
 163 patSigCtxt other                        = LamPatSigCtxt
 164 \end{code}
 165
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170                 Binders
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 \begin{code}
 175 tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId
 176 tcPatBndr (PS { pat_ctxt = LamPat }) bndr_name pat_ty
 177   = do  { pat_ty' <- unBoxPatBndrType pat_ty bndr_name
 178                 -- We have an undecorated binder, so we do rule ABS1,
 179                 -- by unboxing the boxy type, forcing any un-filled-in
 180                 -- boxes to become monotypes
 181                 -- NB that pat_ty' can still be a polytype:
 182                 --      data T = MkT (forall a. a->a)
 183                 --      f t = case t of { MkT g -> ... }
 184                 -- Here, the 'g' must get type (forall a. a->a) from the
 185                 -- MkT context
 186         ; return (Id.mkLocalId bndr_name pat_ty') }
 187
 188 tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
 189   | Just mono_ty <- lookup_sig bndr_name
 190   = do  { mono_name <- newLocalName bndr_name
 191         ; boxyUnify mono_ty pat_ty
 192         ; return (Id.mkLocalId mono_name mono_ty) }
 193
 194   | otherwise
 195   = do  { pat_ty' <- unBoxPatBndrType pat_ty bndr_name
 196         ; mono_name <- newLocalName bndr_name
 197         ; return (Id.mkLocalId mono_name pat_ty') }
 198
 199
 200 -------------------
 201 bindInstsOfPatId :: TcId -> TcM a -> TcM (a, LHsBinds TcId)
 202 bindInstsOfPatId id thing_inside
 203   | not (isOverloadedTy (idType id))
 204   = do { res <- thing_inside; return (res, emptyLHsBinds) }
 205   | otherwise
 206   = do  { (res, lie) <- getLIE thing_inside
 207         ; binds <- bindInstsOfLocalFuns lie [id]
 208         ; return (res, binds) }
 209
 210 -------------------
 211 unBoxPatBndrType  ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name))
 212 unBoxWildCardType ty      = unBoxArgType ty (ptext SLIT("A wild-card pattern"))
 213
 214 unBoxArgType :: BoxyType -> SDoc -> TcM TcType
 215 -- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind;
 216 -- that is, it can't be an unboxed tuple.  For example,
 217 --      case (f x) of r -> ...
 218 -- should fail if 'f' returns an unboxed tuple.
 219 unBoxArgType ty pp_this
 220   = do  { ty' <- unBox ty       -- Returns a zonked type
 221
 222         -- Neither conditional is strictly necesssary (the unify alone will do)
 223         -- but they improve error messages, and allocate fewer tyvars
 224         ; if isUnboxedTupleType ty' then
 225                 failWithTc msg
 226           else if isSubArgTypeKind (typeKind ty') then
 227                 return ty'
 228           else do       -- OpenTypeKind, so constrain it
 229         { ty2 <- newFlexiTyVarTy argTypeKind
 230         ; unifyType ty' ty2
 231         ; return ty' }}
 232   where
 233     msg = pp_this <+> ptext SLIT("cannot be bound to an unboxed tuple")
 234 \end{code}
 235
 236
 237 %************************************************************************
 238 %*                                                                      *
 239                 The main worker functions
 240 %*                                                                      *
 241 %************************************************************************
 242
 243 Note [Nesting]
 244 ~~~~~~~~~~~~~~
 245 tcPat takes a "thing inside" over which the pattern scopes.  This is partly
 246 so that tcPat can extend the environment for the thing_inside, but also
 247 so that constraints arising in the thing_inside can be discharged by the
 248 pattern.
 249
 250 This does not work so well for the ErrCtxt carried by the monad: we don't
 251 want the error-context for the pattern to scope over the RHS.
 252 Hence the getErrCtxt/setErrCtxt stuff in tc_lpats.
 253
 254 \begin{code}
 255 --------------------
 256 type Checker inp out =  forall r.
 257                           inp
 258                        -> PatState
 259                        -> (PatState -> TcM r)
 260                        -> TcM (out, [TcTyVar], r)
 261
 262 tcMultiple :: Checker inp out -> Checker [inp] [out]
 263 tcMultiple tc_pat args pstate thing_inside
 264   = do  { err_ctxt <- getErrCtxt
 265         ; let loop pstate []
 266                 = do { res <- thing_inside pstate
 267                      ; return ([], [], res) }
 268
 269               loop pstate (arg:args)
 270                 = do { (p', p_tvs, (ps', ps_tvs, res))
 271                                 <- tc_pat arg pstate $ \ pstate' ->
 272                                    setErrCtxt err_ctxt $
 273                                    loop pstate' args
 274                 -- setErrCtxt: restore context before doing the next pattern
 275                 -- See note [Nesting] above
 276
 277                      ; return (p':ps', p_tvs ++ ps_tvs, res) }
 278
 279         ; loop pstate args }
 280
 281 --------------------
 282 tc_lpat_pr :: (LPat Name, BoxySigmaType)
 283            -> PatState
 284            -> (PatState -> TcM a)
 285            -> TcM (LPat TcId, [TcTyVar], a)
 286 tc_lpat_pr (pat, ty) = tc_lpat pat ty
 287
 288 tc_lpat :: LPat Name
 289         -> BoxySigmaType
 290         -> PatState
 291         -> (PatState -> TcM a)
 292         -> TcM (LPat TcId, [TcTyVar], a)
 293 tc_lpat (L span pat) pat_ty pstate thing_inside
 294   = setSrcSpan span               $
 295     maybeAddErrCtxt (patCtxt pat) $
 296     do  { let mb_reft = refineType (pat_reft pstate) pat_ty
 297               pat_ty' = case mb_reft of { Just (_, ty') -> ty'; Nothing -> pat_ty }
 298
 299                 -- Make sure the result type reflects the current refinement
 300                 -- We must do this here, so that it correctly ``sees'' all
 301                 -- the refinements to the left.  Example:
 302                 -- Suppose C :: forall a. T a -> a -> Foo
 303                 -- Pattern      C a p1 True
 304                 -- So p1 might refine 'a' to True, and the True
 305                 -- pattern had better see it.
 306
 307         ; (pat', tvs, res) <- tc_pat pstate pat pat_ty' thing_inside
 308         ; let final_pat = case mb_reft of
 309                                 Nothing     -> pat'
 310                                 Just (co,_) -> CoPat (WpCo co) pat' pat_ty
 311         ; return (L span final_pat, tvs, res) }
 312
 313 --------------------
 314 tc_pat  :: PatState
 315         -> Pat Name -> BoxySigmaType    -- Fully refined result type
 316         -> (PatState -> TcM a)  -- Thing inside
 317         -> TcM (Pat TcId,       -- Translated pattern
 318                 [TcTyVar],      -- Existential binders
 319                 a)              -- Result of thing inside
 320
 321 tc_pat pstate (VarPat name) pat_ty thing_inside
 322   = do  { id <- tcPatBndr pstate name pat_ty
 323         ; (res, binds) <- bindInstsOfPatId id $
 324                           tcExtendIdEnv1 name id $
 325                           (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
 326                            >> thing_inside pstate)
 327         ; let pat' | isEmptyLHsBinds binds = VarPat id
 328                    | otherwise             = VarPatOut id binds
 329         ; return (pat', [], res) }
 330
 331 tc_pat pstate (ParPat pat) pat_ty thing_inside
 332   = do  { (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
 333         ; return (ParPat pat', tvs, res) }
 334
 335 tc_pat pstate (BangPat pat) pat_ty thing_inside
 336   = do  { (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
 337         ; return (BangPat pat', tvs, res) }
 338
 339 -- There's a wrinkle with irrefutable patterns, namely that we
 340 -- must not propagate type refinement from them.  For example
 341 --      data T a where { T1 :: Int -> T Int; ... }
 342 --      f :: T a -> Int -> a
 343 --      f ~(T1 i) y = y
 344 -- It's obviously not sound to refine a to Int in the right
 345 -- hand side, because the arugment might not match T1 at all!
 346 --
 347 -- Nor should a lazy pattern bind any existential type variables
 348 -- because they won't be in scope when we do the desugaring
 349 --
 350 -- Note [Hopping the LIE in lazy patterns]
 351 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 352 -- In a lazy pattern, we must *not* discharge constraints from the RHS
 353 -- from dictionaries bound in the pattern.  E.g.
 354 --      f ~(C x) = 3
 355 -- We can't discharge the Num constraint from dictionaries bound by
 356 -- the pattern C!
 357 --
 358 -- So we have to make the constraints from thing_inside "hop around"
 359 -- the pattern.  Hence the getLLE and extendLIEs later.
 360
 361 tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
 362   = do  { (pat', pat_tvs, (res,lie))
 363                 <- tc_lpat pat pat_ty pstate $ \ _ ->
 364                    getLIE (thing_inside pstate)
 365                 -- Ignore refined pstate', revert to pstate
 366         ; extendLIEs lie
 367         -- getLIE/extendLIEs: see Note [Hopping the LIE in lazy patterns]
 368
 369         -- Check no existentials
 370         ; if (null pat_tvs) then return ()
 371           else lazyPatErr lpat pat_tvs
 372
 373         -- Check that the pattern has a lifted type
 374         ; pat_tv <- newBoxyTyVar liftedTypeKind
 375         ; boxyUnify pat_ty (mkTyVarTy pat_tv)
 376
 377         ; return (LazyPat pat', [], res) }
 378
 379 tc_pat pstate (WildPat _) pat_ty thing_inside
 380   = do  { pat_ty' <- unBoxWildCardType pat_ty   -- Make sure it's filled in with monotypes
 381         ; res <- thing_inside pstate
 382         ; return (WildPat pat_ty', [], res) }
 383
 384 tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside
 385   = do  { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
 386         ; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
 387                               tc_lpat pat (idType bndr_id) pstate thing_inside
 388             -- NB: if we do inference on:
 389             --          \ (y@(x::forall a. a->a)) = e
 390             -- we'll fail.  The as-pattern infers a monotype for 'y', which then
 391             -- fails to unify with the polymorphic type for 'x'.  This could
 392             -- perhaps be fixed, but only with a bit more work.
 393             --
 394             -- If you fix it, don't forget the bindInstsOfPatIds!
 395         ; return (AsPat (L nm_loc bndr_id) pat', tvs, res) }
 396
 397 -- Type signatures in patterns
 398 -- See Note [Pattern coercions] below
 399 tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
 400   = do  { (inner_ty, tv_binds) <- tcPatSig (patSigCtxt pstate) sig_ty pat_ty
 401         ; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
 402                               tc_lpat pat inner_ty pstate thing_inside
 403         ; return (SigPatOut pat' inner_ty, tvs, res) }
 404
 405 tc_pat pstate pat@(TypePat ty) pat_ty thing_inside
 406   = failWithTc (badTypePat pat)
 407
 408 ------------------------
 409 -- Lists, tuples, arrays
 410 tc_pat pstate (ListPat pats _) pat_ty thing_inside
 411   = do  { (elt_ty, coi) <- boxySplitListTy pat_ty
 412         ; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
 413                                                 pats pstate thing_inside
 414         ; return (mkCoPatCoI coi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) }
 415
 416 tc_pat pstate (PArrPat pats _) pat_ty thing_inside
 417   = do  { (elt_ty, coi) <- boxySplitPArrTy pat_ty
 418         ; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
 419                                                 pats pstate thing_inside
 420         ; ifM (null pats) (zapToMonotype pat_ty)  -- c.f. ExplicitPArr in TcExpr
 421         ; return (mkCoPatCoI coi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) }
 422
 423 tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
 424   = do  { let tc = tupleTyCon boxity (length pats)
 425         ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
 426         ; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
 427                                                pstate thing_inside
 428
 429         -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 430         -- so that we can experiment with lazy tuple-matching.
 431         -- This is a pretty odd place to make the switch, but
 432         -- it was easy to do.
 433         ; let pat_ty'          = mkTyConApp tc arg_tys
 434                                      -- pat_ty /= pat_ty iff coi /= IdCo
 435               unmangled_result = TuplePat pats' boxity pat_ty'
 436               possibly_mangled_result
 437                 | opt_IrrefutableTuples &&
 438                   isBoxed boxity            = LazyPat (noLoc unmangled_result)
 439                 | otherwise                 = unmangled_result
 440
 441         ; ASSERT( length arg_tys == length pats )      -- Syntactically enforced
 442           return (mkCoPatCoI coi possibly_mangled_result pat_ty, pats_tvs, res)
 443         }
 444
 445 ------------------------
 446 -- Data constructors
 447 tc_pat pstate pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
 448   = do  { data_con <- tcLookupDataCon con_name
 449         ; let tycon = dataConTyCon data_con
 450         ; tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside }
 451
 452 ------------------------
 453 -- Literal patterns
 454 tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
 455   = do  { let lit_ty = hsLitType simple_lit
 456         ; coi <- boxyUnify lit_ty pat_ty
 457                         -- coi is of kind: lit_ty ~ pat_ty
 458         ; res <- thing_inside pstate
 459         ; span <- getSrcSpanM
 460                         -- pattern coercions have to
 461                         -- be of kind: pat_ty ~ lit_ty
 462                         -- hence, sym coi
 463         ; returnM (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty,
 464                    [], res) }
 465
 466 ------------------------
 467 -- Overloaded patterns: n, and n+k
 468 tc_pat pstate pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside
 469   = do  { let orig = LiteralOrigin over_lit
 470         ; lit'    <- tcOverloadedLit orig over_lit pat_ty
 471         ; eq'     <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
 472         ; mb_neg' <- case mb_neg of
 473                         Nothing  -> return Nothing      -- Positive literal
 474                         Just neg ->     -- Negative literal
 475                                         -- The 'negate' is re-mappable syntax
 476                             do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
 477                                ; return (Just neg') }
 478         ; res <- thing_inside pstate
 479         ; returnM (NPat lit' mb_neg' eq' pat_ty, [], res) }
 480
 481 tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
 482   = do  { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
 483         ; let pat_ty' = idType bndr_id
 484               orig    = LiteralOrigin lit
 485         ; lit' <- tcOverloadedLit orig lit pat_ty'
 486
 487         -- The '>=' and '-' parts are re-mappable syntax
 488         ; ge'    <- tcSyntaxOp orig ge    (mkFunTys [pat_ty', pat_ty'] boolTy)
 489         ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty')
 490
 491         -- The Report says that n+k patterns must be in Integral
 492         -- We may not want this when using re-mappable syntax, though (ToDo?)
 493         ; icls <- tcLookupClass integralClassName
 494         ; instStupidTheta orig [mkClassPred icls [pat_ty']]
 495
 496         ; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
 497         ; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
 498
 499 tc_pat _ _other_pat _ _ = panic "tc_pat"        -- ConPatOut, SigPatOut, VarPatOut
 500 \end{code}
 501
 502
 503 %************************************************************************
 504 %*                                                                      *
 505         Most of the work for constructors is here
 506         (the rest is in the ConPatIn case of tc_pat)
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 [Pattern matching indexed data types]
 511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 512 Consider the following declarations:
 513
 514   data family Map k :: * -> *
 515   data instance Map (a, b) v = MapPair (Map a (Pair b v))
 516
 517 and a case expression
 518
 519   case x :: Map (Int, c) w of MapPair m -> ...
 520
 521 As explained by [Wrappers for data instance tycons] in MkIds.lhs, the
 522 worker/wrapper types for MapPair are
 523
 524   $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
 525   $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
 526
 527 So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is
 528 :R123Map, which means the straight use of boxySplitTyConApp would give a type
 529 error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls
 530 boxySplitTyConApp with the family tycon Map instead, which gives us the family
 531 type list {(Int, c), w}.  To get the correct split for :R123Map, we need to
 532 unify the family type list {(Int, c), w} with the instance types {(a, b), v}
 533 (provided by tyConFamInst_maybe together with the family tycon).  This
 534 unification yields the substitution [a -> Int, b -> c, v -> w], which gives us
 535 the split arguments for the representation tycon :R123Map as {Int, c, w}
 536
 537 In other words, boxySplitTyConAppWithFamily implicitly takes the coercion
 538
 539   Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v}
 540
 541 moving between representation and family type into account.  To produce type
 542 correct Core, this coercion needs to be used to case the type of the scrutinee
 543 from the family to the representation type.  This is achieved by
 544 unwrapFamInstScrutinee using a CoPat around the result pattern.
 545
 546 Now it might appear seem as if we could have used the existing GADT type
 547 refinement infrastructure of refineAlt and friends instead of the explicit
 548 unification and CoPat generation.  However, that would be wrong.  Why?  The
 549 whole point of GADT refinement is that the refinement is local to the case
 550 alternative.  In contrast, the substitution generated by the unification of
 551 the family type list and instance types needs to be propagated to the outside.
 552 Imagine that in the above example, the type of the scrutinee would have been
 553 (Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the
 554 substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the
 555 instantiation of x with (a, b) must be global; ie, it must be valid in *all*
 556 alternatives of the case expression, whereas in the GADT case it might vary
 557 between alternatives.
 558
 559 In fact, if we have a data instance declaration defining a GADT, eq_spec will
 560 be non-empty and we will get a mixture of global instantiations and local
 561 refinement from a single match.  This neatly reflects that, as soon as we
 562 have constrained the type of the scrutinee to the required type index, all
 563 further type refinement is local to the alternative.
 564
 565 \begin{code}
 566 --      Running example:
 567 -- MkT :: forall a b c. (a:=:[b]) => b -> c -> T a
 568 --       with scrutinee of type (T ty)
 569
 570 tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
 571          -> BoxySigmaType       -- Type of the pattern
 572          -> HsConPatDetails Name -> (PatState -> TcM a)
 573          -> TcM (Pat TcId, [TcTyVar], a)
 574 tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 575   = do  { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) = dataConFullSig data_con
 576               skol_info = PatSkol data_con
 577               origin    = SigOrigin skol_info
 578
 579           -- Instantiate the constructor type variables [a->ty]
 580         ; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty
 581         ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs  -- Get location from monad,
 582                                                         -- not from ex_tvs
 583         ; let tenv     = zipTopTvSubst (univ_tvs ++ ex_tvs)
 584                                        (ctxt_res_tys ++ mkTyVarTys ex_tvs')
 585               eq_spec' = substEqSpec tenv eq_spec
 586               theta'   = substTheta  tenv (eq_theta ++ dict_theta)
 587               arg_tys' = substTys    tenv arg_tys
 588
 589         ; co_vars <- newCoVars eq_spec' -- Make coercion variables
 590         ; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
 591
 592         ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
 593                 tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
 594
 595         ; loc <- getInstLoc origin
 596         ; dicts <- newDictBndrs loc theta'
 597         ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate')
 598                                            ex_tvs' dicts lie_req
 599
 600         ; addDataConStupidTheta data_con ctxt_res_tys
 601
 602         ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
 603                                      -- pat_ty /= pat_ty iff coi /= IdCo
 604               res_pat = ConPatOut { pat_con = L con_span data_con,
 605                                     pat_tvs = ex_tvs' ++ co_vars,
 606                                     pat_dicts = map instToVar dicts,
 607                                     pat_binds = dict_binds,
 608                                     pat_args = arg_pats', pat_ty = pat_ty' }
 609         ; return
 610             (mkCoPatCoI coi
 611                (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty,
 612              ex_tvs' ++ inner_tvs, res)
 613         }
 614   where
 615     -- Split against the family tycon if the pattern constructor
 616     -- belongs to a family instance tycon.
 617     boxySplitTyConAppWithFamily tycon pat_ty =
 618       traceTc traceMsg >>
 619       case tyConFamInst_maybe tycon of
 620         Nothing                   -> boxySplitTyConApp tycon pat_ty
 621         Just (fam_tycon, instTys) ->
 622           do { (scrutinee_arg_tys, coi) <- boxySplitTyConApp fam_tycon pat_ty
 623              ; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon)
 624              ; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys
 625              ; return (freshTvs, coi)
 626              }
 627       where
 628         traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+>
 629                          ppr tycon <+> ppr pat_ty
 630                        , text "  family instance:" <+>
 631                          ppr (tyConFamInst_maybe tycon)
 632                        ]
 633
 634     -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion
 635     -- pattern if the tycon is an instance of a family.
 636     --
 637     unwrapFamInstScrutinee :: TyCon -> [Type] -> Pat Id -> Pat Id
 638     unwrapFamInstScrutinee tycon args pat
 639       | Just co_con <- tyConFamilyCoercion_maybe tycon
 640 --      , not (isNewTyCon tycon)       -- newtypes are explicitly unwrapped by
 641                                      -- the desugarer
 642           -- NB: We can use CoPat directly, rather than mkCoPat, as we know the
 643           --     coercion is not the identity; mkCoPat is inconvenient as it
 644           --     wants a located pattern.
 645       = CoPat (WpCo $ mkTyConApp co_con args)       -- co fam ty to repr ty
 646               (pat {pat_ty = mkTyConApp tycon args})    -- representation type
 647               pat_ty                                    -- family inst type
 648       | otherwise
 649       = pat
 650
 651
 652 tcConArgs :: DataCon -> [TcSigmaType]
 653           -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
 654
 655 tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
 656   = do  { checkTc (con_arity == no_of_args)     -- Check correct arity
 657                   (arityErr "Constructor" data_con con_arity no_of_args)
 658         ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
 659         ; (arg_pats', tvs, res) <- tcMultiple tcConArg pats_w_tys
 660                                               pstate thing_inside
 661         ; return (PrefixCon arg_pats', tvs, res) }
 662   where
 663     con_arity  = dataConSourceArity data_con
 664     no_of_args = length arg_pats
 665
 666 tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside
 667   = do  { checkTc (con_arity == 2)      -- Check correct arity
 668                   (arityErr "Constructor" data_con con_arity 2)
 669         ; ([p1',p2'], tvs, res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
 670                                               pstate thing_inside
 671         ; return (InfixCon p1' p2', tvs, res) }
 672   where
 673     con_arity  = dataConSourceArity data_con
 674
 675 tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
 676   = pprPanic "tcConArgs" (ppr data_con) -- InfixCon always has two arguments
 677
 678 tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
 679   = do  { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
 680         ; return (RecCon (HsRecFields rpats' dd), tvs, res) }
 681   where
 682     tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
 683     tc_field (HsRecField field_lbl pat pun) pstate thing_inside
 684       = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
 685            ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
 686            ; return (HsRecField sel_id pat' pun, tvs, res) }
 687
 688     find_field_ty :: FieldLabel -> TcM (Id, TcType)
 689     find_field_ty field_lbl
 690         = case [ty | (f,ty) <- field_tys, f == field_lbl] of
 691
 692                 -- No matching field; chances are this field label comes from some
 693                 -- other record type (or maybe none).  As well as reporting an
 694                 -- error we still want to typecheck the pattern, principally to
 695                 -- make sure that all the variables it binds are put into the
 696                 -- environment, else the type checker crashes later:
 697                 --      f (R { foo = (a,b) }) = a+b
 698                 -- If foo isn't one of R's fields, we don't want to crash when
 699                 -- typechecking the "a+b".
 700            [] -> do { addErrTc (badFieldCon data_con field_lbl)
 701                     ; bogus_ty <- newFlexiTyVarTy liftedTypeKind
 702                     ; return (error "Bogus selector Id", bogus_ty) }
 703
 704                 -- The normal case, when the field comes from the right constructor
 705            (pat_ty : extras) ->
 706                 ASSERT( null extras )
 707                 do { sel_id <- tcLookupField field_lbl
 708                    ; return (sel_id, pat_ty) }
 709
 710     field_tys :: [(FieldLabel, TcType)]
 711     field_tys = zip (dataConFieldLabels data_con) arg_tys
 712         -- Don't use zipEqual! If the constructor isn't really a record, then
 713         -- dataConFieldLabels will be empty (and each field in the pattern
 714         -- will generate an error below).
 715
 716 tcConArg :: Checker (LPat Name, BoxySigmaType) (LPat Id)
 717 tcConArg (arg_pat, arg_ty) pstate thing_inside
 718   = tc_lpat arg_pat arg_ty pstate thing_inside
 719         -- NB: the tc_lpat will refine pat_ty if necessary
 720         --     based on the current pstate, which may include
 721         --     refinements from peer argument patterns to the left
 722 \end{code}
 723
 724 \begin{code}
 725 addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
 726 -- Instantiate the "stupid theta" of the data con, and throw
 727 -- the constraints into the constraint set
 728 addDataConStupidTheta data_con inst_tys
 729   | null stupid_theta = return ()
 730   | otherwise         = instStupidTheta origin inst_theta
 731   where
 732     origin = OccurrenceOf (dataConName data_con)
 733         -- The origin should always report "occurrence of C"
 734         -- even when C occurs in a pattern
 735     stupid_theta = dataConStupidTheta data_con
 736     tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
 737     inst_theta = substTheta tenv stupid_theta
 738 \end{code}
 739
 740
 741 %************************************************************************
 742 %*                                                                      *
 743                 Type refinement
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 \begin{code}
 748 refineAlt :: DataCon            -- For tracing only
 749           -> PatState
 750           -> [TcTyVar]          -- Existentials
 751           -> [CoVar]            -- Equational constraints
 752           -> BoxySigmaType      -- Pattern type
 753           -> TcM PatState
 754
 755 refineAlt con pstate ex_tvs [] pat_ty
 756   | null $ dataConEqTheta con
 757   = return pstate       -- Common case: no equational constraints
 758
 759 refineAlt con pstate ex_tvs co_vars pat_ty
 760   = do  { opt_gadt <- doptM Opt_GADTs   -- No type-refinement unless GADTs are on
 761         ; if (not opt_gadt) then return pstate
 762           else do
 763
 764         { checkTc (isRigidTy pat_ty) (nonRigidMatch con)
 765         -- We are matching against a GADT constructor with non-trivial
 766         -- constraints, but pattern type is wobbly.  For now we fail.
 767         -- We can make sense of this, however:
 768         -- Suppose MkT :: forall a b. (a:=:[b]) => b -> T a
 769         --      (\x -> case x of { MkT v -> v })
 770         -- We can infer that x must have type T [c], for some wobbly 'c'
 771         -- and translate to
 772         --      (\(x::T [c]) -> case x of
 773         --                        MkT b (g::([c]:=:[b])) (v::b) -> v `cast` sym g
 774         -- To implement this, we'd first instantiate the equational
 775         -- constraints with *wobbly* type variables for the existentials;
 776         -- then unify these constraints to make pat_ty the right shape;
 777         -- then proceed exactly as in the rigid case
 778
 779                 -- In the rigid case, we perform type refinement
 780         ; case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
 781             Failed msg     -> failWithTc (inaccessibleAlt msg) ;
 782             Succeeded reft -> do { traceTc trace_msg
 783                                  ; return (pstate { pat_reft = reft, pat_eqs = (pat_eqs pstate || not (null $ dataConEqTheta con)) }) }
 784                     -- DO NOT refine the envt right away, because we
 785                     -- might be inside a lazy pattern.  Instead, refine pstate
 786                 where
 787
 788                     trace_msg = text "refineAlt:match" <+>
 789                                 vcat [ ppr con <+> ppr ex_tvs,
 790                                        ppr [(v, tyVarKind v) | v <- co_vars],
 791                                        ppr reft]
 792         } } }
 793 \end{code}
 794
 795
 796 %************************************************************************
 797 %*                                                                      *
 798                 Overloaded literals
 799 %*                                                                      *
 800 %************************************************************************
 801
 802 In tcOverloadedLit we convert directly to an Int or Integer if we
 803 know that's what we want.  This may save some time, by not
 804 temporarily generating overloaded literals, but it won't catch all
 805 cases (the rest are caught in lookupInst).
 806
 807 \begin{code}
 808 tcOverloadedLit :: InstOrigin
 809                  -> HsOverLit Name
 810                  -> BoxyRhoType
 811                  -> TcM (HsOverLit TcId)
 812 tcOverloadedLit orig lit@(HsIntegral i fi) res_ty
 813   | not (fi `isHsVar` fromIntegerName)  -- Do not generate a LitInst for rebindable syntax.
 814         -- Reason: If we do, tcSimplify will call lookupInst, which
 815         --         will call tcSyntaxName, which does unification,
 816         --         which tcSimplify doesn't like
 817         -- ToDo: noLoc sadness
 818   = do  { integer_ty <- tcMetaTy integerTyConName
 819         ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty)
 820         ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
 821
 822   | Just expr <- shortCutIntLit i res_ty
 823   = return (HsIntegral i expr)
 824
 825   | otherwise
 826   = do  { expr <- newLitInst orig lit res_ty
 827         ; return (HsIntegral i expr) }
 828
 829 tcOverloadedLit orig lit@(HsFractional r fr) res_ty
 830   | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
 831   = do  { rat_ty <- tcMetaTy rationalTyConName
 832         ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty)
 833                 -- Overloaded literals must have liftedTypeKind, because
 834                 -- we're instantiating an overloaded function here,
 835                 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
 836                 -- However this'll be picked up by tcSyntaxOp if necessary
 837         ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
 838
 839   | Just expr <- shortCutFracLit r res_ty
 840   = return (HsFractional r expr)
 841
 842   | otherwise
 843   = do  { expr <- newLitInst orig lit res_ty
 844         ; return (HsFractional r expr) }
 845
 846 tcOverloadedLit orig lit@(HsIsString s fr) res_ty
 847   | not (fr `isHsVar` fromStringName)   -- c.f. HsIntegral case
 848   = do  { str_ty <- tcMetaTy stringTyConName
 849         ; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
 850         ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) }
 851
 852   | Just expr <- shortCutStringLit s res_ty
 853   = return (HsIsString s expr)
 854
 855   | otherwise
 856   = do  { expr <- newLitInst orig lit res_ty
 857         ; return (HsIsString s expr) }
 858
 859 newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
 860 newLitInst orig lit res_ty      -- Make a LitInst
 861   = do  { loc <- getInstLoc orig
 862         ; res_tau <- zapToMonotype res_ty
 863         ; new_uniq <- newUnique
 864         ; let   lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
 865                 lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit,
 866                                     tci_ty = res_tau, tci_loc = loc}
 867         ; extendLIE lit_inst
 868         ; return (HsVar (instToId lit_inst)) }
 869 \end{code}
 870
 871
 872 %************************************************************************
 873 %*                                                                      *
 874                 Note [Pattern coercions]
 875 %*                                                                      *
 876 %************************************************************************
 877
 878 In principle, these program would be reasonable:
 879
 880         f :: (forall a. a->a) -> Int
 881         f (x :: Int->Int) = x 3
 882
 883         g :: (forall a. [a]) -> Bool
 884         g [] = True
 885
 886 In both cases, the function type signature restricts what arguments can be passed
 887 in a call (to polymorphic ones).  The pattern type signature then instantiates this
 888 type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we
 889 generate the translated term
 890         f = \x' :: (forall a. a->a).  let x = x' Int in x 3
 891
 892 From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.
 893 And it requires a significant amount of code to implement, becuase we need to decorate
 894 the translated pattern with coercion functions (generated from the subsumption check
 895 by tcSub).
 896
 897 So for now I'm just insisting on type *equality* in patterns.  No subsumption.
 898
 899 Old notes about desugaring, at a time when pattern coercions were handled:
 900
 901 A SigPat is a type coercion and must be handled one at at time.  We can't
 902 combine them unless the type of the pattern inside is identical, and we don't
 903 bother to check for that.  For example:
 904
 905         data T = T1 Int | T2 Bool
 906         f :: (forall a. a -> a) -> T -> t
 907         f (g::Int->Int)   (T1 i) = T1 (g i)
 908         f (g::Bool->Bool) (T2 b) = T2 (g b)
 909
 910 We desugar this as follows:
 911
 912         f = \ g::(forall a. a->a) t::T ->
 913             let gi = g Int
 914             in case t of { T1 i -> T1 (gi i)
 915                            other ->
 916             let gb = g Bool
 917             in case t of { T2 b -> T2 (gb b)
 918                            other -> fail }}
 919
 920 Note that we do not treat the first column of patterns as a
 921 column of variables, because the coerced variables (gi, gb)
 922 would be of different types.  So we get rather grotty code.
 923 But I don't think this is a common case, and if it was we could
 924 doubtless improve it.
 925
 926 Meanwhile, the strategy is:
 927         * treat each SigPat coercion (always non-identity coercions)
 928                 as a separate block
 929         * deal with the stuff inside, and then wrap a binding round
 930                 the result to bind the new variable (gi, gb, etc)
 931
 932
 933 %************************************************************************
 934 %*                                                                      *
 935 \subsection{Errors and contexts}
 936 %*                                                                      *
 937 %************************************************************************
 938
 939 \begin{code}
 940 patCtxt :: Pat Name -> Maybe Message    -- Not all patterns are worth pushing a context
 941 patCtxt (VarPat _)  = Nothing
 942 patCtxt (ParPat _)  = Nothing
 943 patCtxt (AsPat _ _) = Nothing
 944 patCtxt pat         = Just (hang (ptext SLIT("In the pattern:"))
 945                                4 (ppr pat))
 946
 947 -----------------------------------------------
 948
 949 existentialExplode pat
 950   = hang (vcat [text "My brain just exploded.",
 951                 text "I can't handle pattern bindings for existentially-quantified constructors.",
 952                 text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
 953                 text "In the binding group for"])
 954         4 (ppr pat)
 955
 956 sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
 957   = do  { pat_tys' <- mapM zonkTcType pat_tys
 958         ; body_ty' <- zonkTcType body_ty
 959         ; let (env1,  tidy_tys)    = tidyOpenTypes tidy_env (map idType show_ids)
 960               (env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys'
 961               (env3, tidy_body_ty) = tidyOpenType  env2 body_ty'
 962         ; return (env3,
 963                  sep [ptext SLIT("When checking an existential match that binds"),
 964                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 965                       ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
 966                       ptext SLIT("The body has type:") <+> ppr tidy_body_ty
 967                 ]) }
 968   where
 969     bound_ids = collectPatsBinders pats
 970     show_ids = filter is_interesting bound_ids
 971     is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs
 972
 973     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
 974         -- Don't zonk the types so we get the separate, un-unified versions
 975
 976 badFieldCon :: DataCon -> Name -> SDoc
 977 badFieldCon con field
 978   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
 979           ptext SLIT("does not have field"), quotes (ppr field)]
 980
 981 polyPatSig :: TcType -> SDoc
 982 polyPatSig sig_ty
 983   = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
 984          4 (ppr sig_ty)
 985
 986 badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
 987
 988 lazyPatErr pat tvs
 989   = failWithTc $
 990     hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))
 991        2 (vcat (map pprSkolTvBinding tvs))
 992
 993 nonRigidMatch con
 994   =  hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
 995         2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
 996
 997 nonRigidResult res_ty
 998   =  hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty))
 999         2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
1000
1001 inaccessibleAlt msg
1002   = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
1003 \end{code}