TcPatSyn.hs 27.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 ( 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
       ;
Matthew Pickering's avatar
Matthew Pickering committed
223
224

        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
       ; builder_id <- mkPatSynBuilderId dir lname qtvs theta
Matthew Pickering's avatar
Matthew Pickering committed
241
                                         arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
242
243
244
245
246

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

       ; return (patSyn, matcher_bind, tcg_env) }
267

268
  where
269
270
271
272
    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) }
273

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

Gergő Érdi's avatar
Gergő Érdi committed
282
283
tcPatSynMatcher :: Located Name
                -> LPat Id
284
285
286
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvVar])
                -> [(Var, HsWrapper)]
Gergő Érdi's avatar
Gergő Érdi committed
287
                -> TcType
288
289
                -> TcM ((Id, Bool), LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
290
291
292
293
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
294
295
296
297
298
299
300
301
302
303
  = 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
                                     ]
304
             cont_ty = mkSigmaTy ex_tvs prov_theta $
305
306
                       mkFunTys cont_arg_tys res_ty

307
             fail_ty = mkFunTy voidPrimTy res_ty
308

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

319
320
321
             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
322

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

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

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

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

363
364
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
365
366
367
368
mkPatSynRecSelBinds :: PatSyn
                    -> [FieldLabel]
                    -- ^ Visible field labels
                    -> [(LSig Name, LHsBinds Name)]
369
370
371
372
373
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)
374
375
376
377
378
379

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

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

mkPatSynBuilderId :: HsPatSynDir a -> Located Name
Matthew Pickering's avatar
Matthew Pickering committed
389
                  -> [TyVar] -> ThetaType -> [Type] -> Type
390
                  -> TcM (Maybe (Id, Bool))
Matthew Pickering's avatar
Matthew Pickering committed
391
mkPatSynBuilderId dir  (L _ name) qtvs theta arg_tys pat_ty
392
393
394
  | isUnidirectional dir
  = return Nothing
  | otherwise
395
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
396
       ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
Matthew Pickering's avatar
Matthew Pickering committed
397
398
             builder_id    =
              -- See Note [Exported LocalIds] in Id
Matthew Pickering's avatar
Matthew Pickering committed
399
              mkExportedLocalId VanillaId 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
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , bind_fvs    = placeHolderNamesTc
                            , fun_tick    = [] }

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

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

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

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

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

464
465
466
467
468
469
470
471
472
473
474
475
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
476
    = nonBidirectionalErr name
477
478
479
  where
    name    = patSynName ps
    builder = patSynBuilder ps
Gergő Érdi's avatar
Gergő Érdi committed
480

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

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

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

        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
508

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

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

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

542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
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
559
560
    go1   LitPat{}            = return ()
    go1   NPat{}              = return ()
561
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
    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
587
588
589
590
591
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
    ptext (sLit "non-bidirectional pattern synonym")
    <+> quotes (ppr name) <+> ptext (sLit "used in an expression")

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

597
    go :: LPat Name -> Maybe (LHsExpr Name)
598
599
600
601
602
603
604
605
    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]

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

608
    go1 :: Pat Name -> Maybe (HsExpr Name)
Gergő Érdi's avatar
Gergő Érdi committed
609
    go1   (VarPat var)
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
      | 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
629

630
631
632
633
634
635
-- 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
636
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
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

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