TcPatSyn.hs 41.2 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

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

8
9
{-# LANGUAGE CPP #-}

10
module TcPatSyn ( tcPatSynSig, tcInferPatSynDecl, tcCheckPatSynDecl
Matthew Pickering's avatar
Matthew Pickering committed
11
                , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
12
  ) where
Gergő Érdi's avatar
Gergő Érdi committed
13
14
15

import HsSyn
import TcPat
16
import TcHsType( tcImplicitTKBndrs, tcExplicitTKBndrs
17
               , tcHsContext, tcHsLiftedType, tcHsOpenType, kindGeneralize )
18
19
import Type( binderVar, mkNamedBinders, binderVisibility
           , tidyTyCoVarBndrs, tidyTypes, tidyType )
Gergő Érdi's avatar
Gergő Érdi committed
20
21
22
23
import TcRnMonad
import TcEnv
import TcMType
import TysPrim
24
import TysWiredIn  ( runtimeRepTy )
Gergő Érdi's avatar
Gergő Érdi committed
25
26
27
28
29
30
31
32
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
33
import VarEnv( emptyTidyEnv )
Gergő Érdi's avatar
Gergő Érdi committed
34
import Id
35
import IdInfo( RecSelParent(..))
Gergő Érdi's avatar
Gergő Érdi committed
36
37
38
import TcBinds
import BasicTypes
import TcSimplify
39
import TcUnify
Gergő Érdi's avatar
Gergő Érdi committed
40
import TcType
41
42
import TcEvidence
import BuildTyCl
Gergő Érdi's avatar
Gergő Érdi committed
43
import VarSet
44
import MkId
45
import TcTyDecls
Matthew Pickering's avatar
Matthew Pickering committed
46
47
import ConLike
import FieldLabel
Gergő Érdi's avatar
Gergő Érdi committed
48
import Bag
49
import Util
50
import ErrUtils
51
52
import Control.Monad ( unless, zipWithM )
import Data.List( partition )
Gergő Érdi's avatar
Gergő Érdi committed
53
54
55

#include "HsVersions.h"

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
{- *********************************************************************
*                                                                      *
        Type checking a pattern synonym signature
*                                                                      *
************************************************************************

Note [Pattern synonym signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example).
In general they look like this:

   pattern P :: forall univ_tvs. req
             => forall ex_tvs. prov
             => arg1 -> .. -> argn -> body_ty

For parsing and renaming we treat the signature as an ordinary LHsSigType.

Once we get to type checking, we decompose it into its parts, in tcPatSynSig.

* Note that 'forall univ_tvs' and 'req =>'
        and 'forall ex_tvs'   and 'prov =>'
  are all optional.  We gather the pieces at the the top of tcPatSynSig

* Initially the implicitly-bound tyvars (added by the renamer) include both
  universal and existential vars.

* After we kind-check the pieces and convert to Types, we do kind generalisation.

* Note [Splitting the implicit tyvars in a pattern synonym]
  Now the tricky bit: we must split
     the implicitly-bound variables, and
     the kind-generalised variables
  into universal and existential.  We do so as follows:

     Note [The pattern-synonym signature splitting rule]
     the universals are the ones mentioned in
          - univ_tvs (and the kinds thereof)
Rik Steenkamp's avatar
Rik Steenkamp committed
93
          - req
94
          - body_ty
Rik Steenkamp's avatar
Rik Steenkamp committed
95
     the existentials are the rest
96
97
98
99
100
101
102
103
104
105
106
107
108
109

* Moreover see Note
-}

tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo
tcPatSynSig name sig_ty
  | HsIB { hsib_vars = implicit_hs_tvs
         , hsib_body = hs_ty }  <- sig_ty
  , (univ_hs_tvs, hs_req,  hs_ty1) <- splitLHsSigmaTy hs_ty
  , (ex_hs_tvs,   hs_prov, hs_ty2) <- splitLHsSigmaTy hs_ty1
  , (hs_arg_tys, hs_body_ty)       <- splitHsFunType  hs_ty2
  = do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty))
           <- solveEqualities $
              tcImplicitTKBndrs implicit_hs_tvs $
110
111
              tcExplicitTKBndrs univ_hs_tvs  $ \ univ_tvs ->
              tcExplicitTKBndrs ex_hs_tvs    $ \ ex_tvs   ->
112
113
114
115
116
117
118
119
120
121
122
123
              do { req     <- tcHsContext hs_req
                 ; prov    <- tcHsContext hs_prov
                 ; arg_tys <- mapM tcHsOpenType (hs_arg_tys :: [LHsType Name])
                 ; body_ty <- tcHsLiftedType hs_body_ty
                 ; let bound_tvs
                         = unionVarSets [ allBoundVariabless req
                                        , allBoundVariabless prov
                                        , allBoundVariabless (body_ty : arg_tys)
                                        ]
                 ; return ( (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty)
                          , bound_tvs) }

