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

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 ( 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
16
17
18
19

import HsSyn
import TcPat
import TcRnMonad
import TcEnv
import TcMType
import TysPrim
Matthew Pickering's avatar
Matthew Pickering committed
20
import TypeRep
Gergő Érdi's avatar
Gergő Érdi committed
21
22
23
24
25
26
27
28
29
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
import Id
Matthew Pickering's avatar
Matthew Pickering committed
30
import IdInfo( IdDetails(..), RecSelParent(..))
Gergő Érdi's avatar
Gergő Érdi committed
31
32
33
import TcBinds
import BasicTypes
import TcSimplify
34
import TcUnify
Gergő Érdi's avatar
Gergő Érdi committed
35
import TcType
36
37
import TcEvidence
import BuildTyCl
Gergő Érdi's avatar
Gergő Érdi committed
38
import VarSet
39
import MkId
40
41
import VarEnv
import Inst
42
import TcTyDecls
Matthew Pickering's avatar
Matthew Pickering committed
43
44
import ConLike
import FieldLabel
45
#if __GLASGOW_HASKELL__ < 709
Gergő Érdi's avatar
Gergő Érdi committed
46
import Data.Monoid
47
#endif
Gergő Érdi's avatar
Gergő Érdi committed
48
import Bag
49
import Util
50
import Data.Maybe
51
import Control.Monad (forM)
Gergő Érdi's avatar
Gergő Érdi committed
52
53
54

#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
55
56
57
{-
************************************************************************
*                                                                      *
58
                    Type checking a pattern synonym
Austin Seipp's avatar
Austin Seipp committed
59
60
61
*                                                                      *
************************************************************************
-}
62

63
tcInferPatSynDecl :: PatSynBind Name Name
Matthew Pickering's avatar
Matthew Pickering committed
64
                  -> TcM (PatSyn, LHsBinds Id, TcGblEnv)
65
66
67
68
tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
                       psb_def = lpat, psb_dir = dir }
  = setSrcSpan loc $
    do { traceTc "tcInferPatSynDecl {" $ ppr name
69
       ; tcCheckPatSynPat lpat
Gergő Érdi's avatar
Gergő Érdi committed
70

Matthew Pickering's avatar
Matthew Pickering committed
71
72
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

73
74
       ; ((lpat', (args, pat_ty)), tclvl, wanted)
            <- pushLevelAndCaptureConstraints  $
75
76
77
78
79
80
               do { pat_ty <- newFlexiTyVarTy openTypeKind
                  ; tcPat PatSyn lpat pat_ty $
               do { args <- mapM tcLookupId arg_names
                  ; return (args, pat_ty) } }

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

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

       ; (ex_vars, prov_dicts) <- tcCollectEx lpat'
85
86
87
88
       ; let univ_tvs   = filter (not . (`elemVarSet` ex_vars)) qtvs
             ex_tvs     = varSetElems ex_vars
             prov_theta = map evVarPred prov_dicts
             req_theta  = map evVarPred req_dicts
Gergő Érdi's avatar
Gergő Érdi committed
89

90
91
92
93
94
       ; traceTc "tcInferPatSynDecl }" $ ppr name
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, req_theta, ev_binds, req_dicts)
                          (ex_tvs, map mkTyVarTy ex_tvs, prov_theta, emptyTcEvBinds, prov_dicts)
                          (zip args $ repeat idHsWrapper)
Matthew Pickering's avatar
Matthew Pickering committed
95
96
                          pat_ty rec_fields }

97
98
99

tcCheckPatSynDecl :: PatSynBind Name Name
                  -> TcPatSynInfo
Matthew Pickering's avatar
Matthew Pickering committed
100
                  -> TcM (PatSyn, LHsBinds Id, TcGblEnv)
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
                       psb_def = lpat, psb_dir = dir }
                  TPSI{ patsig_tau = tau,
                        patsig_ex = ex_tvs, patsig_univ = univ_tvs,
                        patsig_prov = prov_theta, patsig_req = req_theta }
  = setSrcSpan loc $
    do { traceTc "tcCheckPatSynDecl" $
         ppr (ex_tvs, prov_theta) $$
         ppr (univ_tvs, req_theta) $$
         ppr arg_tys $$
         ppr tau
       ; tcCheckPatSynPat lpat

       ; req_dicts <- newEvVars req_theta

       -- TODO: find a better SkolInfo
117
       ; let skol_info = SigSkol (PatSynCtxt name) (mkFunTys arg_tys pat_ty)
118

Matthew Pickering's avatar
Matthew Pickering committed
119
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
120
121
122
123
124
125
126
127
128
129
130
131
132

       ; let ty_arity = length arg_tys
       ; checkTc (length arg_names == ty_arity)
                 (wrongNumberOfParmsErr ty_arity)

         -- Typecheck the pattern against pat_ty, then unify the type of args
         -- against arg_tys, with ex_tvs changed to SigTyVars.
         -- We get out of this:
         --  * The evidence bindings for the requested theta: req_ev_binds
         --  * The typechecked pattern: lpat'
         --  * The arguments, type-coerced to the SigTyVars: wrapped_args
         --  * The instantiation of ex_tvs to pass to the success continuation: ex_tys
         --  * The provided theta substituted with the SigTyVars: prov_theta'
133
134
       ; (implic1, req_ev_binds, (lpat', (ex_tys, prov_theta', wrapped_args))) <-
           buildImplication skol_info univ_tvs req_dicts $
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
           tcPat PatSyn lpat pat_ty $ do
           { ex_sigtvs <- mapM (\tv -> newSigTyVar (getName tv) (tyVarKind tv)) ex_tvs
           ; let subst = mkTvSubst (mkInScopeSet (zipVarEnv ex_sigtvs ex_sigtvs)) $
                         zipTyEnv ex_tvs (map mkTyVarTy ex_sigtvs)
           ; let ex_tys = substTys subst $ map mkTyVarTy ex_tvs
                 prov_theta' = substTheta subst prov_theta
           ; wrapped_args <- forM (zipEqual "tcCheckPatSynDecl" arg_names arg_tys) $ \(arg_name, arg_ty) -> do
               { arg <- tcLookupId arg_name
               ; let arg_ty' = substTy subst arg_ty
               ; coi <- unifyType (varType arg) arg_ty'
               ; return (setVarType arg arg_ty, coToHsWrapper coi) }
           ; return (ex_tys, prov_theta', wrapped_args) }

       ; (ex_vars_rhs, prov_dicts_rhs) <- tcCollectEx lpat'
       ; let ex_tvs_rhs  = varSetElems ex_vars_rhs

         -- Check that prov_theta' can be satisfied with the dicts from the pattern
152
153
       ; (implic2, prov_ev_binds, prov_dicts) <-
           buildImplication skol_info ex_tvs_rhs prov_dicts_rhs $ do
154
155
156
           { let origin = PatOrigin -- TODO
           ; emitWanteds origin prov_theta' }

157
158
159
160
161
       -- 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
       ; _ <- simplifyTop (emptyWC `addImplics` (implic1 `unionBags` implic2))

162
163
164
165
166
       ; traceTc "tcCheckPatSynDecl }" $ ppr name
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, req_theta, req_ev_binds, req_dicts)
                          (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
                          wrapped_args
Matthew Pickering's avatar
Matthew Pickering committed
167
                          pat_ty rec_fields  }
168
169
170
  where
    (arg_tys, pat_ty) = tcSplitFunTys tau

Matthew Pickering's avatar
Matthew Pickering committed
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
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)

186
187
188
189
190
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr ty_arity
  = ptext (sLit "Number of pattern synonym arguments doesn't match type; expected")
    <+> ppr ty_arity

191
192
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
Matthew Pickering's avatar
Matthew Pickering committed
193
194
195
196
tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
                 -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                 -> Bool              -- ^ Whether infix
                 -> LPat Id           -- ^ Pattern of the PatSyn
197
198
                 -> ([TcTyVar], [PredType], TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcType], [PredType], TcEvBinds, [EvVar])
