Note new GHC.Generics instances in release notes
[ghc.git] / compiler / typecheck / TcPatSyn.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[TcPatSyn]{Typechecking pattern synonym declarations}
6 -}
7
8 {-# LANGUAGE CPP #-}
9
10 module TcPatSyn ( tcPatSynSig, tcInferPatSynDecl, tcCheckPatSynDecl
11 , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
12 ) where
13
14 import HsSyn
15 import TcPat
16 import TcHsType( tcImplicitTKBndrs, tcExplicitTKBndrs
17 , tcHsContext, tcHsLiftedType, tcHsOpenType )
18 import TcRnMonad
19 import TcEnv
20 import TcMType
21 import TysPrim
22 import TysWiredIn ( runtimeRepTy )
23 import Name
24 import SrcLoc
25 import PatSyn
26 import NameSet
27 import Panic
28 import Outputable
29 import FastString
30 import Var
31 import Id
32 import IdInfo( RecSelParent(..))
33 import TcBinds
34 import BasicTypes
35 import TcSimplify
36 import TcUnify
37 import TcType
38 import TcEvidence
39 import BuildTyCl
40 import VarSet
41 import MkId
42 import TcTyDecls
43 import ConLike
44 import FieldLabel
45 import Bag
46 import Util
47 import Data.Maybe
48 import Control.Monad ( unless, zipWithM )
49 import Data.List( partition )
50 import Pair( Pair(..) )
51
52 #include "HsVersions.h"
53
54 {- *********************************************************************
55 * *
56 Type checking a pattern synonym signature
57 * *
58 ************************************************************************
59
60 Note [Pattern synonym signatures]
61 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
62 Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example).
63 In general they look like this:
64
65 pattern P :: forall univ_tvs. req
66 => forall ex_tvs. prov
67 => arg1 -> .. -> argn -> body_ty
68
69 For parsing and renaming we treat the signature as an ordinary LHsSigType.
70
71 Once we get to type checking, we decompose it into its parts, in tcPatSynSig.
72
73 * Note that 'forall univ_tvs' and 'req =>'
74 and 'forall ex_tvs' and 'prov =>'
75 are all optional. We gather the pieces at the the top of tcPatSynSig
76
77 * Initially the implicitly-bound tyvars (added by the renamer) include both
78 universal and existential vars.
79
80 * After we kind-check the pieces and convert to Types, we do kind generalisation.
81
82 * Note [Splitting the implicit tyvars in a pattern synonym]
83 Now the tricky bit: we must split
84 the implicitly-bound variables, and
85 the kind-generalised variables
86 into universal and existential. We do so as follows:
87
88 Note [The pattern-synonym signature splitting rule]
89 the universals are the ones mentioned in
90 - univ_tvs (and the kinds thereof)
91 - req
92 - body_ty
93 the existentials are the rest
94
95 * Moreover see Note
96 -}
97
98 tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo
99 tcPatSynSig name sig_ty
100 | HsIB { hsib_vars = implicit_hs_tvs
101 , hsib_body = hs_ty } <- sig_ty
102 , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTy hs_ty
103 , (ex_hs_tvs, hs_prov, hs_ty2) <- splitLHsSigmaTy hs_ty1
104 , (hs_arg_tys, hs_body_ty) <- splitHsFunType hs_ty2
105 = do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty))
106 <- solveEqualities $
107 tcImplicitTKBndrs implicit_hs_tvs $
108 tcExplicitTKBndrs univ_hs_tvs $ \ univ_tvs ->
109 tcExplicitTKBndrs ex_hs_tvs $ \ ex_tvs ->
110 do { req <- tcHsContext hs_req
111 ; prov <- tcHsContext hs_prov
112 ; arg_tys <- mapM tcHsOpenType (hs_arg_tys :: [LHsType Name])
113 ; body_ty <- tcHsLiftedType hs_body_ty
114 ; let bound_tvs
115 = unionVarSets [ allBoundVariabless req
116 , allBoundVariabless prov
117 , allBoundVariabless (body_ty : arg_tys)
118 ]
119 ; return ( (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty)
120 , bound_tvs) }
121
122 -- These are /signatures/ so we zonk to squeeze out any kind
123 -- unification variables.
124 -- ToDo: checkValidType?
125 ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs
126 ; univ_tvs <- mapM zonkTcTyCoVarBndr univ_tvs
127 ; ex_tvs <- mapM zonkTcTyCoVarBndr ex_tvs
128 ; req <- zonkTcTypes req
129 ; prov <- zonkTcTypes prov
130 ; arg_tys <- zonkTcTypes arg_tys
131 ; body_ty <- zonkTcType body_ty
132
133 -- Kind generalisation; c.f. kindGeneralise
134 ; let free_kvs = tyCoVarsOfTelescope (implicit_tvs ++ univ_tvs ++ ex_tvs) $
135 tyCoVarsOfTypes (body_ty : req ++ prov ++ arg_tys)
136
137 ; kvs <- quantifyTyVars emptyVarSet (Pair free_kvs emptyVarSet)
138
139 -- Complain about: pattern P :: () => forall x. x -> P x
140 -- The renamer thought it was fine, but the existential 'x'
141 -- should not appear in the result type
142 ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType body_ty) ex_tvs
143 ; unless (null bad_tvs) $ addErr $
144 hang (text "The result type" <+> quotes (ppr body_ty))
145 2 (text "mentions existential type variable" <> plural bad_tvs
146 <+> pprQuotedList bad_tvs)
147
148 -- Split [Splitting the implicit tyvars in a pattern synonym]
149 ; let univ_fvs = closeOverKinds $
150 (tyCoVarsOfTypes (body_ty : req) `extendVarSetList` univ_tvs)
151 (extra_univ, extra_ex) = partition (`elemVarSet` univ_fvs) $
152 kvs ++ implicit_tvs
153 ; traceTc "tcTySig }" $
154 vcat [ text "implicit_tvs" <+> ppr implicit_tvs
155 , text "kvs" <+> ppr kvs
156 , text "extra_univ" <+> ppr extra_univ
157 , text "univ_tvs" <+> ppr univ_tvs
158 , text "req" <+> ppr req
159 , text "extra_ex" <+> ppr extra_ex
160 , text "ex_tvs" <+> ppr ex_tvs
161 , text "prov" <+> ppr prov
162 , text "arg_tys" <+> ppr arg_tys
163 , text "body_ty" <+> ppr body_ty ]
164 ; return (TPSI { patsig_name = name
165 , patsig_univ_tvs = extra_univ ++ univ_tvs
166 , patsig_req = req
167 , patsig_ex_tvs = extra_ex ++ ex_tvs
168 , patsig_prov = prov
169 , patsig_arg_tys = arg_tys
170 , patsig_body_ty = body_ty }) }
171
172
173 {-
174 ************************************************************************
175 * *
176 Type checking a pattern synonym
177 * *
178 ************************************************************************
179 -}
180
181 tcInferPatSynDecl :: PatSynBind Name Name
182 -> TcM (LHsBinds Id, TcGblEnv)
183 tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
184 psb_def = lpat, psb_dir = dir }
185 = addPatSynCtxt lname $
186 do { traceTc "tcInferPatSynDecl {" $ ppr name
187 ; tcCheckPatSynPat lpat
188
189 ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
190 ; (tclvl, wanted, ((lpat', args), pat_ty))
191 <- pushLevelAndCaptureConstraints $
192 do { pat_ty <- newOpenInferExpType
193 ; stuff <- tcPat PatSyn lpat pat_ty $
194 mapM tcLookupId arg_names
195 ; pat_ty <- readExpType pat_ty
196 ; return (stuff, pat_ty) }
197
198 ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
199
200 ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
201
202 ; let (ex_vars, prov_dicts) = tcCollectEx lpat'
203 univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs
204 ex_tvs = varSetElems ex_vars
205 prov_theta = map evVarPred prov_dicts
206 req_theta = map evVarPred req_dicts
207
208 ; traceTc "tcInferPatSynDecl }" $ ppr name
209 ; tc_patsyn_finish lname dir False {- no sig -} is_infix lpat'
210 (univ_tvs, req_theta, ev_binds, req_dicts)
211 (ex_tvs, mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
212 (map nlHsVar args, map idType args)
213 pat_ty rec_fields }
214
215
216 tcCheckPatSynDecl :: PatSynBind Name Name
217 -> TcPatSynInfo
218 -> TcM (LHsBinds Id, TcGblEnv)
219 tcCheckPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details
220 , psb_def = lpat, psb_dir = dir }
221 TPSI{ patsig_univ_tvs = univ_tvs, patsig_prov = prov_theta
222 , patsig_ex_tvs = ex_tvs, patsig_req = req_theta
223 , patsig_arg_tys = arg_tys, patsig_body_ty = pat_ty }
224 = addPatSynCtxt lname $
225 do { let origin = PatOrigin -- TODO
226 skol_info = SigSkol (PatSynCtxt name) (mkCheckExpType $
227 mkFunTys arg_tys pat_ty)
228 decl_arity = length arg_names
229 ty_arity = length arg_tys
230 (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
231
232 ; traceTc "tcCheckPatSynDecl" $
233 vcat [ ppr univ_tvs, ppr req_theta, ppr ex_tvs
234 , ppr prov_theta, ppr arg_tys, ppr pat_ty ]
235
236 ; checkTc (decl_arity == ty_arity)
237 (wrongNumberOfParmsErr name decl_arity ty_arity)
238
239 ; tcCheckPatSynPat lpat
240
241 -- Right! Let's check the pattern against the signature
242 -- See Note [Checking against a pattern signature]
243 ; req_dicts <- newEvVars req_theta
244 ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
245 ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
246 pushLevelAndCaptureConstraints $
247 tcExtendTyVarEnv univ_tvs $
248 tcPat PatSyn lpat (mkCheckExpType pat_ty) $
249 do { (subst, ex_tvs') <- if isUnidirectional dir
250 then newMetaTyVars ex_tvs
251 else newMetaSigTyVars ex_tvs
252 -- See the "Existential type variables" part of
253 -- Note [Checking against a pattern signature]
254 ; prov_dicts <- mapM (emitWanted origin)
255 (substTheta (extendTCvInScopeList subst univ_tvs) prov_theta)
256 -- Add the free vars of 'prov_theta' to the in_scope set to
257 -- satisfy the substition invariant. There's no need to
258 -- add 'ex_tvs' as they are already in the domain of the
259 -- substitution.
260 -- See also Note [The substitution invariant] in TyCoRep.
261 ; args' <- zipWithM (tc_arg subst) arg_names arg_tys
262 ; return (ex_tvs', prov_dicts, args') }
263
264 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
265
266 -- Solve the constraints now, because we are about to make a PatSyn,
267 -- which should not contain unification variables and the like (Trac #10997)
268 -- Since all the inputs are implications the returned bindings will be empty
269 ; _ <- simplifyTop (mkImplicWC implics)
270
271 -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
272 -- Otherwise we may get a type error when typechecking the builder,
273 -- when that should be impossible
274
275 ; traceTc "tcCheckPatSynDecl }" $ ppr name
276 ; tc_patsyn_finish lname dir True {- has a sig -} is_infix lpat'
277 (univ_tvs, req_theta, ev_binds, req_dicts)
278 (ex_tvs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
279 (args', arg_tys)
280 pat_ty rec_fields }
281 where
282 tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId)
283 tc_arg subst arg_name arg_ty
284 = do { -- Look up the variable actually bound by lpat
285 -- and check that it has the expected type
286 arg_id <- tcLookupId arg_name
287 ; coi <- unifyType (Just arg_id)
288 (idType arg_id)
289 (substTyUnchecked subst arg_ty)
290 ; return (mkLHsWrapCo coi $ nlHsVar arg_id) }
291
292 {- Note [Checking against a pattern signature]
293 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
294 When checking the actual supplied pattern against the pattern synonym
295 signature, we need to be quite careful.
296
297 ----- Provided constraints
298 Example
299
300 data T a where
301 MkT :: Ord a => a -> T a
302
303 pattern P :: () => Eq a => a -> [T a]
304 pattern P x = [MkT x]
305
306 We must check that the (Eq a) that P claims to bind (and to
307 make available to matches against P), is derivable from the
308 actual pattern. For example:
309 f (P (x::a)) = ...here (Eq a) should be available...
310 And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.
311
312 ----- Existential type variables
313 Unusually, we instantiate the existential tyvars of the pattern with
314 *meta* type variables. For example
315
316 data S where
317 MkS :: Eq a => [a] -> S
318
319 pattern P :: () => Eq x => x -> S
320 pattern P x <- MkS x
321
322 The pattern synonym conceals from its client the fact that MkS has a
323 list inside it. The client just thinks it's a type 'x'. So we must
324 unify x := [a] during type checking, and then use the instantiating type
325 [a] (called ex_tys) when building the matcher. In this case we'll get
326
327 $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
328 $mP x k = case x of
329 MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
330 dl = $dfunEqList d
331 in k [a] dl ys
332
333 This "concealing" story works for /uni-directional/ pattern synonmys,
334 but obviously not for bidirectional ones. So in the bidirectional case
335 we use SigTv, rather than a generic TauTv, meta-tyvar so that. And
336 we should really check that those SigTvs don't get unified with each
337 other.
338
339 -}
340
341 collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
342 collectPatSynArgInfo details =
343 case details of
344 PrefixPatSyn names -> (map unLoc names, [], False)
345 InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
346 RecordPatSyn names ->
347 let (vars, sels) = unzip (map splitRecordPatSyn names)
348 in (vars, sels, False)
349
350 where
351 splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
352 splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
353 , recordPatSynSelectorId = L _ selId })
354 = (patVar, selId)
355
356 addPatSynCtxt :: Located Name -> TcM a -> TcM a
357 addPatSynCtxt (L loc name) thing_inside
358 = setSrcSpan loc $
359 addErrCtxt (text "In the declaration for pattern synonym"
360 <+> quotes (ppr name)) $
361 thing_inside
362
363 wrongNumberOfParmsErr :: Name -> Arity -> Arity -> SDoc
364 wrongNumberOfParmsErr name decl_arity ty_arity
365 = hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
366 <+> speakNOf decl_arity (text "argument"))
367 2 (text "but its type signature has" <+> speakN ty_arity)
368
369 -------------------------
370 -- Shared by both tcInferPatSyn and tcCheckPatSyn
371 tc_patsyn_finish :: Located Name -- ^ PatSyn Name
372 -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
373 -> Bool -- ^ True <=> signature provided
374 -> Bool -- ^ Whether infix
375 -> LPat Id -- ^ Pattern of the PatSyn
376 -> ([TcTyVar], [PredType], TcEvBinds, [EvVar])
377 -> ([TcTyVar], [TcType], [PredType], [EvTerm])
378 -> ([LHsExpr TcId], [TcType]) -- ^ Pattern arguments and types
379 -> TcType -- ^ Pattern type
380 -> [Name] -- ^ Selector names
381 -- ^ Whether fields, empty if not record PatSyn
382 -> TcM (LHsBinds Id, TcGblEnv)
383 tc_patsyn_finish lname dir has_sig is_infix lpat'
384 (univ_tvs, req_theta, req_ev_binds, req_dicts)
385 (ex_tvs, ex_tys, prov_theta, prov_dicts)
386 (args, arg_tys)
387 pat_ty field_labels
388 = do { -- Zonk everything. We are about to build a final PatSyn
389 -- so there had better be no unification variables in there
390 univ_tvs <- mapMaybeM zonkQuantifiedTyVar univ_tvs
391 ; ex_tvs <- mapMaybeM zonkQuantifiedTyVar ex_tvs
392 ; prov_theta <- zonkTcTypes prov_theta
393 ; req_theta <- zonkTcTypes req_theta
394 ; pat_ty <- zonkTcType pat_ty
395 ; arg_tys <- zonkTcTypes arg_tys
396
397 ; traceTc "tc_patsyn_finish {" $
398 ppr (unLoc lname) $$ ppr (unLoc lpat') $$
399 ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
400 ppr (ex_tvs, prov_theta, prov_dicts) $$
401 ppr args $$
402 ppr arg_tys $$
403 ppr pat_ty
404
405 -- Make the 'matcher'
406 ; (matcher_id, matcher_bind) <- tcPatSynMatcher has_sig lname lpat'
407 (univ_tvs, req_theta, req_ev_binds, req_dicts)
408 (ex_tvs, ex_tys, prov_theta, prov_dicts)
409 (args, arg_tys)
410 pat_ty
411
412
413 -- Make the 'builder'
414 ; builder_id <- mkPatSynBuilderId has_sig dir lname
415 univ_tvs req_theta
416 ex_tvs prov_theta
417 arg_tys pat_ty
418
419 -- TODO: Make this have the proper information
420 ; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
421 field_labels' = (map mkFieldLabel field_labels)
422
423
424 -- Make the PatSyn itself
425 ; let patSyn = mkPatSyn (unLoc lname) is_infix
426 (univ_tvs, req_theta)
427 (ex_tvs, prov_theta)
428 arg_tys
429 pat_ty
430 matcher_id builder_id
431 field_labels'
432
433 -- Selectors
434 ; let (sigs, selector_binds) =
435 unzip (mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn))
436 ; let tything = AConLike (PatSynCon patSyn)
437 ; tcg_env <-
438 tcExtendGlobalEnv [tything] $
439 tcRecSelBinds
440 (ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs)
441
442 ; traceTc "tc_patsyn_finish }" empty
443 ; return (matcher_bind, tcg_env) }
444
445 {-
446 ************************************************************************
447 * *
448 Constructing the "matcher" Id and its binding
449 * *
450 ************************************************************************
451 -}
452
453 tcPatSynMatcher :: Bool -- True <=> signature provided
454 -> Located Name
455 -> LPat Id
456 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
457 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
458 -> ([LHsExpr TcId], [TcType])
459 -> TcType
460 -> TcM ((Id, Bool), LHsBinds Id)
461 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
462 tcPatSynMatcher has_sig (L loc name) lpat
463 (univ_tvs, req_theta, req_ev_binds, req_dicts)
464 (ex_tvs, ex_tys, prov_theta, prov_dicts)
465 (args, arg_tys) pat_ty
466 = do { rr_uniq <- newUnique
467 ; tv_uniq <- newUnique
468 ; let rr_name = mkInternalName rr_uniq (mkTyVarOcc "rep") loc
469 tv_name = mkInternalName tv_uniq (mkTyVarOcc "r") loc
470 rr_tv = mkTcTyVar rr_name runtimeRepTy (SkolemTv False)
471 rr = mkTyVarTy rr_tv
472 res_tv = mkTcTyVar tv_name (tYPE rr) (SkolemTv False)
473 is_unlifted = null args && null prov_dicts
474 res_ty = mkTyVarTy res_tv
475 (cont_args, cont_arg_tys)
476 | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
477 | otherwise = (args, arg_tys)
478 mk_sigma = if has_sig then mkSpecSigmaTy else mkInvSigmaTy
479 cont_ty = mk_sigma ex_tvs prov_theta $
480 mkFunTys cont_arg_tys res_ty
481
482 fail_ty = mkFunTy voidPrimTy res_ty
483
484 ; matcher_name <- newImplicitBinder name mkMatcherOcc
485 ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty
486 ; cont <- newSysLocalId (fsLit "cont") cont_ty
487 ; fail <- newSysLocalId (fsLit "fail") fail_ty
488
489 ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
490 matcher_sigma = mkInvSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
491 matcher_id = mkExportedVanillaId matcher_name matcher_sigma
492 -- See Note [Exported LocalIds] in Id
493
494 inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
495 cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
496
497 fail' = nlHsApps fail [nlHsVar voidPrimId]
498
499 args = map nlVarPat [scrutinee, cont, fail]
500 lwpat = noLoc $ WildPat pat_ty
501 cases = if isIrrefutableHsPat lpat
502 then [mkSimpleHsAlt lpat cont']
503 else [mkSimpleHsAlt lpat cont',
504 mkSimpleHsAlt lwpat fail']
505 body = mkLHsWrap (mkWpLet req_ev_binds) $
506 L (getLoc lpat) $
507 HsCase (nlHsVar scrutinee) $
508 MG{ mg_alts = L (getLoc lpat) cases
509 , mg_arg_tys = [pat_ty]
510 , mg_res_ty = res_ty
511 , mg_origin = Generated
512 }
513 body' = noLoc $
514 HsLam $
515 MG{ mg_alts = noLoc [mkSimpleMatch args body]
516 , mg_arg_tys = [pat_ty, cont_ty, res_ty]
517 , mg_res_ty = res_ty
518 , mg_origin = Generated
519 }
520 match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body')
521 (noLoc EmptyLocalBinds)
522 mg = MG{ mg_alts = L (getLoc match) [match]
523 , mg_arg_tys = []
524 , mg_res_ty = res_ty
525 , mg_origin = Generated
526 }
527
528 ; let bind = FunBind{ fun_id = L loc matcher_id
529 , fun_matches = mg
530 , fun_co_fn = idHsWrapper
531 , bind_fvs = emptyNameSet
532 , fun_tick = [] }
533 matcher_bind = unitBag (noLoc bind)
534
535 ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
536 ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
537
538 ; return ((matcher_id, is_unlifted), matcher_bind) }
539
540 mkPatSynRecSelBinds :: PatSyn
541 -> [FieldLabel]
542 -- ^ Visible field labels
543 -> [(LSig Name, LHsBinds Name)]
544 mkPatSynRecSelBinds ps fields = map mkRecSel fields
545 where
546 mkRecSel fld_lbl =
547 case mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl of
548 (name, (_rec_flag, binds)) -> (name, binds)
549
550 isUnidirectional :: HsPatSynDir a -> Bool
551 isUnidirectional Unidirectional = True
552 isUnidirectional ImplicitBidirectional = False
553 isUnidirectional ExplicitBidirectional{} = False
554
555 {-
556 ************************************************************************
557 * *
558 Constructing the "builder" Id
559 * *
560 ************************************************************************
561 -}
562
563 mkPatSynBuilderId :: Bool -- True <=> signature provided
564 -> HsPatSynDir a -> Located Name
565 -> [TyVar] -> ThetaType
566 -> [TyVar] -> ThetaType
567 -> [Type] -> Type
568 -> TcM (Maybe (Id, Bool))
569 mkPatSynBuilderId has_sig dir (L _ name)
570 univ_tvs req_theta ex_tvs prov_theta
571 arg_tys pat_ty
572 | isUnidirectional dir
573 = return Nothing
574 | otherwise
575 = do { builder_name <- newImplicitBinder name mkBuilderOcc
576 ; let qtvs = univ_tvs ++ ex_tvs
577 theta = req_theta ++ prov_theta
578 mk_sigma = if has_sig then mkSpecSigmaTy else mkInvSigmaTy
579 need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
580 builder_sigma = add_void need_dummy_arg $
581 mk_sigma qtvs theta (mkFunTys arg_tys pat_ty)
582 builder_id = mkExportedVanillaId builder_name builder_sigma
583 -- See Note [Exported LocalIds] in Id
584
585 ; return (Just (builder_id, need_dummy_arg)) }
586 where
587
588 add_void :: Bool -> Type -> Type
589 add_void need_dummy_arg ty
590 | need_dummy_arg = mkFunTy voidPrimTy ty
591 | otherwise = ty
592
593 tcPatSynBuilderBind :: TcSigFun
594 -> PatSynBind Name Name
595 -> TcM (LHsBinds Id)
596 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
597 tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat
598 , psb_dir = dir, psb_args = details }
599 | isUnidirectional dir
600 = return emptyBag
601
602 | isNothing mb_match_group -- Can't invert the pattern
603 = setSrcSpan (getLoc lpat) $ failWithTc $
604 hang (text "Right-hand side of bidirectional pattern synonym cannot be used as an expression")
605 2 (ppr lpat)
606
607 | otherwise -- Bidirectional
608 = do { patsyn <- tcLookupPatSyn name
609 ; traceTc "tcPatSynBuilderBind {" $ ppr patsyn
610 ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
611 -- Bidirectional, so patSynBuilder returns Just
612
613 match_group' | need_dummy_arg = add_dummy_arg match_group
614 | otherwise = match_group
615
616 bind = FunBind { fun_id = L loc (idName builder_id)
617 , fun_matches = match_group'
618 , fun_co_fn = idHsWrapper
619 , bind_fvs = placeHolderNamesTc
620 , fun_tick = [] }
621
622 ; sig <- get_builder_sig sig_fun name builder_id need_dummy_arg
623
624 ; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind)
625 ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
626 ; return builder_binds }
627 where
628 Just match_group = mb_match_group
629 mb_match_group
630 = case dir of
631 Unidirectional -> Nothing
632 ExplicitBidirectional explicit_mg -> Just explicit_mg
633 ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat)
634
635 mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
636 mk_mg body = mkMatchGroupName Generated [builder_match]
637 where
638 builder_args = [L loc (VarPat (L loc n)) | L loc n <- args]
639 builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds)
640
641 args = case details of
642 PrefixPatSyn args -> args
643 InfixPatSyn arg1 arg2 -> [arg1, arg2]
644 RecordPatSyn args -> map recordPatSynPatVar args
645
646 add_dummy_arg :: MatchGroup Name (LHsExpr Name)
647 -> MatchGroup Name (LHsExpr Name)
648 add_dummy_arg mg@(MG { mg_alts
649 = L l [L loc (Match NonFunBindMatch [] ty grhss)] })
650 = mg { mg_alts
651 = L l [L loc (Match NonFunBindMatch [nlWildPatName] ty grhss)] }
652 add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
653 pprMatches (PatSyn :: HsMatchContext Name) other_mg
654
655 get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo
656 get_builder_sig sig_fun name builder_id need_dummy_arg
657 | Just (TcPatSynSig sig) <- sig_fun name
658 , TPSI { patsig_univ_tvs = univ_tvs
659 , patsig_req = req
660 , patsig_ex_tvs = ex_tvs
661 , patsig_prov = prov
662 , patsig_arg_tys = arg_tys
663 , patsig_body_ty = body_ty } <- sig
664 = -- Constuct a TcIdSigInfo from a TcPatSynInfo
665 -- This does unfortunately mean that we have to know how to
666 -- make the builder Id's type from the TcPatSynInfo, which
667 -- duplicates the construction in mkPatSynBuilderId
668 -- But we really want to use the scoped type variables from
669 -- the actual sigature, so this is really the Right Thing
670 return (TISI { sig_bndr = CompleteSig builder_id
671 , sig_skols = [(tyVarName tv, tv) | tv <- univ_tvs ++ ex_tvs]
672 , sig_theta = req ++ prov
673 , sig_tau = add_void need_dummy_arg $
674 mkFunTys arg_tys body_ty
675 , sig_ctxt = PatSynCtxt name
676 , sig_loc = getSrcSpan name })
677 | otherwise
678 = -- No signature, so fake up a TcIdSigInfo from the builder Id
679 instTcTySigFromId builder_id
680 -- See Note [Redundant constraints for builder]
681
682 tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)
683 -- monadic only for failure
684 tcPatSynBuilderOcc ps
685 | Just (builder_id, add_void_arg) <- builder
686 , let builder_expr = HsVar (noLoc builder_id)
687 builder_ty = idType builder_id
688 = return $
689 if add_void_arg
690 then ( HsApp (noLoc $ builder_expr) (nlHsVar voidPrimId)
691 , tcFunResultTy builder_ty )
692 else (builder_expr, builder_ty)
693
694 | otherwise -- Unidirectional
695 = nonBidirectionalErr name
696 where
697 name = patSynName ps
698 builder = patSynBuilder ps
699
700 {-
701 Note [Redundant constraints for builder]
702 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
703 The builder can have redundant constraints, which are awkard to eliminate.
704 Consider
705 pattern P = Just 34
706 To match against this pattern we need (Eq a, Num a). But to build
707 (Just 34) we need only (Num a). Fortunately instTcSigFromId sets
708 sig_warn_redundant to False.
709
710 ************************************************************************
711 * *
712 Helper functions
713 * *
714 ************************************************************************
715
716 Note [As-patterns in pattern synonym definitions]
717 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
718 The rationale for rejecting as-patterns in pattern synonym definitions
719 is that an as-pattern would introduce nonindependent pattern synonym
720 arguments, e.g. given a pattern synonym like:
721
722 pattern K x y = x@(Just y)
723
724 one could write a nonsensical function like
725
726 f (K Nothing x) = ...
727
728 or
729 g (K (Just True) False) = ...
730
731 Note [Type signatures and the builder expression]
732 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
733 Consider
734 pattern L x = Left x :: Either [a] [b]
735
736 In tc{Infer/Check}PatSynDecl we will check that the pattern has the
737 specified type. We check the pattern *as a pattern*, so the type
738 signature is a pattern signature, and so brings 'a' and 'b' into
739 scope. But we don't have a way to bind 'a, b' in the LHS, as we do
740 'x', say. Nevertheless, the sigature may be useful to constrain
741 the type.
742
743 When making the binding for the *builder*, though, we don't want
744 $buildL x = Left x :: Either [a] [b]
745 because that wil either mean (forall a b. Either [a] [b]), or we'll
746 get a complaint that 'a' and 'b' are out of scope. (Actually the
747 latter; Trac #9867.) No, the job of the signature is done, so when
748 converting the pattern to an expression (for the builder RHS) we
749 simply discard the signature.
750
751 Note [Record PatSyn Desugaring]
752 -------------------------------
753 It is important that prov_theta comes before req_theta as this ordering is used
754 when desugaring record pattern synonym updates.
755
756 Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
757 want to avoid difficult to decipher core lint errors!
758 -}
759
760 tcCheckPatSynPat :: LPat Name -> TcM ()
761 tcCheckPatSynPat = go
762 where
763 go :: LPat Name -> TcM ()
764 go = addLocM go1
765
766 go1 :: Pat Name -> TcM ()
767 go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
768 go1 VarPat{} = return ()
769 go1 WildPat{} = return ()
770 go1 p@(AsPat _ _) = asPatInPatSynErr p
771 go1 (LazyPat pat) = go pat
772 go1 (ParPat pat) = go pat
773 go1 (BangPat pat) = go pat
774 go1 (PArrPat pats _) = mapM_ go pats
775 go1 (ListPat pats _ _) = mapM_ go pats
776 go1 (TuplePat pats _ _) = mapM_ go pats
777 go1 LitPat{} = return ()
778 go1 NPat{} = return ()
779 go1 (SigPatIn pat _) = go pat
780 go1 (ViewPat _ pat _) = go pat
781 go1 p@SplicePat{} = thInPatSynErr p
782 go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
783 go1 ConPatOut{} = panic "ConPatOut in output of renamer"
784 go1 SigPatOut{} = panic "SigPatOut in output of renamer"
785 go1 CoPat{} = panic "CoPat in output of renamer"
786
787 asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
788 asPatInPatSynErr pat
789 = failWithTc $
790 hang (text "Pattern synonym definition cannot contain as-patterns (@):")
791 2 (ppr pat)
792
793 thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
794 thInPatSynErr pat
795 = failWithTc $
796 hang (text "Pattern synonym definition cannot contain Template Haskell:")
797 2 (ppr pat)
798
799 nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
800 nPlusKPatInPatSynErr pat
801 = failWithTc $
802 hang (text "Pattern synonym definition cannot contain n+k-pattern:")
803 2 (ppr pat)
804
805 nonBidirectionalErr :: Outputable name => name -> TcM a
806 nonBidirectionalErr name = failWithTc $
807 text "non-bidirectional pattern synonym"
808 <+> quotes (ppr name) <+> text "used in an expression"
809
810 tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name)
811 tcPatToExpr args = go
812 where
813 lhsVars = mkNameSet (map unLoc args)
814
815 go :: LPat Name -> Maybe (LHsExpr Name)
816 go (L loc (ConPatIn con info))
817 = case info of
818 PrefixCon ps -> mkPrefixConExpr con ps
819 InfixCon l r -> mkPrefixConExpr con [l,r]
820 RecCon fields -> L loc <$> mkRecordConExpr con fields
821
822 go (L _ (SigPatIn pat _)) = go pat
823 -- See Note [Type signatures and the builder expression]
824
825 go (L loc p) = L loc <$> go1 p
826
827 -- Make a prefix con for prefix and infix patterns for simplicity
828 mkPrefixConExpr :: Located Name -> [LPat Name] -> Maybe (LHsExpr Name)
829 mkPrefixConExpr con pats = do
830 exprs <- traverse go pats
831 return $ foldl (\x y -> L (combineLocs x y) (HsApp x y))
832 (L (getLoc con) (HsVar con))
833 exprs
834
835
836 mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name) -> Maybe (HsExpr Name)
837 mkRecordConExpr con fields = do
838 exprFields <- traverse go fields
839 return $ RecordCon con PlaceHolder noPostTcExpr exprFields
840
841 go1 :: Pat Name -> Maybe (HsExpr Name)
842 go1 (VarPat (L l var))
843 | var `elemNameSet` lhsVars = return $ HsVar (L l var)
844 | otherwise = Nothing
845 go1 (LazyPat pat) = fmap HsPar $ go pat
846 go1 (ParPat pat) = fmap HsPar $ go pat
847 go1 (BangPat pat) = fmap HsPar $ go pat
848 go1 (PArrPat pats ptt) = do { exprs <- mapM go pats
849 ; return $ ExplicitPArr ptt exprs }
850 go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats
851 ; return $ ExplicitList ptt (fmap snd reb) exprs }
852 go1 (TuplePat pats box _) = do { exprs <- mapM go pats
853 ; return $ ExplicitTuple
854 (map (noLoc . Present) exprs) box }
855 go1 (LitPat lit) = return $ HsLit lit
856 go1 (NPat (L _ n) Nothing _ _) = return $ HsOverLit n
857 go1 (NPat (L _ n) (Just neg) _ _)= return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
858 go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
859 go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
860 go1 (CoPat{}) = panic "CoPat in output of renamer"
861 go1 _ = Nothing
862
863 -- Walk the whole pattern and for all ConPatOuts, collect the
864 -- existentially-bound type variables and evidence binding variables.
865 --
866 -- These are used in computing the type of a pattern synonym and also
867 -- in generating matcher functions, since success continuations need
868 -- to be passed these pattern-bound evidences.
869 tcCollectEx :: LPat Id -> (TyVarSet, [EvVar])
870 tcCollectEx pat = go pat
871 where
872 go :: LPat Id -> (TyVarSet, [EvVar])
873 go = go1 . unLoc
874
875 go1 :: Pat Id -> (TyVarSet, [EvVar])
876 go1 (LazyPat p) = go p
877 go1 (AsPat _ p) = go p
878 go1 (ParPat p) = go p
879 go1 (BangPat p) = go p
880 go1 (ListPat ps _ _) = mconcat . map go $ ps
881 go1 (TuplePat ps _ _) = mconcat . map go $ ps
882 go1 (PArrPat ps _) = mconcat . map go $ ps
883 go1 (ViewPat _ p _) = go p
884 go1 con@ConPatOut{} = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
885 goConDetails $ pat_args con
886 go1 (SigPatOut p _) = go p
887 go1 (CoPat _ p _) = go1 p
888 go1 (NPlusKPat n k _ geq subtract _)
889 = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
890 go1 _ = mempty
891
892 goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
893 goConDetails (PrefixCon ps) = mconcat . map go $ ps
894 goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
895 goConDetails (RecCon HsRecFields{ rec_flds = flds })
896 = mconcat . map goRecFd $ flds
897
898 goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
899 goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p