124
125
126
127
128
129
130
131
       -- Kind generalisation
       ; kvs <- kindGeneralize $
                mkSpecForAllTys (implicit_tvs ++ univ_tvs) $
                mkFunTys req $
                mkSpecForAllTys ex_tvs $
                mkFunTys prov $
                mkFunTys arg_tys $
                body_ty
132

133
       -- These are /signatures/ so we zonk to squeeze out any kind
134
135
       -- unification variables.  Do this after quantifyTyVars which may
       -- default kind variables to *.
136
       -- ToDo: checkValidType?
137
       ; traceTc "about zonk" empty
138
139
140
141
142
143
144
145
146
147
148
149
150
       ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs
       ; univ_tvs     <- mapM zonkTcTyCoVarBndr univ_tvs
       ; ex_tvs       <- mapM zonkTcTyCoVarBndr ex_tvs
       ; req          <- zonkTcTypes req
       ; prov         <- zonkTcTypes prov
       ; arg_tys      <- zonkTcTypes arg_tys
       ; body_ty      <- zonkTcType  body_ty

       -- Complain about:  pattern P :: () => forall x. x -> P x
       -- The renamer thought it was fine, but the existential 'x'
       -- should not appear in the result type
       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType body_ty) ex_tvs
       ; unless (null bad_tvs) $ addErr $
151
152
         hang (text "The result type" <+> quotes (ppr body_ty))
            2 (text "mentions existential type variable" <> plural bad_tvs
153
154
155
156
157
               <+> pprQuotedList bad_tvs)

         -- Split [Splitting the implicit tyvars in a pattern synonym]
       ; let univ_fvs = closeOverKinds $
                        (tyCoVarsOfTypes (body_ty : req) `extendVarSetList` univ_tvs)
158
159
160
161
             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) .
                                                 binderVar "tcPatSynSig") $
                                      mkNamedBinders Invisible kvs ++
                                      mkNamedBinders Specified implicit_tvs
162
       ; traceTc "tcTySig }" $
163
164
         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
              , text "kvs" <+> ppr_tvs kvs
165
              , text "extra_univ" <+> ppr extra_univ
166
              , text "univ_tvs" <+> ppr_tvs univ_tvs
167
              , text "req" <+> ppr req
168
              , text "extra_ex" <+> ppr extra_ex
169
              , text "ex_tvs" <+> ppr_tvs ex_tvs
170
171
172
173
              , text "prov" <+> ppr prov
              , text "arg_tys" <+> ppr arg_tys
              , text "body_ty" <+> ppr body_ty ]
       ; return (TPSI { patsig_name = name
174
175
176
177
178
179
180
181
                      , patsig_univ_bndrs = extra_univ ++
                                            mkNamedBinders Specified univ_tvs
                      , patsig_req        = req
                      , patsig_ex_bndrs   = extra_ex   ++
                                            mkNamedBinders Specified ex_tvs
                      , patsig_prov       = prov
                      , patsig_arg_tys    = arg_tys
                      , patsig_body_ty    = body_ty }) }
182
183
184
185
186
  where

ppr_tvs :: [TyVar] -> SDoc
ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
                           | tv <- tvs])
187
188


Austin Seipp's avatar
Austin Seipp committed
189
190
191
{-
************************************************************************
*                                                                      *
192
                    Type checking a pattern synonym
Austin Seipp's avatar
Austin Seipp committed
193
194
195
*                                                                      *
************************************************************************
-}
196

197
tcInferPatSynDecl :: PatSynBind Name Name
198
                  -> TcM (LHsBinds Id, TcGblEnv)
199
tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
200
                       psb_def = lpat, psb_dir = dir }
201
  = addPatSynCtxt lname $