Matthew Pickering's avatar
Matthew Pickering committed
199
200
201
202
203
                 -> [(Var, HsWrapper)]  -- ^ Pattern arguments
                 -> TcType              -- ^ Pattern type
                 -> [Name]              -- ^ Selector names
                 -- ^ Whether fields, empty if not record PatSyn
                 -> TcM (PatSyn, LHsBinds Id, TcGblEnv)
204
205
206
207
tc_patsyn_finish lname dir is_infix lpat'
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
                 wrapped_args
Matthew Pickering's avatar
Matthew Pickering committed
208
                 pat_ty field_labels
209
210
211
212
213
214
215
216
217
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there
         univ_tvs     <- mapM zonkQuantifiedTyVar univ_tvs
       ; ex_tvs       <- mapM zonkQuantifiedTyVar ex_tvs
       ; prov_theta   <- zonkTcThetaType prov_theta
       ; req_theta    <- zonkTcThetaType req_theta
       ; pat_ty       <- zonkTcType pat_ty
       ; wrapped_args <- mapM zonk_wrapped_arg wrapped_args
       ; let qtvs    = univ_tvs ++ ex_tvs
Matthew Pickering's avatar
Matthew Pickering committed
218
             -- See Note [Record PatSyn Desugaring]
219
220
221
             theta   = prov_theta ++ req_theta
             arg_tys = map (varType . fst) wrapped_args

