Make the matcher and wrapper Ids in PatSyn into LocalIds, not GlobalIds
[ghc.git] / compiler / typecheck / TcPatSyn.lhs
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 \begin{code}
8 {-# LANGUAGE CPP #-}
9
10 module TcPatSyn (tcPatSynDecl) where
11
12 import HsSyn
13 import TcPat
14 import TcRnMonad
15 import TcEnv
16 import TcMType
17 import TysPrim
18 import Name
19 import SrcLoc
20 import PatSyn
21 import NameSet
22 import Panic
23 import Outputable
24 import FastString
25 import Var
26 import Id
27 import IdInfo( IdDetails( VanillaId ) )
28 import TcBinds
29 import BasicTypes
30 import TcSimplify
31 import TcType
32 import VarSet
33 import Data.Monoid
34 import Bag
35 import TcEvidence
36 import BuildTyCl
37 import TypeRep
38
39 #include "HsVersions.h"
40 \end{code}
41
42 \begin{code}
43 tcPatSynDecl :: Located Name
44              -> HsPatSynDetails (Located Name)
45              -> LPat Name
46              -> HsPatSynDir Name
47              -> TcM (PatSyn, LHsBinds Id)
48 tcPatSynDecl lname@(L _ name) details lpat dir
49   = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
50        ; tcCheckPatSynPat lpat
51        ; pat_ty <- newFlexiTyVarTy openTypeKind
52
53        ; let (arg_names, is_infix) = case details of
54                  PrefixPatSyn names      -> (map unLoc names, False)
55                  InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True)
56        ; ((lpat', args), wanted) <- captureConstraints       $
57                                     tcPat PatSyn lpat pat_ty $
58                                     mapM tcLookupId arg_names
59        ; let named_taus = (name, pat_ty):map (\arg -> (getName arg, varType arg)) args
60
61        ; traceTc "tcPatSynDecl::wanted" (ppr named_taus $$ ppr wanted)
62        ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted
63
64        ; (ex_vars, prov_dicts) <- tcCollectEx lpat'
65        ; let univ_tvs   = filter (not . (`elemVarSet` ex_vars)) qtvs
66              ex_tvs     = varSetElems ex_vars
67              prov_theta = map evVarPred prov_dicts
68              req_theta  = map evVarPred req_dicts
69
70        ; univ_tvs   <- mapM zonkQuantifiedTyVar univ_tvs
71        ; ex_tvs     <- mapM zonkQuantifiedTyVar ex_tvs
72        ; prov_theta <- zonkTcThetaType prov_theta
73        ; req_theta  <- zonkTcThetaType req_theta
74        ; pat_ty     <- zonkTcType pat_ty
75        ; args       <- mapM zonkId args
76
77        ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$
78                                      ppr prov_theta $$
79                                      ppr prov_dicts)
80        ; traceTc "tcPatSynDecl: univ" (ppr univ_tvs $$
81                                        ppr req_theta $$
82                                        ppr req_dicts $$
83                                        ppr ev_binds)
84
85        ; let theta = prov_theta ++ req_theta
86
87        ; traceTc "tcPatSynDecl: type" (ppr name $$
88                                        ppr univ_tvs $$
89                                        ppr (map varType args) $$
90                                        ppr pat_ty)
91
92        ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' args
93                                          univ_tvs ex_tvs
94                                          ev_binds
95                                          prov_dicts req_dicts
96                                          prov_theta req_theta
97                                          pat_ty
98        ; m_wrapper <- tcPatSynWrapper lname lpat dir args
99                                       univ_tvs ex_tvs theta pat_ty
100        ; let binds = matcher_bind `unionBags` maybe emptyBag snd m_wrapper
101
102        ; traceTc "tcPatSynDecl }" $ ppr name
103        ; let patSyn = mkPatSyn name is_infix
104                         (map varType args)
105                         univ_tvs ex_tvs
106                         prov_theta req_theta
107                         pat_ty
108                         matcher_id (fmap fst m_wrapper)
109        ; return (patSyn, binds) }
110
111 \end{code}
112
113
114 \begin{code}
115 tcPatSynMatcher :: Located Name
116                 -> LPat Id
117                 -> [Var]
118                 -> [TcTyVar] -> [TcTyVar]
119                 -> TcEvBinds
120                 -> [EvVar] -> [EvVar]
121                 -> ThetaType -> ThetaType
122                 -> TcType
123                 -> TcM (Id, LHsBinds Id)
124 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
125 tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
126   = do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind
127        ; matcher_name <- newImplicitBinder name mkMatcherOcc
128        ; let res_ty = TyVarTy res_tv
129              cont_ty = mkSigmaTy ex_tvs prov_theta $
130                        mkFunTys (map varType args) res_ty
131
132        ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
133              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
134              matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma
135
136        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
137        ; let matcher_lid = L loc matcher_id
138
139        ; scrutinee <- mkId "scrut" pat_ty
140        ; cont <- mkId "cont" cont_ty
141        ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ args)
142        ; fail <- mkId "fail" res_ty
143        ; let fail' = nlHsVar fail
144
145
146        ; let args = map nlVarPat [scrutinee, cont, fail]
147              lwpat = noLoc $ WildPat pat_ty
148              cases = if isIrrefutableHsPat lpat
149                      then [mkSimpleHsAlt lpat  cont']
150                      else [mkSimpleHsAlt lpat  cont',
151                            mkSimpleHsAlt lwpat fail']
152              body = mkLHsWrap (mkWpLet ev_binds) $
153                     L (getLoc lpat) $
154                     HsCase (nlHsVar scrutinee) $
155                     MG{ mg_alts = cases
156                       , mg_arg_tys = [pat_ty]
157                       , mg_res_ty = res_ty
158                       , mg_origin = Generated
159                       }
160              body' = noLoc $
161                      HsLam $
162                      MG{ mg_alts = [mkSimpleMatch args body]
163                        , mg_arg_tys = [pat_ty, cont_ty, res_ty]
164                        , mg_res_ty = res_ty
165                        , mg_origin = Generated
166                        }
167
168              match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds
169              mg = MG{ mg_alts = [match]
170                     , mg_arg_tys = []
171                     , mg_res_ty = res_ty
172                     , mg_origin = Generated
173                     }
174
175        ; let bind = FunBind{ fun_id = matcher_lid
176                            , fun_infix = False
177                            , fun_matches = mg
178                            , fun_co_fn = idHsWrapper
179                            , bind_fvs = emptyNameSet
180                            , fun_tick = Nothing }
181              matcher_bind = unitBag (noLoc bind)
182
183        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
184
185        ; return (matcher_id, matcher_bind) }
186   where
187     mkId s ty = do
188         name <- newName . mkVarOccFS . fsLit $ s
189         return $ mkLocalId name ty
190
191 tcPatSynWrapper :: Located Name
192                 -> LPat Name
193                 -> HsPatSynDir Name
194                 -> [Var]
195                 -> [TyVar] -> [TyVar]
196                 -> ThetaType
197                 -> TcType
198                 -> TcM (Maybe (Id, LHsBinds Id))
199 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
200 tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty
201   = do { let argNames = mkNameSet (map Var.varName args)
202        ; case (dir, tcPatToExpr argNames lpat) of
203            (Unidirectional, _) ->
204                return Nothing
205            (ImplicitBidirectional, Nothing) ->
206                cannotInvertPatSynErr lpat
207            (ImplicitBidirectional, Just lexpr) ->
208                fmap Just $ tc_pat_syn_wrapper_from_expr lname lexpr args univ_tvs ex_tvs theta pat_ty }
209
210 tc_pat_syn_wrapper_from_expr :: Located Name
211                              -> LHsExpr Name
212                              -> [Var]
213                              -> [TyVar] -> [TyVar]
214                              -> ThetaType
215                              -> Type
216                              -> TcM (Id, LHsBinds Id)
217 tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty
218   = do { let qtvs = univ_tvs ++ ex_tvs
219        ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs
220        ; let wrapper_theta = substTheta subst theta
221              pat_ty' = substTy subst pat_ty
222              args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args
223              wrapper_tau = mkFunTys (map varType args') pat_ty'
224              wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
225
226        ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
227        ; let wrapper_lname = L loc wrapper_name
228              wrapper_id = mkExportedLocalId VanillaId wrapper_name wrapper_sigma
229
230        ; let wrapper_args = map (noLoc . VarPat . Var.varName) args'
231              wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
232              bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
233              lbind = noLoc bind
234        ; let sig = TcSigInfo{ sig_id = wrapper_id
235                             , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs
236                             , sig_theta = wrapper_theta
237                             , sig_tau = wrapper_tau
238                             , sig_loc = loc
239                             }
240        ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig lbind
241        ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds
242        ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id)
243        ; return (wrapper_id, wrapper_binds) }
244
245 \end{code}
246
247 Note [As-patterns in pattern synonym definitions]
248 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
249
250 The rationale for rejecting as-patterns in pattern synonym definitions
251 is that an as-pattern would introduce nonindependent pattern synonym
252 arguments, e.g. given a pattern synonym like:
253
254         pattern K x y = x@(Just y)
255
256 one could write a nonsensical function like
257
258         f (K Nothing x) = ...
259
260 or
261         g (K (Just True) False) = ...
262
263 \begin{code}
264 tcCheckPatSynPat :: LPat Name -> TcM ()
265 tcCheckPatSynPat = go
266   where
267     go :: LPat Name -> TcM ()
268     go = addLocM go1
269
270     go1 :: Pat Name -> TcM ()
271     go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)
272     go1   VarPat{}            = return ()
273     go1   WildPat{}           = return ()
274     go1 p@(AsPat _ _)         = asPatInPatSynErr p
275     go1   (LazyPat pat)       = go pat
276     go1   (ParPat pat)        = go pat
277     go1   (BangPat pat)       = go pat
278     go1   (PArrPat pats _)    = mapM_ go pats
279     go1   (ListPat pats _ _)  = mapM_ go pats
280     go1   (TuplePat pats _ _) = mapM_ go pats
281     go1   LitPat{}            = return ()
282     go1   NPat{}              = return ()
283     go1   (SigPatIn pat _)    = go pat
284     go1   (ViewPat _ pat _)   = go pat
285     go1 p@SplicePat{}         = thInPatSynErr p
286     go1 p@QuasiQuotePat{}     = thInPatSynErr p
287     go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p
288     go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
289     go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
290     go1   CoPat{}             = panic "CoPat in output of renamer"
291
292 asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
293 asPatInPatSynErr pat
294   = failWithTc $
295     hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
296        2 (ppr pat)
297
298 thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
299 thInPatSynErr pat
300   = failWithTc $
301     hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
302        2 (ppr pat)
303
304 nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
305 nPlusKPatInPatSynErr pat
306   = failWithTc $
307     hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
308        2 (ppr pat)
309
310 tcPatToExpr :: NameSet -> LPat Name -> Maybe (LHsExpr Name)
311 tcPatToExpr lhsVars = go
312   where
313     go :: LPat Name -> Maybe (LHsExpr Name)
314     go (L loc (ConPatIn conName info))
315       = do
316           { let con = L loc (HsVar (unLoc conName))
317           ; exprs <- mapM go (hsConPatArgs info)
318           ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
319     go (L loc p) = fmap (L loc) $ go1 p
320
321     go1 :: Pat Name -> Maybe (HsExpr Name)
322     go1   (VarPat var)
323       | var `elemNameSet` lhsVars  = return $ HsVar var
324       | otherwise                  = Nothing
325     go1   (LazyPat pat)            = fmap HsPar $ go pat
326     go1   (ParPat pat)             = fmap HsPar $ go pat
327     go1   (BangPat pat)            = fmap HsPar $ go pat
328     go1   (PArrPat pats ptt)
329       = do { exprs <- mapM go pats
330            ; return $ ExplicitPArr ptt exprs }
331     go1   (ListPat pats ptt reb)
332       = do { exprs <- mapM go pats
333            ; return $ ExplicitList ptt (fmap snd reb) exprs }
334     go1   (TuplePat pats box _)
335       = do { exprs <- mapM go pats
336            ; return (ExplicitTuple (map Present exprs) box)
337            }
338     go1   (LitPat lit)             = return $ HsLit lit
339     go1   (NPat n Nothing _)       = return $ HsOverLit n
340     go1   (NPat n (Just neg) _)    = return $ noLoc neg `HsApp` noLoc (HsOverLit n)
341     go1   (SigPatIn pat (HsWB ty _ _))
342       = do { expr <- go pat
343            ; return $ ExprWithTySig expr ty }
344     go1   (ConPatOut{})            = panic "ConPatOut in output of renamer"
345     go1   (SigPatOut{})            = panic "SigPatOut in output of renamer"
346     go1   (CoPat{})                = panic "CoPat in output of renamer"
347     go1   _                        = Nothing
348
349 cannotInvertPatSynErr :: OutputableBndr name => LPat name -> TcM a
350 cannotInvertPatSynErr (L loc pat)
351   = setSrcSpan loc $ failWithTc $
352     hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
353        2 (ppr pat)
354
355 -- Walk the whole pattern and for all ConPatOuts, collect the
356 -- existentially-bound type variables and evidence binding variables.
357 --
358 -- These are used in computing the type of a pattern synonym and also
359 -- in generating matcher functions, since success continuations need
360 -- to be passed these pattern-bound evidences.
361 tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar])
362 tcCollectEx = return . go
363   where
364     go :: LPat Id -> (TyVarSet, [EvVar])
365     go = go1 . unLoc
366
367     go1 :: Pat Id -> (TyVarSet, [EvVar])
368     go1 (LazyPat p)         = go p
369     go1 (AsPat _ p)         = go p
370     go1 (ParPat p)          = go p
371     go1 (BangPat p)         = go p
372     go1 (ListPat ps _ _)    = mconcat . map go $ ps
373     go1 (TuplePat ps _ _)   = mconcat . map go $ ps
374     go1 (PArrPat ps _)      = mconcat . map go $ ps
375     go1 (ViewPat _ p _)     = go p
376     go1 (QuasiQuotePat qq)  = pprPanic "TODO: tcInstPatSyn QuasiQuotePat" $ ppr qq
377     go1 con@ConPatOut{}     = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
378                                  goConDetails $ pat_args con
379     go1 (SigPatOut p _)     = go p
380     go1 (CoPat _ p _)       = go1 p
381     go1 (NPlusKPat n k geq subtract)
382       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
383     go1 _                   = mempty
384
385     goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
386     goConDetails (PrefixCon ps) = mconcat . map go $ ps
387     goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
388     goConDetails (RecCon HsRecFields{ rec_flds = flds })
389       = mconcat . map goRecFd $ flds
390
391     goRecFd :: HsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
392     goRecFd HsRecField{ hsRecFieldArg = p } = go p
393
394 \end{code}