202
    do { traceTc "tcInferPatSynDecl {" $ ppr name
203
       ; tcCheckPatSynPat lpat
Gergő Érdi's avatar
Gergő Érdi committed
204

Matthew Pickering's avatar
Matthew Pickering committed
205
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
206
       ; (tclvl, wanted, ((lpat', args), pat_ty))
207
            <- pushLevelAndCaptureConstraints  $
208
209
210
211
212
               do { pat_ty <- newOpenInferExpType
                  ; stuff <- tcPat PatSyn lpat pat_ty $
                             mapM tcLookupId arg_names
                  ; pat_ty <- readExpType pat_ty
                  ; return (stuff, pat_ty) }
213
214

       ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
Gergő Érdi's avatar
Gergő Érdi committed
215

216
       ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
Gergő Érdi's avatar
Gergő Érdi committed
217

218
219
       ; let (ex_vars, prov_dicts) = tcCollectEx lpat'
             univ_tvs   = filter (not . (`elemVarSet` ex_vars)) qtvs
220
221
222
             ex_tvs     = varSetElems ex_vars
             prov_theta = map evVarPred prov_dicts
             req_theta  = map evVarPred req_dicts
Gergő Érdi's avatar
Gergő Érdi committed
223

224
       ; traceTc "tcInferPatSynDecl }" $ ppr name
225
226
227
228
229
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, mkNamedBinders Invisible univ_tvs
                            , req_theta,  ev_binds, req_dicts)
                          (ex_tvs,   mkNamedBinders Invisible ex_tvs
                            , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
230
                          (map nlHsVar args, map idType args)
Matthew Pickering's avatar
Matthew Pickering committed
231
232
                          pat_ty rec_fields }

233
234
235

tcCheckPatSynDecl :: PatSynBind Name Name
                  -> TcPatSynInfo
236
                  -> TcM (LHsBinds Id, TcGblEnv)
237
238
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                         , psb_def = lpat, psb_dir = dir }
239
240
241
                  TPSI{ patsig_univ_bndrs = univ_bndrs, patsig_prov = prov_theta
                      , patsig_ex_bndrs   = ex_bndrs,   patsig_req  = req_theta
                      , patsig_arg_tys    = arg_tys,    patsig_body_ty = pat_ty }
242
  = addPatSynCtxt lname $
243
    do { let decl_arity = length arg_names
244
245
246
             ty_arity   = length arg_tys
             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

247
248
249
             univ_tvs   = map (binderVar "tcCheckPatSynDecl 1") univ_bndrs
             ex_tvs     = map (binderVar "tcCheckPatSynDecl 2") ex_bndrs

250
       ; traceTc "tcCheckPatSynDecl" $
251
         vcat [ ppr univ_bndrs, ppr req_theta, ppr ex_bndrs
252
253
254
255
256
              , ppr prov_theta, ppr arg_tys, ppr pat_ty ]

       ; checkTc (decl_arity == ty_arity)
                 (wrongNumberOfParmsErr name decl_arity ty_arity)

257
258
       ; tcCheckPatSynPat lpat

259
260
       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
261
       ; req_dicts <- newEvVars req_theta
262
263
       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
264
265
266
           pushLevelAndCaptureConstraints            $
           tcExtendTyVarEnv univ_tvs                 $
           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
267
268
269
           do { (subst, ex_tvs') <- if   isUnidirectional dir
                                    then newMetaTyVars    ex_tvs
                                    else newMetaSigTyVars ex_tvs
Rik Steenkamp's avatar
Rik Steenkamp committed
270
                    -- See the "Existential type variables" part of
271
                    -- Note [Checking against a pattern signature]
272
273
              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
274
275
              ; let prov_theta' = substTheta (extendTCvInScopeList subst univ_tvs) prov_theta
                  -- Add univ_tvs to the in_scope set to
276
277
278
279
                  -- satisfy the substition invariant. There's no need to
                  -- add 'ex_tvs' as they are already in the domain of the
                  -- substitution.
                  -- See also Note [The substitution invariant] in TyCoRep.
280
              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
281
282
283
              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
              ; return (ex_tvs', prov_dicts, args') }

284
285
286
287
       ; let skol_info = SigSkol (PatSynCtxt name) (mkPhiTy req_theta pat_ty)
                         -- The type here is a bit bogus, but we do not print
                         -- the type for PatSynCtxt, so it doesn't matter
                         -- See TcRnTypes Note [Skolem info for pattern synonyms]
288
       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
289

290
291
292
       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (Trac #10997)
       -- Since all the inputs are implications the returned bindings will be empty
293
       ; _ <- simplifyTop (mkImplicWC implics)
294
295
296
297

       -- 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
298

299
       ; traceTc "tcCheckPatSynDecl }" $ ppr name
300
301
302
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, univ_bndrs, req_theta, ev_binds, req_dicts)
                          (ex_tvs, ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
303
                          (args', arg_tys)
304
                          pat_ty rec_fields }
305
  where
306
307
308
309
310
311
312
    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId)
    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
           ; coi <- unifyType (Just arg_id)
                              (idType arg_id)
313
                              (substTyUnchecked subst arg_ty)
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
           ; return (mkLHsWrapCo coi $ nlHsVar arg_id) }

{- Note [Checking against a pattern signature]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
331
332
make available to matches against P), is derivable from the
actual pattern.  For example:
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
    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

This "concealing" story works for /uni-directional/ pattern synonmys,
but obviously not for bidirectional ones.  So in the bidirectional case
we use SigTv, rather than a generic TauTv, meta-tyvar so that.  And
we should really check that those SigTvs don't get unified with each
other.

-}
364

Matthew Pickering's avatar
Matthew Pickering committed
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo details =
  case details of
    PrefixPatSyn names      -> (map unLoc names, [], False)
    InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
    RecordPatSyn names ->
      let (vars, sels) = unzip (map splitRecordPatSyn names)
      in (vars, sels, False)

  where
    splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
    splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
                                         , recordPatSynSelectorId = L _ selId })
      = (patVar, selId)

380
381
382
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L loc name) thing_inside
  = setSrcSpan loc $
383
    addErrCtxt (text "In the declaration for pattern synonym"
384
385
386
387
388
                <+> quotes (ppr name)) $
    thing_inside

