Typos in comments only [ci skip]
[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 {-# LANGUAGE FlexibleContexts #-}
10
11 module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
12 , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
13 ) where
14
15 import HsSyn
16 import TcPat
17 import Type( mkTyVarBinders, mkEmptyTCvSubst
18 , tidyTyVarBinders, tidyTypes, tidyType )
19 import TcRnMonad
20 import TcSigs( emptyPragEnv, completeSigFromId )
21 import TcEnv
22 import TcMType
23 import TcHsSyn( zonkTyVarBindersX, zonkTcTypeToTypes
24 , zonkTcTypeToType, emptyZonkEnv )
25 import TysPrim
26 import TysWiredIn ( runtimeRepTy )
27 import Name
28 import SrcLoc
29 import PatSyn
30 import NameSet
31 import Panic
32 import Outputable
33 import FastString
34 import Var
35 import VarEnv( emptyTidyEnv, mkInScopeSet )
36 import Id
37 import IdInfo( RecSelParent(..))
38 import TcBinds
39 import BasicTypes
40 import TcSimplify
41 import TcUnify
42 import TcType
43 import TcEvidence
44 import BuildTyCl
45 import VarSet
46 import MkId
47 import TcTyDecls
48 import ConLike
49 import FieldLabel
50 import Bag
51 import Util
52 import ErrUtils
53 import Control.Monad ( zipWithM )
54 import Data.List( partition )
55
56 #include "HsVersions.h"
57
58 {-
59 ************************************************************************
60 * *
61 Type checking a pattern synonym
62 * *
63 ************************************************************************
64 -}
65
66 tcInferPatSynDecl :: PatSynBind Name Name
67 -> TcM (LHsBinds Id, TcGblEnv)
68 tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
69 psb_def = lpat, psb_dir = dir }
70 = addPatSynCtxt lname $
71 do { traceTc "tcInferPatSynDecl {" $ ppr name
72 ; tcCheckPatSynPat lpat
73
74 ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
75 ; (tclvl, wanted, ((lpat', args), pat_ty))
76 <- pushLevelAndCaptureConstraints $
77 tcInferNoInst $ \ exp_ty ->
78 tcPat PatSyn lpat exp_ty $
79 mapM tcLookupId arg_names
80
81 ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
82
83 ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl NoRestrictions []
84 named_taus wanted
85
86 ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
87 ex_tv_set = mkVarSet ex_tvs
88 univ_tvs = filterOut (`elemVarSet` ex_tv_set) qtvs
89 prov_theta = map evVarPred prov_dicts
90 req_theta = map evVarPred req_dicts
91
92 ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
93 ; tc_patsyn_finish lname dir is_infix lpat'
94 (mkTyVarBinders Inferred univ_tvs
95 , req_theta, ev_binds, req_dicts)
96 (mkTyVarBinders Inferred ex_tvs
97 , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
98 (map nlHsVar args, map idType args)
99 pat_ty rec_fields }
100
101
102 tcCheckPatSynDecl :: PatSynBind Name Name
103 -> TcPatSynInfo
104 -> TcM (LHsBinds Id, TcGblEnv)
105 tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
106 , psb_def = lpat, psb_dir = dir }
107 TPSI{ patsig_implicit_bndrs = implicit_tvs
108 , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
109 , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta
110 , patsig_body_ty = sig_body_ty }
111 = addPatSynCtxt lname $
112 do { let decl_arity = length arg_names
113 (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
114
115 ; traceTc "tcCheckPatSynDecl" $
116 vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
117 , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
118
119 ; tcCheckPatSynPat lpat
120
121 ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
122 Right stuff -> return stuff
123 Left missing -> wrongNumberOfParmsErr name decl_arity missing
124
125 -- Complain about: pattern P :: () => forall x. x -> P x
126 -- The existential 'x' should not appear in the result type
127 -- Can't check this until we know P's arity
128 ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
129 ; checkTc (null bad_tvs) $
130 hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
131 , text "namely" <+> quotes (ppr pat_ty) ])
132 2 (text "mentions existential type variable" <> plural bad_tvs
133 <+> pprQuotedList bad_tvs)
134
135 -- See Note [The pattern-synonym signature splitting rule]
136 ; let univ_fvs = closeOverKinds $
137 (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
138 (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
139 univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
140 ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs
141 univ_tvs = binderVars univ_bndrs
142 ex_tvs = binderVars ex_bndrs
143
144 -- Right! Let's check the pattern against the signature
145 -- See Note [Checking against a pattern signature]
146 ; req_dicts <- newEvVars req_theta
147 ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
148 ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
149 pushLevelAndCaptureConstraints $
150 tcExtendTyVarEnv univ_tvs $
151 tcPat PatSyn lpat (mkCheckExpType pat_ty) $
152 do { let new_tv | isUnidirectional dir = newMetaTyVarX
153 | otherwise = newMetaSigTyVarX
154 in_scope = mkInScopeSet (mkVarSet univ_tvs)
155 empty_subst = mkEmptyTCvSubst in_scope
156 ; (subst, ex_tvs') <- mapAccumLM new_tv empty_subst ex_tvs
157 -- See the "Existential type variables" part of
158 -- Note [Checking against a pattern signature]
159 ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
160 ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
161 ; let prov_theta' = substTheta subst prov_theta
162 -- Add univ_tvs to the in_scope set to
163 -- satisfy the substition invariant. There's no need to
164 -- add 'ex_tvs' as they are already in the domain of the
165 -- substitution.
166 -- See also Note [The substitution invariant] in TyCoRep.
167 ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
168 ; args' <- zipWithM (tc_arg subst) arg_names arg_tys
169 ; return (ex_tvs', prov_dicts, args') }
170
171 ; let skol_info = SigSkol (PatSynCtxt name) (mkPhiTy req_theta pat_ty)
172 -- The type here is a bit bogus, but we do not print
173 -- the type for PatSynCtxt, so it doesn't matter
174 -- See TcRnTypes Note [Skolem info for pattern synonyms]
175 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
176
177 -- Solve the constraints now, because we are about to make a PatSyn,
178 -- which should not contain unification variables and the like (Trac #10997)
179 ; empty_binds <- simplifyTop (mkImplicWC implics)
180
181 -- Since all the inputs are implications the returned bindings will be empty
182 ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )
183
184 -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
185 -- Otherwise we may get a type error when typechecking the builder,
186 -- when that should be impossible
187
188 ; traceTc "tcCheckPatSynDecl }" $ ppr name
189 ; tc_patsyn_finish lname dir is_infix lpat'
190 (univ_bndrs, req_theta, ev_binds, req_dicts)
191 (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
192 (args', arg_tys)
193 pat_ty rec_fields }
194 where
195 tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId)
196 tc_arg subst arg_name arg_ty
197 = do { -- Look up the variable actually bound by lpat
198 -- and check that it has the expected type
199 arg_id <- tcLookupId arg_name
200 ; coi <- unifyType (Just arg_id)
201 (idType arg_id)
202 (substTyUnchecked subst arg_ty)
203 ; return (mkLHsWrapCo coi $ nlHsVar arg_id) }
204
205 {- Note [Checking against a pattern signature]
206 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
207 When checking the actual supplied pattern against the pattern synonym
208 signature, we need to be quite careful.
209
210 ----- Provided constraints
211 Example
212
213 data T a where
214 MkT :: Ord a => a -> T a
215
216 pattern P :: () => Eq a => a -> [T a]
217 pattern P x = [MkT x]
218
219 We must check that the (Eq a) that P claims to bind (and to
220 make available to matches against P), is derivable from the
221 actual pattern. For example:
222 f (P (x::a)) = ...here (Eq a) should be available...
223 And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.
224
225 ----- Existential type variables
226 Unusually, we instantiate the existential tyvars of the pattern with
227 *meta* type variables. For example
228
229 data S where
230 MkS :: Eq a => [a] -> S
231
232 pattern P :: () => Eq x => x -> S
233 pattern P x <- MkS x
234
235 The pattern synonym conceals from its client the fact that MkS has a
236 list inside it. The client just thinks it's a type 'x'. So we must
237 unify x := [a] during type checking, and then use the instantiating type
238 [a] (called ex_tys) when building the matcher. In this case we'll get
239
240 $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
241 $mP x k = case x of
242 MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
243 dl = $dfunEqList d
244 in k [a] dl ys
245
246 This "concealing" story works for /uni-directional/ pattern synonyms,
247 but obviously not for bidirectional ones. So in the bidirectional case
248 we use SigTv, rather than a generic TauTv, meta-tyvar so that. And
249 we should really check that those SigTvs don't get unified with each
250 other.
251
252 -}
253
254 collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
255 collectPatSynArgInfo details =
256 case details of
257 PrefixPatSyn names -> (map unLoc names, [], False)
258 InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
259 RecordPatSyn names ->
260 let (vars, sels) = unzip (map splitRecordPatSyn names)
261 in (vars, sels, False)
262
263 where
264 splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
265 splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
266 , recordPatSynSelectorId = L _ selId })
267 = (patVar, selId)
268
269 addPatSynCtxt :: Located Name -> TcM a -> TcM a
270 addPatSynCtxt (L loc name) thing_inside
271 = setSrcSpan loc $
272 addErrCtxt (text "In the declaration for pattern synonym"
273 <+> quotes (ppr name)) $
274 thing_inside
275
276 wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
277 wrongNumberOfParmsErr name decl_arity missing
278 = failWithTc $
279 hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
280 <+> speakNOf decl_arity (text "argument"))
281 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
282
283 -------------------------
284 -- Shared by both tcInferPatSyn and tcCheckPatSyn
285 tc_patsyn_finish :: Located Name -- ^ PatSyn Name
286 -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
287 -> Bool -- ^ Whether infix
288 -> LPat Id -- ^ Pattern of the PatSyn
289 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
290 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
291 -> ([LHsExpr TcId], [TcType]) -- ^ Pattern arguments and types
292 -> TcType -- ^ Pattern type
293 -> [Name] -- ^ Selector names
294 -- ^ Whether fields, empty if not record PatSyn
295 -> TcM (LHsBinds Id, TcGblEnv)
296 tc_patsyn_finish lname dir is_infix lpat'
297 (univ_tvs, req_theta, req_ev_binds, req_dicts)
298 (ex_tvs, ex_tys, prov_theta, prov_dicts)
299 (args, arg_tys)
300 pat_ty field_labels
301 = do { -- Zonk everything. We are about to build a final PatSyn
302 -- so there had better be no unification variables in there
303
304 (ze, univ_tvs') <- zonkTyVarBindersX emptyZonkEnv univ_tvs
305 ; req_theta' <- zonkTcTypeToTypes ze req_theta
306 ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs
307 ; prov_theta' <- zonkTcTypeToTypes ze prov_theta
308 ; pat_ty' <- zonkTcTypeToType ze pat_ty
309 ; arg_tys' <- zonkTcTypeToTypes ze arg_tys
310
311 ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs'
312 (env2, ex_tvs) = tidyTyVarBinders env1 ex_tvs'
313 req_theta = tidyTypes env2 req_theta'
314 prov_theta = tidyTypes env2 prov_theta'
315 arg_tys = tidyTypes env2 arg_tys'
316 pat_ty = tidyType env2 pat_ty'
317
318 ; traceTc "tc_patsyn_finish {" $
319 ppr (unLoc lname) $$ ppr (unLoc lpat') $$
320 ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
321 ppr (ex_tvs, prov_theta, prov_dicts) $$
322 ppr args $$
323 ppr arg_tys $$
324 ppr pat_ty
325
326 -- Make the 'matcher'
327 ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
328 (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
329 (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
330 (args, arg_tys)
331 pat_ty
332
333
334 -- Make the 'builder'
335 ; builder_id <- mkPatSynBuilderId dir lname
336 univ_tvs req_theta
337 ex_tvs prov_theta
338 arg_tys pat_ty
339
340 -- TODO: Make this have the proper information
341 ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
342 , flIsOverloaded = False
343 , flSelector = name }
344 field_labels' = map mkFieldLabel field_labels
345
346 -- Make the PatSyn itself
347 ; let patSyn = mkPatSyn (unLoc lname) is_infix
348 (univ_tvs, req_theta)
349 (ex_tvs, prov_theta)
350 arg_tys
351 pat_ty
352 matcher_id builder_id
353 field_labels'
354
355 -- Selectors
356 ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
357 tything = AConLike (PatSynCon patSyn)
358 ; tcg_env <- tcExtendGlobalEnv [tything] $
359 tcRecSelBinds rn_rec_sel_binds
360
361 ; traceTc "tc_patsyn_finish }" empty
362 ; return (matcher_bind, tcg_env) }
363
364 {-
365 ************************************************************************
366 * *
367 Constructing the "matcher" Id and its binding
368 * *
369 ************************************************************************
370 -}
371
372 tcPatSynMatcher :: Located Name
373 -> LPat Id
374 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
375 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
376 -> ([LHsExpr TcId], [TcType])
377 -> TcType
378 -> TcM ((Id, Bool), LHsBinds Id)
379 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
380 tcPatSynMatcher (L loc name) lpat
381 (univ_tvs, req_theta, req_ev_binds, req_dicts)
382 (ex_tvs, ex_tys, prov_theta, prov_dicts)
383 (args, arg_tys) pat_ty
384 = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
385 ; tv_name <- newNameAt (mkTyVarOcc "r") loc
386 ; let rr_tv = mkTcTyVar rr_name runtimeRepTy vanillaSkolemTv
387 rr = mkTyVarTy rr_tv
388 res_tv = mkTcTyVar tv_name (tYPE rr) vanillaSkolemTv
389 res_ty = mkTyVarTy res_tv
390 is_unlifted = null args && null prov_dicts
391 (cont_args, cont_arg_tys)
392 | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
393 | otherwise = (args, arg_tys)
394 cont_ty = mkInfSigmaTy ex_tvs prov_theta $
395 mkFunTys cont_arg_tys res_ty
396
397 fail_ty = mkFunTy voidPrimTy res_ty
398
399 ; matcher_name <- newImplicitBinder name mkMatcherOcc
400 ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty
401 ; cont <- newSysLocalId (fsLit "cont") cont_ty
402 ; fail <- newSysLocalId (fsLit "fail") fail_ty
403
404 ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
405 matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
406 matcher_id = mkExportedVanillaId matcher_name matcher_sigma
407 -- See Note [Exported LocalIds] in Id
408
409 inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
410 cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
411
412 fail' = nlHsApps fail [nlHsVar voidPrimId]
413
414 args = map nlVarPat [scrutinee, cont, fail]
415 lwpat = noLoc $ WildPat pat_ty
416 cases = if isIrrefutableHsPat lpat
417 then [mkHsCaseAlt lpat cont']
418 else [mkHsCaseAlt lpat cont',
419 mkHsCaseAlt lwpat fail']
420 body = mkLHsWrap (mkWpLet req_ev_binds) $
421 L (getLoc lpat) $
422 HsCase (nlHsVar scrutinee) $
423 MG{ mg_alts = L (getLoc lpat) cases
424 , mg_arg_tys = [pat_ty]
425 , mg_res_ty = res_ty
426 , mg_origin = Generated
427 }
428 body' = noLoc $
429 HsLam $
430 MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
431 args body]
432 , mg_arg_tys = [pat_ty, cont_ty, res_ty]
433 , mg_res_ty = res_ty
434 , mg_origin = Generated
435 }
436 match = mkMatch (FunRhs (L loc name) Prefix) []
437 (mkHsLams (rr_tv:res_tv:univ_tvs)
438 req_dicts body')
439 (noLoc EmptyLocalBinds)
440 mg = MG{ mg_alts = L (getLoc match) [match]
441 , mg_arg_tys = []
442 , mg_res_ty = res_ty
443 , mg_origin = Generated
444 }
445
446 ; let bind = FunBind{ fun_id = L loc matcher_id
447 , fun_matches = mg
448 , fun_co_fn = idHsWrapper
449 , bind_fvs = emptyNameSet
450 , fun_tick = [] }
451 matcher_bind = unitBag (noLoc bind)
452
453 ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
454 ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
455
456 ; return ((matcher_id, is_unlifted), matcher_bind) }
457
458 mkPatSynRecSelBinds :: PatSyn
459 -> [FieldLabel] -- ^ Visible field labels
460 -> HsValBinds Name
461 mkPatSynRecSelBinds ps fields
462 = ValBindsOut selector_binds sigs
463 where
464 (sigs, selector_binds) = unzip (map mkRecSel fields)
465 mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
466
467 isUnidirectional :: HsPatSynDir a -> Bool
468 isUnidirectional Unidirectional = True
469 isUnidirectional ImplicitBidirectional = False
470 isUnidirectional ExplicitBidirectional{} = False
471
472 {-
473 ************************************************************************
474 * *
475 Constructing the "builder" Id
476 * *
477 ************************************************************************
478 -}
479
480 mkPatSynBuilderId :: HsPatSynDir a -> Located Name
481 -> [TyVarBinder] -> ThetaType
482 -> [TyVarBinder] -> ThetaType
483 -> [Type] -> Type
484 -> TcM (Maybe (Id, Bool))
485 mkPatSynBuilderId dir (L _ name)
486 univ_bndrs req_theta ex_bndrs prov_theta
487 arg_tys pat_ty
488 | isUnidirectional dir
489 = return Nothing
490 | otherwise
491 = do { builder_name <- newImplicitBinder name mkBuilderOcc
492 ; let theta = req_theta ++ prov_theta
493 need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
494 builder_sigma = add_void need_dummy_arg $
495 mkForAllTys univ_bndrs $
496 mkForAllTys ex_bndrs $
497 mkFunTys theta $
498 mkFunTys arg_tys $
499 pat_ty
500 builder_id = mkExportedVanillaId builder_name builder_sigma
501 -- See Note [Exported LocalIds] in Id
502
503 ; return (Just (builder_id, need_dummy_arg)) }
504 where
505
506 tcPatSynBuilderBind :: PatSynBind Name Name
507 -> TcM (LHsBinds Id)
508 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
509 tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
510 , psb_dir = dir, psb_args = details })
511 | isUnidirectional dir
512 = return emptyBag
513
514 | Left why <- mb_match_group -- Can't invert the pattern
515 = setSrcSpan (getLoc lpat) $ failWithTc $
516 vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
517 <+> quotes (ppr name) <> colon)
518 2 why
519 , text "RHS pattern:" <+> ppr lpat ]
520
521 | Right match_group <- mb_match_group -- Bidirectional
522 = do { patsyn <- tcLookupPatSyn name
523 ; traceTc "tcPatSynBuilderBind {" $ ppr patsyn
524 ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
525 -- Bidirectional, so patSynBuilder returns Just
526
527 match_group' | need_dummy_arg = add_dummy_arg match_group
528 | otherwise = match_group
529
530 bind = FunBind { fun_id = L loc (idName builder_id)
531 , fun_matches = match_group'
532 , fun_co_fn = idHsWrapper
533 , bind_fvs = placeHolderNamesTc
534 , fun_tick = [] }
535
536 sig = completeSigFromId (PatSynCtxt name) builder_id
537
538 ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
539 ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
540 ; return builder_binds }
541
542 | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with
543 where
544 mb_match_group
545 = case dir of
546 ExplicitBidirectional explicit_mg -> Right explicit_mg
547 ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat)
548 Unidirectional -> panic "tcPatSynBuilderBind"
549
550 mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
551 mk_mg body = mkMatchGroup Generated [builder_match]
552 where
553 builder_args = [L loc (VarPat (L loc n)) | L loc n <- args]
554 builder_match = mkMatch (FunRhs (L loc name) Prefix)
555 builder_args body
556 (noLoc EmptyLocalBinds)
557
558 args = case details of
559 PrefixPatSyn args -> args
560 InfixPatSyn arg1 arg2 -> [arg1, arg2]
561 RecordPatSyn args -> map recordPatSynPatVar args
562
563 add_dummy_arg :: MatchGroup Name (LHsExpr Name)
564 -> MatchGroup Name (LHsExpr Name)
565 add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })
566 = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
567 add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
568 pprMatches other_mg
569
570 tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)
571 -- monadic only for failure
572 tcPatSynBuilderOcc ps
573 | Just (builder_id, add_void_arg) <- builder
574 , let builder_expr = HsVar (noLoc builder_id)
575 builder_ty = idType builder_id
576 = return $
577 if add_void_arg
578 then ( HsApp (noLoc $ builder_expr) (nlHsVar voidPrimId)
579 , tcFunResultTy builder_ty )
580 else (builder_expr, builder_ty)
581
582 | otherwise -- Unidirectional
583 = nonBidirectionalErr name
584 where
585 name = patSynName ps
586 builder = patSynBuilder ps
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 tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name)
594 -- Given a /pattern/, return an /expression/ that builds a value
595 -- that matches the pattern. E.g. if the pattern is (Just [x]),
596 -- the expression is (Just [x]). They look the same, but the
597 -- input uses constructors from HsPat and the output uses constructors
598 -- from HsExpr.
599 --
600 -- Returns (Left r) if the pattern is not invertible, for reason r.
601 -- See Note [Builder for a bidirectional pattern synonym]
602 tcPatToExpr args pat = go pat
603 where
604 lhsVars = mkNameSet (map unLoc args)
605
606 -- Make a prefix con for prefix and infix patterns for simplicity
607 mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name)
608 mkPrefixConExpr lcon@(L loc _) pats
609 = do { exprs <- mapM go pats
610 ; return (foldl (\x y -> HsApp (L loc x) y)
611 (HsVar lcon) exprs) }
612
613 mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name)
614 -> Either MsgDoc (HsExpr Name)
615 mkRecordConExpr con fields
616 = do { exprFields <- mapM go fields
617 ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }
618
619 go :: LPat Name -> Either MsgDoc (LHsExpr Name)
620 go (L loc p) = L loc <$> go1 p
621
622 go1 :: Pat Name -> Either MsgDoc (HsExpr Name)
623 go1 (ConPatIn con info)
624 = case info of
625 PrefixCon ps -> mkPrefixConExpr con ps
626 InfixCon l r -> mkPrefixConExpr con [l,r]
627 RecCon fields -> mkRecordConExpr con fields
628
629 go1 (SigPatIn pat _) = go1 (unLoc pat)
630 -- See Note [Type signatures and the builder expression]
631
632 go1 (VarPat (L l var))
633 | var `elemNameSet` lhsVars
634 = return $ HsVar (L l var)
635 | otherwise
636 = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
637 go1 (ParPat pat) = fmap HsPar $ go pat
638 go1 (LazyPat pat) = go1 (unLoc pat)
639 go1 (BangPat pat) = go1 (unLoc pat)
640 go1 (PArrPat pats ptt) = do { exprs <- mapM go pats
641 ; return $ ExplicitPArr ptt exprs }
642 go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats
643 ; return $ ExplicitList ptt (fmap snd reb) exprs }
644 go1 (TuplePat pats box _) = do { exprs <- mapM go pats
645 ; return $ ExplicitTuple
646 (map (noLoc . Present) exprs) box }
647 go1 (SumPat pat alt arity _) = do { expr <- go1 (unLoc pat)
648 ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder
649 }
650 go1 (LitPat lit) = return $ HsLit lit
651 go1 (NPat (L _ n) mb_neg _ _)
652 | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
653 | otherwise = return $ HsOverLit n
654 go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
655 go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
656 go1 (CoPat{}) = panic "CoPat in output of renamer"
657 go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")
658
659 {- Note [Builder for a bidirectional pattern synonym]
660 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
661 For a bidirectional pattern synonym we need to produce an /expression/
662 that matches the supplied /pattern/, given values for the arguments
663 of the pattern synoymy. For example
664 pattern F x y = (Just x, [y])
665 The 'builder' for F looks like
666 $builderF x y = (Just x, [y])
667
668 We can't always do this:
669 * Some patterns aren't invertible; e.g. view patterns
670 pattern F x = (reverse -> x:_)
671
672 * The RHS pattern might bind more variables than the pattern
673 synonym, so again we can't invert it
674 pattern F x = (x,y)
675
676 * Ditto wildcards
677 pattern F x = (x,_)
678
679
680 Note [Redundant constraints for builder]
681 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
682 The builder can have redundant constraints, which are awkard to eliminate.
683 Consider
684 pattern P = Just 34
685 To match against this pattern we need (Eq a, Num a). But to build
686 (Just 34) we need only (Num a). Fortunately instTcSigFromId sets
687 sig_warn_redundant to False.
688
689 ************************************************************************
690 * *
691 Helper functions
692 * *
693 ************************************************************************
694
695 Note [As-patterns in pattern synonym definitions]
696 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
697 The rationale for rejecting as-patterns in pattern synonym definitions
698 is that an as-pattern would introduce nonindependent pattern synonym
699 arguments, e.g. given a pattern synonym like:
700
701 pattern K x y = x@(Just y)
702
703 one could write a nonsensical function like
704
705 f (K Nothing x) = ...
706
707 or
708 g (K (Just True) False) = ...
709
710 Note [Type signatures and the builder expression]
711 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
712 Consider
713 pattern L x = Left x :: Either [a] [b]
714
715 In tc{Infer/Check}PatSynDecl we will check that the pattern has the
716 specified type. We check the pattern *as a pattern*, so the type
717 signature is a pattern signature, and so brings 'a' and 'b' into
718 scope. But we don't have a way to bind 'a, b' in the LHS, as we do
719 'x', say. Nevertheless, the sigature may be useful to constrain
720 the type.
721
722 When making the binding for the *builder*, though, we don't want
723 $buildL x = Left x :: Either [a] [b]
724 because that wil either mean (forall a b. Either [a] [b]), or we'll
725 get a complaint that 'a' and 'b' are out of scope. (Actually the
726 latter; Trac #9867.) No, the job of the signature is done, so when
727 converting the pattern to an expression (for the builder RHS) we
728 simply discard the signature.
729
730 Note [Record PatSyn Desugaring]
731 -------------------------------
732 It is important that prov_theta comes before req_theta as this ordering is used
733 when desugaring record pattern synonym updates.
734
735 Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
736 want to avoid difficult to decipher core lint errors!
737 -}
738
739 tcCheckPatSynPat :: LPat Name -> TcM ()
740 tcCheckPatSynPat = go
741 where
742 go :: LPat Name -> TcM ()
743 go = addLocM go1
744
745 go1 :: Pat Name -> TcM ()
746 go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
747 go1 VarPat{} = return ()
748 go1 WildPat{} = return ()
749 go1 p@(AsPat _ _) = asPatInPatSynErr p
750 go1 (LazyPat pat) = go pat
751 go1 (ParPat pat) = go pat
752 go1 (BangPat pat) = go pat
753 go1 (PArrPat pats _) = mapM_ go pats
754 go1 (ListPat pats _ _) = mapM_ go pats
755 go1 (TuplePat pats _ _) = mapM_ go pats
756 go1 (SumPat pat _ _ _) = go pat
757 go1 LitPat{} = return ()
758 go1 NPat{} = return ()
759 go1 (SigPatIn pat _) = go pat
760 go1 (ViewPat _ pat _) = go pat
761 go1 p@SplicePat{} = thInPatSynErr p
762 go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
763 go1 ConPatOut{} = panic "ConPatOut in output of renamer"
764 go1 SigPatOut{} = panic "SigPatOut in output of renamer"
765 go1 CoPat{} = panic "CoPat in output of renamer"
766
767 asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
768 asPatInPatSynErr pat
769 = failWithTc $
770 hang (text "Pattern synonym definition cannot contain as-patterns (@):")
771 2 (ppr pat)
772
773 thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
774 thInPatSynErr pat
775 = failWithTc $
776 hang (text "Pattern synonym definition cannot contain Template Haskell:")
777 2 (ppr pat)
778
779 nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
780 nPlusKPatInPatSynErr pat
781 = failWithTc $
782 hang (text "Pattern synonym definition cannot contain n+k-pattern:")
783 2 (ppr pat)
784
785 nonBidirectionalErr :: Outputable name => name -> TcM a
786 nonBidirectionalErr name = failWithTc $
787 text "non-bidirectional pattern synonym"
788 <+> quotes (ppr name) <+> text "used in an expression"
789
790 -- Walk the whole pattern and for all ConPatOuts, collect the
791 -- existentially-bound type variables and evidence binding variables.
792 --
793 -- These are used in computing the type of a pattern synonym and also
794 -- in generating matcher functions, since success continuations need
795 -- to be passed these pattern-bound evidences.
796 tcCollectEx
797 :: LPat Id
798 -> ( [TyVar] -- Existentially-bound type variables
799 -- in correctly-scoped order; e.g. [ k:*, x:k ]
800 , [EvVar] ) -- and evidence variables
801
802 tcCollectEx pat = go pat
803 where
804 go :: LPat Id -> ([TyVar], [EvVar])
805 go = go1 . unLoc
806
807 go1 :: Pat Id -> ([TyVar], [EvVar])
808 go1 (LazyPat p) = go p
809 go1 (AsPat _ p) = go p
810 go1 (ParPat p) = go p
811 go1 (BangPat p) = go p
812 go1 (ListPat ps _ _) = mergeMany . map go $ ps
813 go1 (TuplePat ps _ _) = mergeMany . map go $ ps
814 go1 (SumPat p _ _ _) = go p
815 go1 (PArrPat ps _) = mergeMany . map go $ ps
816 go1 (ViewPat _ p _) = go p
817 go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
818 goConDetails $ pat_args con
819 go1 (SigPatOut p _) = go p
820 go1 (CoPat _ p _) = go1 p
821 go1 (NPlusKPat n k _ geq subtract _)
822 = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
823 go1 _ = empty
824
825 goConDetails :: HsConPatDetails Id -> ([TyVar], [EvVar])
826 goConDetails (PrefixCon ps) = mergeMany . map go $ ps
827 goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
828 goConDetails (RecCon HsRecFields{ rec_flds = flds })
829 = mergeMany . map goRecFd $ flds
830
831 goRecFd :: LHsRecField Id (LPat Id) -> ([TyVar], [EvVar])
832 goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p
833
834 merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
835 mergeMany = foldr merge empty
836 empty = ([], [])