TcPatSyn.hs 47.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

cactus's avatar
cactus committed
5
\section[TcPatSyn]{Typechecking pattern synonym declarations}
Austin Seipp's avatar
Austin Seipp committed
6
-}
cactus's avatar
cactus committed
7

8
{-# LANGUAGE CPP #-}
9
{-# LANGUAGE FlexibleContexts #-}
10
{-# LANGUAGE TypeFamilies #-}
11
{-# LANGUAGE ViewPatterns #-}
12

13 14
module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
                , tcPatSynBuilderOcc, nonBidirectionalErr
15
  ) where
cactus's avatar
cactus committed
16

17 18
import GhcPrelude

19
import GHC.Hs
cactus's avatar
cactus committed
20
import TcPat
David Eichmann's avatar
David Eichmann committed
21
import Type( tidyTyCoVarBinders, tidyTypes, tidyType )
cactus's avatar
cactus committed
22
import TcRnMonad
23
import TcSigs( emptyPragEnv, completeSigFromId )
cactus's avatar
cactus committed
24 25
import TcEnv
import TcMType
26
import TcHsSyn
cactus's avatar
cactus committed
27 28 29 30 31 32 33 34 35
import TysPrim
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
36
import VarEnv( emptyTidyEnv, mkInScopeSet )
cactus's avatar
cactus committed
37
import Id
38
import IdInfo( RecSelParent(..), setLevityInfoWithType )
cactus's avatar
cactus committed
39 40 41
import TcBinds
import BasicTypes
import TcSimplify
42
import TcUnify
43
import Predicate
44
import TysWiredIn
cactus's avatar
cactus committed
45
import TcType
46
import TcEvidence
47
import TcOrigin
48
import BuildTyCl
cactus's avatar
cactus committed
49
import VarSet
50
import MkId
51
import TcTyDecls
Matthew Pickering's avatar
Matthew Pickering committed
52 53
import ConLike
import FieldLabel
cactus's avatar
cactus committed
54
import Bag
55
import Util
56
import ErrUtils
57
import Data.Maybe( mapMaybe )
58
import Control.Monad ( zipWithM )
59
import Data.List( partition )
cactus's avatar
cactus committed
60 61 62

#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
63 64 65
{-
************************************************************************
*                                                                      *
66
                    Type checking a pattern synonym
Austin Seipp's avatar
Austin Seipp committed
67 68 69
*                                                                      *
************************************************************************
-}
70

71 72 73
tcPatSynDecl :: PatSynBind GhcRn GhcRn
             -> Maybe TcSigInfo
             -> TcM (LHsBinds GhcTc, TcGblEnv)
74 75
tcPatSynDecl psb mb_sig
  = recoverM (recoverPSB psb) $
76 77 78
    case mb_sig of
      Nothing                 -> tcInferPatSynDecl psb
      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
79 80 81 82 83
      _                       -> panic "tcPatSynDecl"

recoverPSB :: PatSynBind GhcRn GhcRn
           -> TcM (LHsBinds GhcTc, TcGblEnv)
-- See Note [Pattern synonym error recovery]
84
recoverPSB (PSB { psb_id = L _ name
85
                , psb_args = details })
86 87 88 89 90
 = do { matcher_name <- newImplicitBinder name mkMatcherOcc
      ; let placeholder = AConLike $ PatSynCon $
                          mk_placeholder matcher_name
      ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
      ; return (emptyBag, gbl_env) }
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
  where
    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
    mk_placeholder matcher_name
      = mkPatSyn name is_infix
                        ([mkTyVarBinder Specified alphaTyVar], []) ([], [])
                        [] -- Arg tys
                        alphaTy
                        (matcher_id, True) Nothing
                        []  -- Field labels
       where
         -- The matcher_id is used only by the desugarer, so actually
         -- and error-thunk would probably do just as well here.
         matcher_id = mkLocalId matcher_name $
                      mkSpecForAllTys [alphaTyVar] alphaTy

106
recoverPSB (XPatSynBind nec) = noExtCon nec
107 108 109

{- Note [Pattern synonym error recovery]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
110
If type inference for a pattern synonym fails, we can't continue with
111 112 113
the rest of tc_patsyn_finish, because we may get knock-on errors, or
even a crash.  E.g. from
   pattern What = True :: Maybe
114
we get a kind error; and we must stop right away (#15289).
115 116 117 118 119 120

We stop if there are /any/ unsolved constraints, not just insoluble
ones; because pattern synonyms are top-level things, we will never
solve them later if we can't solve them now.  And if we were to carry
on, tc_patsyn_finish does zonkTcTypeToType, which defaults any
unsolved unificatdion variables to Any, which confuses the error
121
reporting no end (#15685).
122 123 124 125 126 127 128 129 130 131 132 133

So we use simplifyTop to completely solve the constraint, report
any errors, throw an exception.

Even in the event of such an error we can recover and carry on, just
as we do for value bindings, provided we plug in placeholder for the
pattern synonym: see recoverPSB.  The goal of the placeholder is not
to cause a raft of follow-on errors.  I've used the simplest thing for
now, but we might need to elaborate it a bit later.  (e.g.  I've given
it zero args, which may cause knock-on errors if it is used in a
pattern.) But it'll do for now.

134 135
-}

136 137
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
138
tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
139
                       , psb_def = lpat, psb_dir = dir })
140
  = addPatSynCtxt lname $
141
    do { traceTc "tcInferPatSynDecl {" $ ppr name
cactus's avatar
cactus committed
142

Matthew Pickering's avatar
Matthew Pickering committed
143
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
144
       ; (tclvl, wanted, ((lpat', args), pat_ty))
145
            <- pushLevelAndCaptureConstraints  $
146 147
               tcInferNoInst                   $ \ exp_ty ->
               tcPat PatSyn lpat exp_ty        $
148
               mapM tcLookupId arg_names
149

150
       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
cactus's avatar
cactus committed
151

152 153 154
             named_taus = (name, pat_ty) : map mk_named_tau args
             mk_named_tau arg
               = (getName arg, mkSpecForAllTys ex_tvs (varType arg))
155
               -- The mkSpecForAllTys is important (#14552), albeit
156
               -- slightly artificial (there is no variable with this funny type).
157 158 159 160 161 162
               -- We do not want to quantify over variable (alpha::k)
               -- that mention the existentially-bound type variables
               -- ex_tvs in its kind k.
               -- See Note [Type variables whose kind is captured]

       ; (univ_tvs, req_dicts, ev_binds, residual, _)
163
               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted
164 165
       ; top_ev_binds <- checkNoErrs (simplifyTop residual)
       ; addTopEvBinds top_ev_binds $
166

167
    do { prov_dicts <- mapM zonkId prov_dicts
168 169
       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
             -- Filtering: see Note [Remove redundant provided dicts]
170 171
             (prov_theta, prov_evs)
                 = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
172
             req_theta = map evVarPred req_dicts
173 174 175 176 177 178 179 180 181

       -- Report coercions that esacpe
       -- See Note [Coercions that escape]
       ; args <- mapM zonkId args
       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
                              , let bad_cos = filterDVarSet isId $
                                              (tyCoVarsOfTypeDSet (idType arg))
                              , not (isEmptyDVarSet bad_cos) ]
       ; mapM_ dependentArgErr bad_args
182

183
       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
184
       ; tc_patsyn_finish lname dir is_infix lpat'
185
                          (mkTyVarBinders Inferred univ_tvs
186
                            , req_theta,  ev_binds, req_dicts)
187
                          (mkTyVarBinders Inferred ex_tvs
188
                            , mkTyVarTys ex_tvs, prov_theta, prov_evs)
189
                          (map nlHsVar args, map idType args)
190
                          pat_ty rec_fields } }
191
tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec
Matthew Pickering's avatar
Matthew Pickering committed
192

193 194 195 196
mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
-- See Note [Equality evidence in pattern synonyms]
mkProvEvidence ev_id
  | EqPred r ty1 ty2 <- classifyPredType pred
197 198
  , let k1 = tcTypeKind ty1
        k2 = tcTypeKind ty2
199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
        is_homo = k1 `tcEqType` k2
        homo_tys   = [k1, ty1, ty2]
        hetero_tys = [k1, k2, ty1, ty2]
  = case r of
      ReprEq | is_homo
             -> Just ( mkClassPred coercibleClass    homo_tys
                     , evDataConApp coercibleDataCon homo_tys eq_con_args )
             | otherwise -> Nothing
      NomEq  | is_homo
             -> Just ( mkClassPred eqClass    homo_tys
                     , evDataConApp eqDataCon homo_tys eq_con_args )
             | otherwise
             -> Just ( mkClassPred heqClass    hetero_tys
                     , evDataConApp heqDataCon hetero_tys eq_con_args )

  | otherwise
  = Just (pred, EvExpr (evId ev_id))
  where
    pred = evVarPred ev_id
    eq_con_args = [evId ev_id]

220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr (arg, bad_cos)
  = addErrTc $
    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
         , hang (text "Pattern-bound variable")
              2 (ppr arg <+> dcolon <+> ppr (idType arg))
         , nest 2 $
           hang (text "has a type that mentions pattern-bound coercion"
                 <> plural bad_co_list <> colon)
              2 (pprWithCommas ppr bad_co_list)
         , text "Hint: use -fprint-explicit-coercions to see the coercions"
         , text "Probable fix: add a pattern signature" ]
  where
    bad_co_list = dVarSetElems bad_cos

236 237 238 239 240 241 242 243 244 245 246 247 248 249
{- Note [Type variables whose kind is captured]
~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data AST a = Sym [a]
  class Prj s where { prj :: [a] -> Maybe (s a)
  pattern P x <= Sym (prj -> Just x)

Here we get a matcher with this type
  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r

No problem.  But note that 's' is not fixed by the type of the
pattern (AST a), nor is it existentially bound.  It's really only
fixed by the type of the continuation.

250
#14552 showed that this can go wrong if the kind of 's' mentions
251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
existentially bound variables.  We obviously can't make a type like
  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
                                   -> r -> r
But neither is 's' itself existentially bound, so the forall (s::k->*)
can't go in the inner forall either.  (What would the matcher apply
the continuation to?)

Solution: do not quantiify over any unification variable whose kind
mentions the existentials.  We can conveniently do that by making the
"taus" passed to simplifyInfer look like
   forall ex_tvs. arg_ty

After that, Note [Naughty quantification candidates] in TcMType takes
over, and zonks any such naughty variables to Any.

Note [Remove redundant provided dicts]
267 268 269 270 271 272 273
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that
   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
                                       => a1 :~~: a2
(NB: technically the (k1~k2) existential dictionary is not necessary,
but it's there at the moment.)

274
Now consider (#14394):
275 276 277 278 279 280 281 282 283 284 285
   pattern Foo = HRefl
in a non-poly-kinded module.  We don't want to get
    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
with that redundant (* ~ *).  We'd like to remove it; hence the call to
mkMinimalWithSCs.

Similarly consider
  data S a where { MkS :: Ord a => a -> S a }
  pattern Bam x y <- (MkS (x::a), MkS (y::a)))

The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
286
need one.  Again mkMimimalWithSCs removes the redundant one.
287

288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303
Note [Equality evidence in pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data X a where
     MkX :: Eq a => [a] -> X (Maybe a)
  pattern P x = MkG x

Then there is a danger that GHC will infer
  P :: forall a.  () =>
       forall b. (a ~# Maybe b, Eq b) => [b] -> X a

The 'builder' for P, which is called in user-code, will then
have type
  $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a

and that is bad because (a ~# Maybe b) is not a predicate type
304
(see Note [Types for coercions, predicates, and evidence] in TyCoRep
305 306 307 308 309
and is not implicitly instantiated.

So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and
marginally less efficient, if the builder/martcher are not inlined.

310
See also Note [Lift equality constraints when quantifying] in TcType
311

312 313
Note [Coercions that escape]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
314
#14507 showed an example where the inferred type of the matcher
315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338
for the pattern synonym was somethign like
   $mSO :: forall (r :: TYPE rep) kk (a :: k).
           TypeRep k a
           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
           -> (Void# -> r)
           -> r

What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass
selection) by the pattern being matched; and indeed it is implicit in
the context (Bool ~ k).  You could imagine trying to extract it like
this:
   $mSO :: forall (r :: TYPE rep) kk (a :: k).
           TypeRep k a
           -> ( co :: ((Bool :: *) ~ (k :: *)) =>
                  let co_a2sv = sc_sel co
                  in TypeRep Bool (a |> co_a2sv) -> r)
           -> (Void# -> r)
           -> r

But we simply don't allow that in types.  Maybe one day but not now.

How to detect this situation?  We just look for free coercion variables
in the types of any of the arguments to the matcher.  The error message
is not very helpful, but at least we don't get a Lint error.
339
-}
340

341
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
342
                  -> TcPatSynInfo
343
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
344
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
345
                         , psb_def = lpat, psb_dir = dir }
346 347 348 349
                  TPSI{ patsig_implicit_bndrs = implicit_tvs
                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta
                      , patsig_body_ty    = sig_body_ty }
350
  = addPatSynCtxt lname $
351
    do { let decl_arity = length arg_names
352 353 354
             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

       ; traceTc "tcCheckPatSynDecl" $
355 356
         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
357

358 359 360 361 362 363 364 365 366 367 368 369 370 371
       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
                                 Right stuff  -> return stuff
                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing

       -- Complain about:  pattern P :: () => forall x. x -> P x
       -- The existential 'x' should not appear in the result type
       -- Can't check this until we know P's arity
       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
       ; checkTc (null bad_tvs) $
         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
                   , text "namely" <+> quotes (ppr pat_ty) ])
            2 (text "mentions existential type variable" <> plural bad_tvs
               <+> pprQuotedList bad_tvs)

372
         -- See Note [The pattern-synonym signature splitting rule] in TcSigs
373
       ; let univ_fvs = closeOverKinds $
374
                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
375 376 377 378 379
             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
             univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
             ex_bndrs   = extra_ex   ++ mkTyVarBinders Specified explicit_ex_tvs
             univ_tvs   = binderVars univ_bndrs
             ex_tvs     = binderVars ex_bndrs
380

381 382
       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
383
       ; req_dicts <- newEvVars req_theta
384 385
       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
386 387 388
           pushLevelAndCaptureConstraints            $
           tcExtendTyVarEnv univ_tvs                 $
           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
389
           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)
390
                    empty_subst = mkEmptyTCvSubst in_scope
391 392 393
              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
                    -- newMetaTyVarX: see the "Existential type variables"
                    -- part of Note [Checking against a pattern signature]
394 395
              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
396
              ; let prov_theta' = substTheta subst prov_theta
397
                  -- Add univ_tvs to the in_scope set to
398
                  -- satisfy the substitution invariant. There's no need to
399 400
                  -- add 'ex_tvs' as they are already in the domain of the
                  -- substitution.
Ben Gamari's avatar
Ben Gamari committed
401
                  -- See also Note [The substitution invariant] in TyCoSubst.
402
              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
403 404 405
              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
              ; return (ex_tvs', prov_dicts, args') }

406
       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
407 408
                         -- The type here is a bit bogus, but we do not print
                         -- the type for PatSynCtxt, so it doesn't matter
409
                         -- See Note [Skolem info for pattern synonyms] in Origin
410
       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
411

412
       -- Solve the constraints now, because we are about to make a PatSyn,
413
       -- which should not contain unification variables and the like (#10997)
414
       ; simplifyTopImplic implics
415 416 417 418

       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
       -- Otherwise we may get a type error when typechecking the builder,
       -- when that should be impossible
419

420
       ; traceTc "tcCheckPatSynDecl }" $ ppr name
421
       ; tc_patsyn_finish lname dir is_infix lpat'
422 423
                          (univ_bndrs, req_theta, ev_binds, req_dicts)
                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
424
                          (args', arg_tys)
425
                          pat_ty rec_fields }
426
  where
427
    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
428 429 430 431
    tc_arg subst arg_name arg_ty
      = do {   -- Look up the variable actually bound by lpat
               -- and check that it has the expected type
             arg_id <- tcLookupId arg_name
432 433 434 435 436 437
           ; wrap <- tcSubType_NC GenSigCtxt
                                 (idType arg_id)
                                 (substTyUnchecked subst arg_ty)
                -- Why do we need tcSubType here?
                -- See Note [Pattern synonyms and higher rank types]
           ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
438
tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec
439 440 441 442 443 444 445 446 447 448

{- [Pattern synonyms and higher rank types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data T = MkT (forall a. a->a)

  pattern P :: (Int -> Int) -> T
  pattern P x <- MkT x

This should work.  But in the matcher we must match against MkT, and then
Gabor Greif's avatar
Gabor Greif committed
449
instantiate its argument 'x', to get a function of type (Int -> Int).
450
Equality is not enough!  #13752 was an example.
451

452 453 454 455 456 457 458

Note [The pattern-synonym signature splitting rule]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given a pattern signature, we must split
     the kind-generalised variables, and
     the implicitly-bound variables
into universal and existential.  The rule is this
459
(see discussion on #11224):
460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479

     The universal tyvars are the ones mentioned in
          - univ_tvs: the user-specified (forall'd) universals
          - req_theta
          - res_ty
     The existential tyvars are all the rest

For example

   pattern P :: () => b -> T a
   pattern P x = ...

Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
how do we split the arg_tys from req_ty?  Consider

   pattern Q :: () => b -> S c -> T a
   pattern Q x = ...

This is an odd example because Q has only one syntactic argument, and
so presumably is defined by a view pattern matching a function.  But
480
it can happen (#11977, #12108).
481 482 483 484 485 486 487 488 489 490 491 492 493 494 495

We don't know Q's arity from the pattern signature, so we have to wait
until we see the pattern declaration itself before deciding res_ty is,
and hence which variables are existential and which are universal.

And that in turn is why TcPatSynInfo has a separate field,
patsig_implicit_bndrs, to capture the implicitly bound type variables,
because we don't yet know how to split them up.

It's a slight compromise, because it means we don't really know the
pattern synonym's real signature until we see its declaration.  So,
for example, in hs-boot file, we may need to think what to do...
(eg don't have any implicitly-bound variables).


496
Note [Checking against a pattern signature]
497 498 499 500 501 502 503 504 505 506 507 508 509 510
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When checking the actual supplied pattern against the pattern synonym
signature, we need to be quite careful.

----- Provided constraints
Example

    data T a where
      MkT :: Ord a => a -> T a

    pattern P :: () => Eq a => a -> [T a]
    pattern P x = [MkT x]

We must check that the (Eq a) that P claims to bind (and to
Rik Steenkamp's avatar
Rik Steenkamp committed
511 512
make available to matches against P), is derivable from the
actual pattern.  For example:
513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536
    f (P (x::a)) = ...here (Eq a) should be available...
And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.

----- Existential type variables
Unusually, we instantiate the existential tyvars of the pattern with
*meta* type variables.  For example

    data S where
      MkS :: Eq a => [a] -> S

    pattern P :: () => Eq x => x -> S
    pattern P x <- MkS x

The pattern synonym conceals from its client the fact that MkS has a
list inside it.  The client just thinks it's a type 'x'.  So we must
unify x := [a] during type checking, and then use the instantiating type
[a] (called ex_tys) when building the matcher.  In this case we'll get

   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
   $mP x k = case x of
               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
                                              dl = $dfunEqList d
                                          in k [a] dl ys

537 538 539 540 541 542 543 544 545 546 547 548
All this applies when type-checking the /matching/ side of
a pattern synonym.  What about the /building/ side?

* For Unidirectional, there is no builder

* For ExplicitBidirectional, the builder is completely separate
  code, typechecked in tcPatSynBuilderBind

* For ImplicitBidirectional, the builder is still typechecked in
  tcPatSynBuilderBind, by converting the pattern to an expression and
  typechecking it.

549
  At one point, for ImplicitBidirectional I used TyVarTvs (instead of
550 551
  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
  is redundant since tcPatSynBuilderBind does the job, (b) it was
552
  still incomplete (TyVarTvs can unify with each other), and (c) it
553
  didn't even work (#13441 was accepted with
554 555 556
  ExplicitBidirectional, but rejected if expressed in
  ImplicitBidirectional form.  Conclusion: trying to be too clever is
  a bad idea.
557
-}
558

559 560
collectPatSynArgInfo :: HsPatSynDetails (Located Name)
                     -> ([Name], [Name], Bool)
Matthew Pickering's avatar
Matthew Pickering committed
561 562
collectPatSynArgInfo details =
  case details of
563 564 565 566 567
    PrefixCon names      -> (map unLoc names, [], False)
    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
    RecCon names         -> (vars, sels, False)
                         where
                            (vars, sels) = unzip (map splitRecordPatSyn names)
Matthew Pickering's avatar
Matthew Pickering committed
568
  where
569 570
    splitRecordPatSyn :: RecordPatSynField (Located Name)
                      -> (Name, Name)
571
    splitRecordPatSyn (RecordPatSynField
572 573
                       { recordPatSynPatVar     = L _ patVar
                       , recordPatSynSelectorId = L _ selId })
Matthew Pickering's avatar
Matthew Pickering committed
574 575
      = (patVar, selId)

576
addPatSynCtxt :: Located Name -> TcM a -> TcM a
577
addPatSynCtxt (L loc name) thing_inside
578
  = setSrcSpan loc $
579
    addErrCtxt (text "In the declaration for pattern synonym"
580 581 582
                <+> quotes (ppr name)) $
    thing_inside

583 584 585 586
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
  = failWithTc $
    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
587
          <+> speakNOf decl_arity (text "argument"))
588
       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
589

590 591
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
592 593
tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
Matthew Pickering's avatar
Matthew Pickering committed
594
                 -> Bool              -- ^ Whether infix
595
                 -> LPat GhcTc        -- ^ Pattern of the PatSyn
596
                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
597
                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
598 599 600 601
                 -> ([LHsExpr GhcTcId], [TcType])   -- ^ Pattern arguments and
                                                    -- types
                 -> TcType            -- ^ Pattern type
                 -> [Name]            -- ^ Selector names
Matthew Pickering's avatar
Matthew Pickering committed
602
                 -- ^ Whether fields, empty if not record PatSyn
603
                 -> TcM (LHsBinds GhcTc, TcGblEnv)
604
tc_patsyn_finish lname dir is_infix lpat'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
605 606
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
607
                 (args, arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
608
                 pat_ty field_labels
609 610
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there
Simon Peyton Jones's avatar
Simon Peyton Jones committed
611

612 613
         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs
       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta
Simon Peyton Jones's avatar
Simon Peyton Jones committed
614
       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs
615 616 617
       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta
       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty
       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys
618

Ningning Xie's avatar
Ningning Xie committed
619 620
       ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'
             (env2, ex_tvs)   = tidyTyCoVarBinders env1 ex_tvs'
621 622 623 624
             req_theta  = tidyTypes env2 req_theta'
             prov_theta = tidyTypes env2 prov_theta'
             arg_tys    = tidyTypes env2 arg_tys'
             pat_ty     = tidyType  env2 pat_ty'
625

626
       ; traceTc "tc_patsyn_finish {" $
627
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
628 629
           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, prov_theta, prov_dicts) $$
630 631
           ppr args $$
           ppr arg_tys $$
632
           ppr pat_ty
633 634

       -- Make the 'matcher'
635
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
636 637
                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
638
                                         (args, arg_tys)
cactus's avatar
cactus committed
639
                                         pat_ty
640

641
       -- Make the 'builder'
642
       ; builder_id <- mkPatSynBuilderId dir lname
643 644
                                         univ_tvs req_theta
                                         ex_tvs   prov_theta
Matthew Pickering's avatar
Matthew Pickering committed
645
                                         arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
646 647

         -- TODO: Make this have the proper information
648 649 650 651
       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
                                            , flIsOverloaded = False
                                            , flSelector = name }
             field_labels' = map mkFieldLabel field_labels
Matthew Pickering's avatar
Matthew Pickering committed
652

653

654
       -- Make the PatSyn itself
Matthew Pickering's avatar
Matthew Pickering committed
655
       ; let patSyn = mkPatSyn (unLoc lname) is_infix
656 657
                        (univ_tvs, req_theta)
                        (ex_tvs, prov_theta)
658
                        arg_tys
cactus's avatar
cactus committed
659
                        pat_ty
660
                        matcher_id builder_id
Matthew Pickering's avatar
Matthew Pickering committed
661 662 663
                        field_labels'

       -- Selectors
664 665 666 667
       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
             tything = AConLike (PatSynCon patSyn)
       ; tcg_env <- tcExtendGlobalEnv [tything] $
                    tcRecSelBinds rn_rec_sel_binds
Matthew Pickering's avatar
Matthew Pickering committed
668

669
       ; traceTc "tc_patsyn_finish }" empty
670
       ; return (matcher_bind, tcg_env) }
671

Austin Seipp's avatar
Austin Seipp committed
672 673 674
{-
************************************************************************
*                                                                      *
675
         Constructing the "matcher" Id and its binding
Austin Seipp's avatar
Austin Seipp committed
676 677 678
*                                                                      *
************************************************************************
-}
679

680
tcPatSynMatcher :: Located Name
681
                -> LPat GhcTc
682
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
683
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
684
                -> ([LHsExpr GhcTcId], [TcType])
cactus's avatar
cactus committed
685
                -> TcType
686
                -> TcM ((Id, Bool), LHsBinds GhcTc)
687
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
688
tcPatSynMatcher (L loc name) lpat
689
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
690 691
                (ex_tvs, ex_tys, prov_theta, prov_dicts)
                (args, arg_tys) pat_ty
692 693
  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
694
       ; let rr_tv  = mkTyVar rr_name runtimeRepTy
695
             rr     = mkTyVarTy rr_tv
696
             res_tv = mkTyVar tv_name (tYPE rr)
697
             res_ty = mkTyVarTy res_tv
698
             is_unlifted = null args && null prov_dicts
699 700 701
             (cont_args, cont_arg_tys)
               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
               | otherwise   = (args,                 arg_tys)
702
             cont_ty = mkInfSigmaTy ex_tvs prov_theta $
703
                       mkVisFunTys cont_arg_tys res_ty
704

705
             fail_ty  = mkVisFunTy voidPrimTy res_ty
706

707
       ; matcher_name <- newImplicitBinder name mkMatcherOcc
708 709 710 711
       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty

712
       ; let matcher_tau   = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty
713
             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
714
             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
715
                             -- See Note [Exported LocalIds] in Id
716

717
             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
718
             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
cactus's avatar
cactus committed
719

720
             fail' = nlHsApps fail [nlHsVar voidPrimId]
cactus's avatar
cactus committed
721

722
             args = map nlVarPat [scrutinee, cont, fail]
cactus's avatar
cactus committed
723 724
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
725 726 727
                     then [mkHsCaseAlt lpat  cont']
                     else [mkHsCaseAlt lpat  cont',
                           mkHsCaseAlt lwpat fail']
728
             body = mkLHsWrap (mkWpLet req_ev_binds) $
729
                    L (getLoc lpat) $
730
                    HsCase noExtField (nlHsVar scrutinee) $
731
                    MG{ mg_alts = L (getLoc lpat) cases
732
                      , mg_ext = MatchGroupTc [pat_ty] res_ty
733
                      , mg_origin = Generated
cactus's avatar
cactus committed
734 735
                      }
             body' = noLoc $
736
                     HsLam noExtField $
737 738
                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
                                                        args body]
739
                       , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
740
                       , mg_origin = Generated
cactus's avatar
cactus committed
741
                       }
742
             match = mkMatch (mkPrefixFunRhs (L loc name)) []
743
                             (mkHsLams (rr_tv:res_tv:univ_tvs)
744
                                       req_dicts body')
745
                             (noLoc (EmptyLocalBinds noExtField))
746
             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
747
             mg = MG{ mg_alts = L (getLoc match) [match]
748
                    , mg_ext = MatchGroupTc [] res_ty
749
                    , mg_origin = Generated
cactus's avatar
cactus committed
750 751
                    }

752
       ; let bind = FunBind{ fun_ext = emptyNameSet
753
                           , fun_id = L loc matcher_id
cactus's avatar
cactus committed
754 755
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
756
                           , fun_tick = [] }
757
             matcher_bind = unitBag (noLoc bind)
cactus's avatar
cactus committed
758

759
       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
cactus's avatar
cactus committed
760 761
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

762 763
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
764
mkPatSynRecSelBinds :: PatSyn
765
                    -> [FieldLabel]  -- ^ Visible field labels
766
                    -> [(Id, LHsBind GhcRn)]
767
mkPatSynRecSelBinds ps fields
768 769
  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
    | fld_lbl <- fields ]
770 771 772 773 774 775

isUnidirectional :: HsPatSynDir a -> Bool
isUnidirectional Unidirectional          = True
isUnidirectional ImplicitBidirectional   = False
isUnidirectional ExplicitBidirectional{} = False

Austin Seipp's avatar
Austin Seipp committed
776 777 778
{-
************************************************************************
*                                                                      *
779
         Constructing the "builder" Id
Austin Seipp's avatar
Austin Seipp committed
780 781 782
*                                                                      *
************************************************************************
-}
783

784
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
785 786
                  -> [TyVarBinder] -> ThetaType
                  -> [TyVarBinder] -> ThetaType
787
                  -> [Type] -> Type
788
                  -> TcM (Maybe (Id, Bool))
789
mkPatSynBuilderId dir (L _ name)
790
                  univ_bndrs req_theta ex_bndrs prov_theta
791
                  arg_tys pat_ty
792 793 794
  | isUnidirectional dir
  = return Nothing
  | otherwise
795
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
796
       ; let theta          = req_theta ++ prov_theta
797
             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
798
             builder_sigma  = add_void need_dummy_arg $
799 800
                              mkForAllTys univ_bndrs $
                              mkForAllTys ex_bndrs $
801 802
                              mkPhiTy theta $
                              mkVisFunTys arg_tys $
803
                              pat_ty
804
             builder_id     = mkExportedVanillaId builder_name builder_sigma
Matthew Pickering's avatar
Matthew Pickering committed
805
              -- See Note [Exported LocalIds] in Id
806

807 808 809
             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id

       ; return (Just (builder_id', need_dummy_arg)) }
810
  where
811

812 813
tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
                    -> TcM (LHsBinds GhcTc)
814
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
815
tcPatSynBuilderBind (PSB { psb_id = L loc name
816 817 818
                         , psb_def = lpat
                         , psb_dir = dir
                         , psb_args = details })
819 820 821
  | isUnidirectional dir
  = return emptyBag

822
  | Left why <- mb_match_group       -- Can't invert the pattern
823
  = setSrcSpan (getLoc lpat) $ failWithTc $
824 825 826 827
    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                 <+> quotes (ppr name) <> colon)
              2 why
         , text "RHS pattern:" <+> ppr lpat ]
828

829
  | Right match_group <- mb_match_group  -- Bidirectional
830
  = do { patsyn <- tcLookupPatSyn name
831 832 833 834 835 836 837 838 839
       ; case patSynBuilder patsyn of {
           Nothing -> return emptyBag ;
             -- This case happens if we found a type error in the
             -- pattern synonym, recovered, and put a placeholder
             -- with patSynBuilder=Nothing in the environment

           Just (builder_id, need_dummy_arg) ->  -- Normal case
    do { -- Bidirectional, so patSynBuilder returns Just
         let match_group' | need_dummy_arg = add_dummy_arg match_group
840 841
                          | otherwise      = match_group

842
             bind = FunBind { fun_ext = placeHolderNamesTc
843
                            , fun_id      = L loc (idName builder_id)
844 845 846 847
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , fun_tick    = [] }

848
             sig = completeSigFromId (PatSynCtxt name) builder_id
849

850 851
       ; traceTc "tcPatSynBuilderBind {" $
         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
852
       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
853
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
854
       ; return builder_binds } } }
855 856

  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
857
  where
858
    mb_match_group
859
       = case dir of
860
           ExplicitBidirectional explicit_mg -> Right explicit_mg
861
           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
862
           Unidirectional -> panic "tcPatSynBuilderBind"
863

864
    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
865
    mk_mg body = mkMatchGroup Generated [builder_match]
866
          where
867 868 869
            builder_args  = [L loc (VarPat noExtField (L loc n))
                            | L loc n <- args]
            builder_match = mkMatch (mkPrefixFunRhs (L loc name))
870
                                    builder_args body
871
                                    (noLoc (EmptyLocalBinds noExtField))
872 873

    args = case details of
874 875 876
              PrefixCon args     -> args
              InfixCon arg1 arg2 -> [arg1, arg2]
              RecCon args        -> map recordPatSynPatVar args
877

878 879
    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
                  -> MatchGroup GhcRn (LHsExpr GhcRn)
880
    add_dummy_arg mg@(MG { mg_alts =
881 882
                           (L l [L loc match@(Match { m_pats = pats })]) })
      = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
883
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
884
                             pprMatches other_mg
885
tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec
886

887
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
888 889
-- monadic only for failure
tcPatSynBuilderOcc ps
890
  | Just (builder_id, add_void_arg) <- builder
891
  , let builder_expr = HsConLikeOut noExtField (PatSynCon ps)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
892 893 894
        builder_ty   = idType builder_id
  = return $
    if add_void_arg
895 896
    then ( builder_expr   -- still just return builder_expr; the void# arg is added
                          -- by dsConLike in the desugarer
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
897 898
         , tcFunResultTy builder_ty )
    else (builder_expr, builder_ty)
899 900

  | otherwise  -- Unidirectional
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
901
  = nonBidirectionalErr name
902 903 904
  where
    name    = patSynName ps
    builder = patSynBuilder ps
cactus's avatar
cactus committed
905

906 907
add_void :: Bool -> Type -> Type
add_void need_dummy_arg ty
908
  | need_dummy_arg = mkVisFunTy voidPrimTy ty
909 910
  | otherwise      = ty

911 912
tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
            -> Either MsgDoc (LHsExpr GhcRn)
913 914 915 916 917 918 919 920
-- Given a /pattern/, return an /expression/ that builds a value
-- that matches the pattern.  E.g. if the pattern is (Just [x]),
-- the expression is (Just [x]).  They look the same, but the
-- input uses constructors from HsPat and the output uses constructors
-- from HsExpr.
--
-- Returns (Left r) if the pattern is not invertible, for reason r.
-- See Note [Builder for a bidirectional pattern synonym]
921
tcPatToExpr name args pat = go pat
922 923 924 925
  where
    lhsVars = mkNameSet (map unLoc args)

    -- Make a prefix con for prefix and infix patterns for simplicity
926 927
    mkPrefixConExpr :: Located Name -> [LPat GhcRn]
                    -> Either MsgDoc (HsExpr GhcRn)
928
    mkPrefixConExpr lcon@(L loc _) pats
929
      = do { exprs <- mapM go pats
930
           ; return (foldl' (\x y -> HsApp noExtField (L loc x) y)
931
                            (HsVar noExtField lcon) exprs) }
932

933 934
    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
                    -> Either MsgDoc (HsExpr GhcRn)
935 936
    mkRecordConExpr con fields
      = do { exprFields <- mapM go fields
937
           ; return (RecordCon noExtField con exprFields) }
938

939
    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
940
    go (L loc p) = L loc <$> go1 p
941

942
    go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
943 944 945 946 947 948
    go1 (ConPatIn con info)
      = case info of
          PrefixCon ps  -> mkPrefixConExpr con ps
          InfixCon l r  -> mkPrefixConExpr con [l,r]
          RecCon fields -> mkRecordConExpr con fields

949
    go1 (SigPat _ pat _) = go1 (unLoc pat)
950 951
        -- See Note [Type signatures and the builder expression]

952
    go1 (VarPat _ (L l var))
953
        | var `elemNameSet` lhsVars
954
        = return $ HsVar noExtField (L l var)
955 956
        | otherwise
        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
957
    go1 (ParPat _ pat)          = fmap (HsPar noExtField) $ go pat
958
    go1 p@(ListPat reb pats)
959
      | Nothing <- reb = do { exprs <- mapM go pats
960
                            ; return $ ExplicitList noExtField Nothing exprs }
961
      | otherwise                   = notInvertibleListPat p
962
    go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
963 964
                                         ; return $ ExplicitTuple noExtField
                                           (map (noLoc . (Present noExtField)) exprs)
965 966
                                                                           box }
    go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)
967
                                         ; return $ ExplicitSum noExtField alt arity
968
                                                                   (noLoc expr)
969
                                         }
970
    go1 (LitPat _ lit)              = return $ HsLit noExtField lit
971
    go1 (NPat _ (L _ n) mb_neg _)
972
        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg
973 974
                                                     [noLoc (HsOverLit noExtField n)]
        | otherwise                 = return $ HsOverLit noExtField n
975 976
    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
    go1 (CoPat{})                   = panic "CoPat in output of renamer"
977
    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
978
                                    = go1 pat
979
    go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
980
    go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"
981 982

    -- The following patterns are not invertible.
983 984 985 986