wrongNumberOfParmsErr :: Name -> Arity -> Arity -> SDoc
wrongNumberOfParmsErr name decl_arity ty_arity
389
  = hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
390
391
          <+> speakNOf decl_arity (text "argument"))
       2 (text "but its type signature has" <+> speakN ty_arity)
392

393
394
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
Matthew Pickering's avatar
Matthew Pickering committed
395
396
397
398
tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
                 -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                 -> Bool              -- ^ Whether infix
                 -> LPat Id           -- ^ Pattern of the PatSyn
399
400
                 -> ([TcTyVar], [TcTyBinder], [PredType], TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcTyBinder], [TcType], [PredType], [EvTerm])
401
                 -> ([LHsExpr TcId], [TcType])   -- ^ Pattern arguments and types
Matthew Pickering's avatar
Matthew Pickering committed
402
403
404
                 -> TcType              -- ^ Pattern type
                 -> [Name]              -- ^ Selector names
                 -- ^ Whether fields, empty if not record PatSyn
405
                 -> TcM (LHsBinds Id, TcGblEnv)
406
407
408
tc_patsyn_finish lname dir is_infix lpat'
                 (univ_tvs, univ_bndrs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_bndrs, ex_tys, prov_theta, prov_dicts)
409
                 (args, arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
410
                 pat_ty field_labels
411
412
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there
413
414
         univ_tvs'    <- mapMaybeM (zonkQuantifiedTyVar False) univ_tvs
       ; ex_tvs'      <- mapMaybeM (zonkQuantifiedTyVar False) ex_tvs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
415
416
                         -- ToDo: The False means that we behave here as if
                         -- -XPolyKinds was always on, which isn't right.
417
418
419
420
421
422
423
424
425
426
427
       ; prov_theta'  <- zonkTcTypes prov_theta
       ; req_theta'   <- zonkTcTypes req_theta
       ; pat_ty'      <- zonkTcType pat_ty
       ; arg_tys'     <- zonkTcTypes arg_tys

       ; let (env1, univ_tvs) = tidyTyCoVarBndrs emptyTidyEnv univ_tvs'
             (env2, ex_tvs)   = tidyTyCoVarBndrs env1 ex_tvs'
             req_theta  = tidyTypes env2 req_theta'
             prov_theta = tidyTypes env2 prov_theta'
             arg_tys    = tidyTypes env2 arg_tys'
             pat_ty     = tidyType  env2 pat_ty'
428

429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
          -- We need to update the univ and ex binders after zonking.
          -- But zonking may have defaulted some erstwhile binders,
          -- so we need to make sure the tyvars and tybinders remain
          -- lined up
       ; let update_binders :: [TyVar] -> [TcTyBinder] -> [TyBinder]
             update_binders [] _ = []
             update_binders all_tvs@(tv:tvs) (bndr:bndrs)
               | tv == bndr_var
               = mkNamedBinder (binderVisibility bndr) tv : update_binders tvs bndrs
               | otherwise
               = update_binders all_tvs bndrs
               where
                 bndr_var = binderVar "tc_patsyn_finish" bndr
             update_binders tvs _ = pprPanic "tc_patsyn_finish" (ppr lname $$ ppr tvs)

             univ_bndrs' = update_binders univ_tvs univ_bndrs
             ex_bndrs'   = update_binders ex_tvs   ex_bndrs

447
       ; traceTc "tc_patsyn_finish {" $
448
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
449
450
           ppr (univ_tvs, univ_bndrs', req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, ex_bndrs', prov_theta, prov_dicts) $$
451
452
           ppr args $$
           ppr arg_tys $$
453
           ppr pat_ty
454
455

       -- Make the 'matcher'
456
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
457
                                         (univ_tvs, req_theta, req_ev_binds, req_dicts)
458
459
                                         (ex_tvs, ex_tys, prov_theta, prov_dicts)
                                         (args, arg_tys)
Gergő Érdi's avatar
Gergő Érdi committed
460
                                         pat_ty
461

Matthew Pickering's avatar
Matthew Pickering committed
462

463
       -- Make the 'builder'
464
465
466
       ; builder_id <- mkPatSynBuilderId dir lname
                                         univ_bndrs' req_theta
                                         ex_bndrs'   prov_theta
Matthew Pickering's avatar
Matthew Pickering committed
467
                                         arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
468
469
470
471
472

         -- TODO: Make this have the proper information
       ; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
             field_labels' = (map mkFieldLabel field_labels)

Gergő Érdi's avatar
Gergő Érdi committed
473

474
       -- Make the PatSyn itself
Matthew Pickering's avatar
Matthew Pickering committed
475
       ; let patSyn = mkPatSyn (unLoc lname) is_infix
476
477
                        (univ_tvs, univ_bndrs', req_theta)
                        (ex_tvs, ex_bndrs', prov_theta)
478
                        arg_tys
Gergő Érdi's avatar
Gergő Érdi committed
479
                        pat_ty
480
                        matcher_id builder_id
Matthew Pickering's avatar
Matthew Pickering committed
481
482
483
484
485
486
487
488
489
490
491
                        field_labels'

       -- Selectors
       ; let (sigs, selector_binds) =
                unzip (mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn))
       ; let tything = AConLike (PatSynCon patSyn)
       ; tcg_env <-
          tcExtendGlobalEnv [tything] $
            tcRecSelBinds
              (ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs)

492
       ; traceTc "tc_patsyn_finish }" empty
493
       ; return (matcher_bind, tcg_env) }
494

Austin Seipp's avatar
Austin Seipp committed
495
496
497
{-
************************************************************************
*                                                                      *
498
         Constructing the "matcher" Id and its binding
Austin Seipp's avatar
Austin Seipp committed
499
500
501
*                                                                      *
************************************************************************
-}
502

503
tcPatSynMatcher :: Located Name
Gergő Érdi's avatar
Gergő Érdi committed
504
                -> LPat Id
505
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
506
507
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                -> ([LHsExpr TcId], [TcType])
Gergő Érdi's avatar
Gergő Érdi committed
508
                -> TcType
509
510
                -> TcM ((Id, Bool), LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
511
tcPatSynMatcher (L loc name) lpat
512
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
513
514
                (ex_tvs, ex_tys, prov_theta, prov_dicts)
                (args, arg_tys) pat_ty
515
516
517
  = do { rr_uniq <- newUnique
       ; tv_uniq <- newUnique
       ; let rr_name  = mkInternalName rr_uniq (mkTyVarOcc "rep") loc
518
             tv_name  = mkInternalName tv_uniq (mkTyVarOcc "r") loc
519
520
521
             rr_tv    = mkTcTyVar rr_name runtimeRepTy (SkolemTv False)
             rr       = mkTyVarTy rr_tv
             res_tv   = mkTcTyVar tv_name  (tYPE rr) (SkolemTv False)
522
             is_unlifted = null args && null prov_dicts
523
             res_ty = mkTyVarTy res_tv
524
525
526
             (cont_args, cont_arg_tys)
               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
               | otherwise   = (args,                 arg_tys)
527
             cont_ty = mkInvSigmaTy ex_tvs prov_theta $
528
529
                       mkFunTys cont_arg_tys res_ty

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
530
             fail_ty  = mkFunTy voidPrimTy res_ty
531

532
       ; matcher_name <- newImplicitBinder name mkMatcherOcc
533
534
535
536
537
       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty

       ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
538
             matcher_sigma = mkInvSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
539
             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
540
                             -- See Note [Exported LocalIds] in Id
541

542
543
             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
             cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
Gergő Érdi's avatar
Gergő Érdi committed
544

545
             fail' = nlHsApps fail [nlHsVar voidPrimId]
Gergő Érdi's avatar
Gergő Érdi committed
546

547
             args = map nlVarPat [scrutinee, cont, fail]
Gergő Érdi's avatar
Gergő Érdi committed
548
549
550
551
552
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
                     then [mkSimpleHsAlt lpat  cont']
                     else [mkSimpleHsAlt lpat  cont',
                           mkSimpleHsAlt lwpat fail']
553
             body = mkLHsWrap (mkWpLet req_ev_binds) $
Gergő Érdi's avatar
Gergő Érdi committed
554
555
                    L (getLoc lpat) $
                    HsCase (nlHsVar scrutinee) $
556
                    MG{ mg_alts = L (getLoc lpat) cases
Gergő Érdi's avatar
Gergő Érdi committed
557
558
                      , mg_arg_tys = [pat_ty]
                      , mg_res_ty = res_ty
559
                      , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
560
561
562
                      }
             body' = noLoc $
                     HsLam $
563
                     MG{ mg_alts = noLoc [mkSimpleMatch args body]
Gergő Érdi's avatar
Gergő Érdi committed
564
565
                       , mg_arg_tys = [pat_ty, cont_ty, res_ty]
                       , mg_res_ty = res_ty
566
                       , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
567
                       }
568
             match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body')
569
570
                             (noLoc EmptyLocalBinds)
             mg = MG{ mg_alts = L (getLoc match) [match]
Gergő Érdi's avatar
Gergő Érdi committed
571
572
                    , mg_arg_tys = []
                    , mg_res_ty = res_ty
573
                    , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
574
575
                    }

576
       ; let bind = FunBind{ fun_id = L loc matcher_id
Gergő Érdi's avatar
Gergő Érdi committed
577
578
579
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
                           , bind_fvs = emptyNameSet
580
                           , fun_tick = [] }
581
             matcher_bind = unitBag (noLoc bind)
Gergő Érdi's avatar
Gergő Érdi committed
582

583
       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
Gergő Érdi's avatar
Gergő Érdi committed
584
585
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

586
587
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
588
589
590
591
mkPatSynRecSelBinds :: PatSyn
                    -> [FieldLabel]
                    -- ^ Visible field labels
                    -> [(LSig Name, LHsBinds Name)]
592
593
594
595
596
mkPatSynRecSelBinds ps fields = map mkRecSel fields
  where
    mkRecSel fld_lbl =
      case mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl of
        (name, (_rec_flag, binds)) -> (name, binds)
597
598
599
600
601
602

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

Austin Seipp's avatar
Austin Seipp committed
603
604
605
{-
************************************************************************
*                                                                      *
606
         Constructing the "builder" Id
Austin Seipp's avatar
Austin Seipp committed
607
608
609
*                                                                      *
************************************************************************
-}
610

611
612
613
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
                  -> [TyBinder] -> ThetaType
                  -> [TyBinder] -> ThetaType
614
                  -> [Type] -> Type
615
                  -> TcM (Maybe (Id, Bool))
616
617
mkPatSynBuilderId dir (L _ name)
                  univ_bndrs req_theta ex_bndrs prov_theta
618
                  arg_tys pat_ty
619
620
621
  | isUnidirectional dir
  = return Nothing
  | otherwise
622
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
623
       ; let theta          = req_theta ++ prov_theta
624
             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
625
             builder_sigma  = add_void need_dummy_arg $
626
627
628
629
630
                              mkForAllTys univ_bndrs $
                              mkForAllTys ex_bndrs $
                              mkFunTys theta $
                              mkFunTys arg_tys $
                              pat_ty
631
             builder_id     = mkExportedVanillaId builder_name builder_sigma
Matthew Pickering's avatar
Matthew Pickering committed
632
              -- See Note [Exported LocalIds] in Id
633

634
       ; return (Just (builder_id, need_dummy_arg)) }
635
  where
636

637
638
tcPatSynBuilderBind :: TcSigFun
                    -> PatSynBind Name Name
639
640
                    -> TcM (LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
641
642
tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat
                               , psb_dir = dir, psb_args = details }
643
644
645
  | isUnidirectional dir
  = return emptyBag

646
  | Left why <- mb_match_group       -- Can't invert the pattern
647
  = setSrcSpan (getLoc lpat) $ failWithTc $
648
649
650
651
    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                 <+> quotes (ppr name) <> colon)
              2 why
         , text "RHS pattern:" <+> ppr lpat ]
652

653
  | Right match_group <- mb_match_group  -- Bidirectional
654
  = do { patsyn <- tcLookupPatSyn name
655
       ; traceTc "tcPatSynBuilderBind {" $ ppr patsyn
656
       ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
657
658
659
660
661
                   -- Bidirectional, so patSynBuilder returns Just

             match_group' | need_dummy_arg = add_dummy_arg match_group
                          | otherwise      = match_group

662
             bind = FunBind { fun_id      = L loc (idName builder_id)
663
664
665
666
667
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , bind_fvs    = placeHolderNamesTc
                            , fun_tick    = [] }

668
       ; sig <- get_builder_sig sig_fun name builder_id need_dummy_arg
669

670
       ; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind)
671
672
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
       ; return builder_binds }
673
674

  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
675
  where
676
    mb_match_group
677
       = case dir of
678
           ExplicitBidirectional explicit_mg -> Right explicit_mg
679
           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)