Matthew Pickering's avatar
Matthew Pickering committed
222
223
224
       ; (patSyn, matcher_bind) <- fixM $ \ ~(patSyn,_) -> do {

        traceTc "tc_patsyn_finish {" $
225
226
227
228
229
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) $$
           ppr wrapped_args $$
           ppr pat_ty
230
231

       -- Make the 'matcher'
232
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
233
234
                                         (univ_tvs, req_theta, req_ev_binds, req_dicts)
                                         (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
235
                                         wrapped_args  -- Not necessarily zonked
Gergő Érdi's avatar
Gergő Érdi committed
236
                                         pat_ty
237

Matthew Pickering's avatar
Matthew Pickering committed
238

239
       -- Make the 'builder'
Matthew Pickering's avatar
Matthew Pickering committed
240
241
242
243
244
245
246
       ; builder_id <- mkPatSynBuilderId dir lname qtvs theta
                                         arg_tys pat_ty patSyn

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

248
       -- Make the PatSyn itself
Matthew Pickering's avatar
Matthew Pickering committed
249
       ; let patSyn' = mkPatSyn (unLoc lname) is_infix
250
251
                        (univ_tvs, req_theta)
                        (ex_tvs, prov_theta)
252
                        arg_tys
Gergő Érdi's avatar
Gergő Érdi committed
253
                        pat_ty
254
                        matcher_id builder_id
Matthew Pickering's avatar
Matthew Pickering committed
255
256
257
258
259
260
261
262
263
264
265
266
267
                        field_labels'
       ; return (patSyn', matcher_bind) }

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

       ; return (patSyn, matcher_bind, tcg_env) }
268

269
  where
270
271
272
273
    zonk_wrapped_arg :: (Var, HsWrapper) -> TcM (Var, HsWrapper)
    -- The HsWrapper will get zonked later, as part of the LHsBinds
    zonk_wrapped_arg (arg_id, wrap) = do { arg_id <- zonkId arg_id
                                         ; return (arg_id, wrap) }
274

Austin Seipp's avatar
Austin Seipp committed
275
276
277
{-
************************************************************************
*                                                                      *
278
         Constructing the "matcher" Id and its binding
Austin Seipp's avatar
Austin Seipp committed
279
280
281
*                                                                      *
************************************************************************
-}
282

Gergő Érdi's avatar
Gergő Érdi committed
283
284
tcPatSynMatcher :: Located Name
                -> LPat Id
285
286
287
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvVar])
                -> [(Var, HsWrapper)]
Gergő Érdi's avatar
Gergő Érdi committed
288
                -> TcType
