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