680
           Unidirectional -> panic "tcPatSynBuilderBind"
681
682

    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
683
    mk_mg body = mkMatchGroupName Generated [builder_match]
684
             where
685
               builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
686
               builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds)
687
688

    args = case details of
689
              PrefixPatSyn args     -> args
690
              InfixPatSyn arg1 arg2 -> [arg1, arg2]
Matthew Pickering's avatar
Matthew Pickering committed
691
              RecordPatSyn args     -> map recordPatSynPatVar args
692

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
693
694
    add_dummy_arg :: MatchGroup Name (LHsExpr Name)
                  -> MatchGroup Name (LHsExpr Name)
695
696
    add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })
      = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
697
698
699
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
                             pprMatches (PatSyn :: HsMatchContext Name) other_mg

700
701
702
get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo
get_builder_sig sig_fun name builder_id need_dummy_arg
  | Just (TcPatSynSig sig) <- sig_fun name
703
704
705
706
707
708
  , TPSI { patsig_univ_bndrs = univ_bndrs
         , patsig_req        = req
         , patsig_ex_bndrs   = ex_bndrs
         , patsig_prov       = prov
         , patsig_arg_tys    = arg_tys
         , patsig_body_ty    = body_ty } <- sig
709
710
711
712
713
714
715
  = -- Constuct a TcIdSigInfo from a TcPatSynInfo
    -- This does unfortunately mean that we have to know how to
    -- make the builder Id's type from the TcPatSynInfo, which
    -- duplicates the construction in mkPatSynBuilderId
    -- But we really want to use the scoped type variables from
    -- the actual sigature, so this is really the Right Thing
    return (TISI { sig_bndr  = CompleteSig builder_id
716
717
718
                 , sig_skols = [ (tyVarName tv, tv)
                               | bndr <- univ_bndrs ++ ex_bndrs
                               , let tv = binderVar "get_builder_sig" bndr ]
719
720
721
                 , sig_theta = req ++ prov
                 , sig_tau   = add_void need_dummy_arg $
                               mkFunTys arg_tys body_ty
722
                 , sig_ctxt  = PatSynCtxt name
723
724
725
726
727
728
                 , sig_loc   = getSrcSpan name })
  | otherwise
  = -- No signature, so fake up a TcIdSigInfo from the builder Id
    instTcTySigFromId builder_id
    -- See Note [Redundant constraints for builder]

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
729
730
731
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)
-- monadic only for failure
tcPatSynBuilderOcc ps
732
  | Just (builder_id, add_void_arg) <- builder
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
733
734
735
736
737
738
739
  , let builder_expr = HsVar (noLoc builder_id)
        builder_ty   = idType builder_id
  = return $
    if add_void_arg
    then ( HsApp (noLoc $ builder_expr) (nlHsVar voidPrimId)
         , tcFunResultTy builder_ty )
    else (builder_expr, builder_ty)