289
290
                -> TcM ((Id, Bool), LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
291
292
293
294
tcPatSynMatcher (L loc name) lpat
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
                (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
                wrapped_args pat_ty
295
296
297
298
299
300
301
302
303
304
  = do { uniq <- newUnique
       ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
             res_tv  = mkTcTyVar tv_name openTypeKind (SkolemTv False)
             is_unlifted = null wrapped_args && null prov_dicts
             res_ty = mkTyVarTy res_tv
             (cont_arg_tys, cont_args)
               | is_unlifted = ([voidPrimTy], [nlHsVar voidPrimId])
               | otherwise   = unzip [ (varType arg, mkLHsWrap wrap $ nlHsVar arg)
                                     | (arg, wrap) <- wrapped_args
                                     ]
305
             cont_ty = mkSigmaTy ex_tvs prov_theta $
306
307
                       mkFunTys cont_arg_tys res_ty

308
             fail_ty = mkFunTy voidPrimTy res_ty
309

310
       ; matcher_name <- newImplicitBinder name mkMatcherOcc
311
312
313
314
315
       ; 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
316
             matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
317
             matcher_id    = mkExportedLocalId VanillaId matcher_name matcher_sigma
318
                             -- See Note [Exported LocalIds] in Id
319

320
321
322
             cont_dicts = map nlHsVar prov_dicts
             cont' = mkLHsWrap (mkWpLet prov_ev_binds) $
                     nlHsTyApps cont ex_tys (cont_dicts ++ cont_args)
Gergő Érdi's avatar
Gergő Érdi committed
323

324
             fail' = nlHsApps fail [nlHsVar voidPrimId]
Gergő Érdi's avatar
Gergő Érdi committed
325

326
             args = map nlVarPat [scrutinee, cont, fail]
Gergő Érdi's avatar
Gergő Érdi committed
327
328
329
330
331
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
                     then [mkSimpleHsAlt lpat  cont']
                     else [mkSimpleHsAlt lpat  cont',
                           mkSimpleHsAlt lwpat fail']
332
             body = mkLHsWrap (mkWpLet req_ev_binds) $
Gergő Érdi's avatar
Gergő Érdi committed
333
334
                    L (getLoc lpat) $
                    HsCase (nlHsVar scrutinee) $
335
                    MG{ mg_alts = cases
Gergő Érdi's avatar
Gergő Érdi committed
336
337
                      , mg_arg_tys = [pat_ty]
                      , mg_res_ty = res_ty
338
                      , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
339
340
341
                      }
             body' = noLoc $
                     HsLam $
342
                     MG{ mg_alts = [mkSimpleMatch args body]
Gergő Érdi's avatar
Gergő Érdi committed
343
344
                       , mg_arg_tys = [pat_ty, cont_ty, res_ty]
                       , mg_res_ty = res_ty
345
                       , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
346
                       }
347
348
             match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds
             mg = MG{ mg_alts = [match]
Gergő Érdi's avatar
Gergő Érdi committed
349
350
                    , mg_arg_tys = []
                    , mg_res_ty = res_ty
351
                    , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
352
353
                    }

354
       ; let bind = FunBind{ fun_id = L loc matcher_id
Gergő Érdi's avatar
Gergő Érdi committed
355
356
357
358
                           , fun_infix = False
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
                           , bind_fvs = emptyNameSet
359
                           , fun_tick = [] }
360
             matcher_bind = unitBag (noLoc bind)
Gergő Érdi's avatar
Gergő Érdi committed
361

362
       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
Gergő Érdi's avatar
Gergő Érdi committed
363
364
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

365
366
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
367
368
369
370
371
372
mkPatSynRecSelBinds :: PatSyn
                    -> [FieldLabel]
                    -- ^ Visible field labels
                    -> [(LSig Name, LHsBinds Name)]
mkPatSynRecSelBinds ps fields =
    map (mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps)) fields
373
374
375
376
377
378

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

Austin Seipp's avatar
Austin Seipp committed
379
380
381
{-
************************************************************************
*                                                                      *
382
         Constructing the "builder" Id
Austin Seipp's avatar
Austin Seipp committed
383
384
385
*                                                                      *
************************************************************************
-}
386
387

mkPatSynBuilderId :: HsPatSynDir a -> Located Name
Matthew Pickering's avatar
Matthew Pickering committed
388
                  -> [TyVar] -> ThetaType -> [Type] -> Type -> PatSyn
389
                  -> TcM (Maybe (Id, Bool))
Matthew Pickering's avatar
Matthew Pickering committed
390
mkPatSynBuilderId dir  (L _ name) qtvs theta arg_tys pat_ty pat_syn
391
392
393
  | isUnidirectional dir
  = return Nothing
  | otherwise
394
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
395
       ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
Matthew Pickering's avatar
Matthew Pickering committed
396
397
398
399
             builder_id    =
              -- See Note [Exported LocalIds] in Id
              mkExportedLocalId (PatSynBuilderId pat_syn)
                                builder_name builder_sigma
400
       ; return (Just (builder_id, need_dummy_arg)) }
401
  where
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
    builder_arg_tys | need_dummy_arg = [voidPrimTy]
                    | otherwise = arg_tys
    need_dummy_arg = isUnLiftedType pat_ty && null arg_tys && null theta

tcPatSynBuilderBind :: PatSynBind Name Name
                    -> TcM (LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
                       , psb_dir = dir, psb_args = details }
  | isUnidirectional dir
  = return emptyBag

  | isNothing mb_match_group       -- Can't invert the pattern
  = setSrcSpan (getLoc lpat) $ failWithTc $
    hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
       2 (ppr lpat)

419
  | otherwise  -- Bidirectional
420
  = do { patsyn <- tcLookupPatSyn name
421
       ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
422
423
424
425
426
                   -- Bidirectional, so patSynBuilder returns Just

             match_group' | need_dummy_arg = add_dummy_arg match_group
                          | otherwise      = match_group

427
             bind = FunBind { fun_id      = L loc (idName builder_id)
428
429
430
431
432
433
                            , fun_infix   = False
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , bind_fvs    = placeHolderNamesTc
                            , fun_tick    = [] }

434
       ; sig <- instTcTySigFromId builder_id
435
                -- See Note [Redundant constraints for builder]
436

437
       ; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind)
438
439
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
       ; return builder_binds }
440
  where
441
    Just match_group = mb_match_group
442
    mb_match_group
443
444
445
446
       = case dir of
           Unidirectional                    -> Nothing
           ExplicitBidirectional explicit_mg -> Just explicit_mg
           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)
447
448

    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
449
    mk_mg body = mkMatchGroupName Generated [builder_match]
450
451
452
               where
                 builder_args  = [L loc (VarPat n) | L loc n <- args]
                 builder_match = mkMatch builder_args body EmptyLocalBinds
453
454

    args = case details of
455
              PrefixPatSyn args     -> args
456
              InfixPatSyn arg1 arg2 -> [arg1, arg2]
Matthew Pickering's avatar
Matthew Pickering committed
457
              RecordPatSyn args     -> map recordPatSynPatVar args
458

459
    add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name)