740
741

  | otherwise  -- Unidirectional
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
742
  = nonBidirectionalErr name
743
744
745
  where
    name    = patSynName ps
    builder = patSynBuilder ps
Gergő Érdi's avatar
Gergő Érdi committed
746

747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
add_void :: Bool -> Type -> Type
add_void need_dummy_arg ty
  | need_dummy_arg = mkFunTy voidPrimTy ty
  | otherwise      = ty

tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name)
-- 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]
tcPatToExpr args pat = go pat
  where
    lhsVars = mkNameSet (map unLoc args)

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

    mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name)
                    -> Either MsgDoc (HsExpr Name)
    mkRecordConExpr con fields
      = do { exprFields <- mapM go fields
           ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }

    go :: LPat Name -> Either MsgDoc (LHsExpr Name)
    go (L loc p) = L loc <$> go1 p

    go1 :: Pat Name -> Either MsgDoc (HsExpr Name)
    go1 (ConPatIn con info)
      = case info of
          PrefixCon ps  -> mkPrefixConExpr con ps
          InfixCon l r  -> mkPrefixConExpr con [l,r]
          RecCon fields -> mkRecordConExpr con fields

    go1 (SigPatIn pat _) = go1 (unLoc pat)
        -- See Note [Type signatures and the builder expression]

    go1 (VarPat (L l var))
        | var `elemNameSet` lhsVars
        = return $ HsVar (L l var)
        | otherwise
        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
    go1 (ParPat pat)                = fmap HsPar $ go pat
    go1 (LazyPat pat)               = go1 (unLoc pat)
    go1 (BangPat pat)               = go1 (unLoc pat)
    go1 (PArrPat pats ptt)          = do { exprs <- mapM go pats
                                         ; return $ ExplicitPArr ptt exprs }
    go1 (ListPat pats ptt reb)      = do { exprs <- mapM go pats
                                         ; return $ ExplicitList ptt (fmap snd reb) exprs }
    go1 (TuplePat pats box _)       = do { exprs <- mapM go pats
                                         ; return $ ExplicitTuple
                                              (map (noLoc . Present) exprs) box }
    go1 (LitPat lit)                = return $ HsLit lit
    go1 (NPat (L _ n) mb_neg _ _)
        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
        | otherwise                 = return $ HsOverLit n
    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
    go1 (SigPatOut{})               = panic "SigPatOut in output of renamer"
    go1 (CoPat{})                   = panic "CoPat in output of renamer"
    go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")

{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For a bidirectional pattern synonym we need to produce an /expression/
that matches the supplied /pattern/, given values for the arguments
of the pattern synoymy.  For example
  pattern F x y = (Just x, [y])
The 'builder' for F looks like
  $builderF x y = (Just x, [y])

We can't always do this:
 * Some patterns aren't invertible; e.g. view patterns
      pattern F x = (reverse -> x:_)

 * The RHS pattern might bind more variables than the pattern
   synonym, so again we can't invert it
      pattern F x = (x,y)

 * Ditto wildcards
      pattern F x = (x,_)


836
837
838
839
840
841
Note [Redundant constraints for builder]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The builder can have redundant constraints, which are awkard to eliminate.
Consider
   pattern P = Just 34
To match against this pattern we need (Eq a, Num a).  But to build
842
843
(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
sig_warn_redundant to False.
844

Austin Seipp's avatar
Austin Seipp committed
845
846
************************************************************************
*                                                                      *
847
         Helper functions
Austin Seipp's avatar
Austin Seipp committed
848
849
*                                                                      *
************************************************************************
850

851
852
Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
853
854
855
The rationale for rejecting as-patterns in pattern synonym definitions
is that an as-pattern would introduce nonindependent pattern synonym
arguments, e.g. given a pattern synonym like:
856
857
858
859
860
861

        pattern K x y = x@(Just y)

one could write a nonsensical function like

        f (K Nothing x) = ...
Gergő Érdi's avatar
Gergő Érdi committed
862

863
864
or
        g (K (Just True) False) = ...
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884

Note [Type signatures and the builder expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   pattern L x = Left x :: Either [a] [b]

In tc{Infer/Check}PatSynDecl we will check that the pattern has the
specified type.  We check the pattern *as a pattern*, so the type
signature is a pattern signature, and so brings 'a' and 'b' into
scope.  But we don't have a way to bind 'a, b' in the LHS, as we do
'x', say.  Nevertheless, the sigature may be useful to constrain
the type.

When making the binding for the *builder*, though, we don't want
  $buildL x = Left x :: Either [a] [b]
because that wil either mean (forall a b. Either [a] [b]), or we'll
get a complaint that 'a' and 'b' are out of scope. (Actually the
latter; Trac #9867.)  No, the job of the signature is done, so when
converting the pattern to an expression (for the builder RHS) we
simply discard the signature.
Matthew Pickering's avatar
Matthew Pickering committed
885
886
887
888
889
890
891
892

Note [Record PatSyn Desugaring]
-------------------------------
It is important that prov_theta comes before req_theta as this ordering is used
when desugaring record pattern synonym updates.

Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
want to avoid difficult to decipher core lint errors!
893
 -}
894

895
896
897
898
899
900
901
902
903
904
tcCheckPatSynPat :: LPat Name -> TcM ()
tcCheckPatSynPat = go
  where
    go :: LPat Name -> TcM ()
    go = addLocM go1

    go1 :: Pat Name -> TcM ()
    go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)
    go1   VarPat{}            = return ()
    go1   WildPat{}           = return ()
905
    go1 p@(AsPat _ _)         = asPatInPatSynErr p
906
907
908
909
910
911
    go1   (LazyPat pat)       = go pat
    go1   (ParPat pat)        = go pat
    go1   (BangPat pat)       = go pat
    go1   (PArrPat pats _)    = mapM_ go pats
    go1   (ListPat pats _ _)  = mapM_ go pats
    go1   (TuplePat pats _ _) = mapM_ go pats
912
913
    go1   LitPat{}            = return ()
    go1   NPat{}              = return ()
914
915
916
917
918
919
920
921
922
923
924
    go1   (SigPatIn pat _)    = go pat
    go1   (ViewPat _ pat _)   = go pat
    go1 p@SplicePat{}         = thInPatSynErr p
    go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p
    go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
    go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
    go1   CoPat{}             = panic "CoPat in output of renamer"

asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
asPatInPatSynErr pat
  = failWithTc $
925
    hang (text "Pattern synonym definition cannot contain as-patterns (@):")
926
927
928
929
930
       2 (ppr pat)

thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
thInPatSynErr pat
  = failWithTc $
931
    hang (text "Pattern synonym definition cannot contain Template Haskell:")
932
933
934
935
936
       2 (ppr pat)

nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
nPlusKPatInPatSynErr pat
  = failWithTc $
937
    hang (text "Pattern synonym definition cannot contain n+k-pattern:")
938
939
       2 (ppr pat)

Matthew Pickering's avatar
Matthew Pickering committed
940
941
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
942
943
    text "non-bidirectional pattern synonym"
    <+> quotes (ppr name) <+> text "used in an expression"
Matthew Pickering's avatar
Matthew Pickering committed
944

945
946
947
948
949
950
-- Walk the whole pattern and for all ConPatOuts, collect the
-- existentially-bound type variables and evidence binding variables.
--
-- These are used in computing the type of a pattern synonym and also
-- in generating matcher functions, since success continuations need
-- to be passed these pattern-bound evidences.
951
952
tcCollectEx :: LPat Id -> (TyVarSet, [EvVar])
tcCollectEx pat = go pat
Gergő Érdi's avatar
Gergő Érdi committed
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
  where
    go :: LPat Id -> (TyVarSet, [EvVar])
    go = go1 . unLoc

    go1 :: Pat Id -> (TyVarSet, [EvVar])
    go1 (LazyPat p)         = go p
    go1 (AsPat _ p)         = go p
    go1 (ParPat p)          = go p
    go1 (BangPat p)         = go p
    go1 (ListPat ps _ _)    = mconcat . map go $ ps
    go1 (TuplePat ps _ _)   = mconcat . map go $ ps
    go1 (PArrPat ps _)      = mconcat . map go $ ps
    go1 (ViewPat _ p _)     = go p
    go1 con@ConPatOut{}     = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
                                 goConDetails $ pat_args con
    go1 (SigPatOut p _)     = go p
    go1 (CoPat _ p _)       = go1 p
970
    go1 (NPlusKPat n k _ geq subtract _)
Gergő Érdi's avatar
Gergő Érdi committed
971
972
973
974
975
976
977
978
979
      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
    go1 _                   = mempty

    goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
    goConDetails (PrefixCon ps) = mconcat . map go $ ps
    goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
    goConDetails (RecCon HsRecFields{ rec_flds = flds })
      = mconcat . map goRecFd $ flds

980
981
    goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p