460
461
    add_dummy_arg mg@(MG { mg_alts = [L loc (Match Nothing [] ty grhss)] })
      = mg { mg_alts = [L loc (Match Nothing [nlWildPatName] ty grhss)] }
462
463
464
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
                             pprMatches (PatSyn :: HsMatchContext Name) other_mg

465
466
467
468
469
470
471
472
473
474
475
476
tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType)
-- The result type should be fully instantiated
tcPatSynBuilderOcc orig ps
  | Just (builder_id, add_void_arg) <- builder
  = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id)
       ; let inst_fun = mkHsWrap wrap (HsVar builder_id)
       ; if add_void_arg
         then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId)
                     , tcFunResultTy rho )
         else return ( inst_fun, rho ) }

  | otherwise  -- Unidirectional
Matthew Pickering's avatar
Matthew Pickering committed
477
    = nonBidirectionalErr name
478
479
480
  where
    name    = patSynName ps
    builder = patSynBuilder ps
Gergő Érdi's avatar
Gergő Érdi committed
481

Austin Seipp's avatar
Austin Seipp committed
482
{-
483
484
485
486
487
488
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
489
490
(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
sig_warn_redundant to False.
491

Austin Seipp's avatar
Austin Seipp committed
492
493
************************************************************************
*                                                                      *
494
         Helper functions
Austin Seipp's avatar
Austin Seipp committed
495
496
*                                                                      *
************************************************************************
497

498
499
Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
500
501
502
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:
503
504
505
506
507
508

        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
509

510
511
or
        g (K (Just True) False) = ...
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531

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
532
533
534
535
536
537
538
539
540

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!
541
 -}
542

543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
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 ()
    go1 p@(AsPat _ _)         = asPatInPatSynErr p
    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
560
561
    go1   LitPat{}            = return ()
    go1   NPat{}              = return ()
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
    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 $
    hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
       2 (ppr pat)

thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
thInPatSynErr pat
  = failWithTc $
    hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
       2 (ppr pat)

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

Matthew Pickering's avatar
Matthew Pickering committed
588
589
590
591
592
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
    ptext (sLit "non-bidirectional pattern synonym")
    <+> quotes (ppr name) <+> ptext (sLit "used in an expression")

593
594
tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name)
tcPatToExpr args = go
Gergő Érdi's avatar
Gergő Érdi committed
595
  where
596
597
    lhsVars = mkNameSet (map unLoc args)

598
    go :: LPat Name -> Maybe (LHsExpr Name)
599
600
601
602
603
604
605
606
    go (L loc (ConPatIn (L _ con) info))
      = do { exprs <- mapM go (hsConPatArgs info)
           ; return $ L loc $
             foldl (\x y -> HsApp (L loc x) y) (HsVar con) exprs }

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

607
    go (L loc p) = fmap (L loc) $ go1 p
Gergő Érdi's avatar
Gergő Érdi committed
608

609
    go1 :: Pat Name -> Maybe (HsExpr Name)
Gergő Érdi's avatar
Gergő Érdi committed
610
    go1   (VarPat var)
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
      | var `elemNameSet` lhsVars     = return $ HsVar var
      | otherwise                     = Nothing
    go1   (LazyPat pat)               = fmap HsPar $ go pat
    go1   (ParPat pat)                = fmap HsPar $ go pat
    go1   (BangPat pat)               = fmap HsPar $ go 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) Nothing _)    = return $ HsOverLit n
    go1   (NPat (L _ n) (Just neg) _) = return $ noLoc neg `HsApp` noLoc (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   _                           = Nothing
Gergő Érdi's avatar
Gergő Érdi committed
630

631
632
633
634
635
636
-- 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.
Gergő Érdi's avatar
Gergő Érdi committed
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar])
tcCollectEx = return . go
  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
    go1 (NPlusKPat n k geq subtract)
      = 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

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