TcPatSyn.hs 35.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

cactus's avatar
cactus committed
5
\section[TcPatSyn]{Typechecking pattern synonym declarations}
Austin Seipp's avatar
Austin Seipp committed
6
-}
cactus's avatar
cactus committed
7

8
{-# LANGUAGE CPP #-}
9
{-# LANGUAGE FlexibleContexts #-}
10

11
module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
Matthew Pickering's avatar
Matthew Pickering committed
12
                , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
13
  ) where
cactus's avatar
cactus committed
14 15 16

import HsSyn
import TcPat
17 18
import Type( mkTyVarBinders, mkEmptyTCvSubst
           , tidyTyVarBinders, tidyTypes, tidyType )
cactus's avatar
cactus committed
19
import TcRnMonad
20
import TcSigs( emptyPragEnv, completeSigFromId )
cactus's avatar
cactus committed
21 22
import TcEnv
import TcMType
Simon Peyton Jones's avatar
Simon Peyton Jones committed
23 24
import TcHsSyn( zonkTyVarBindersX, zonkTcTypeToTypes
              , zonkTcTypeToType, emptyZonkEnv )
cactus's avatar
cactus committed
25
import TysPrim
26
import TysWiredIn  ( runtimeRepTy )
cactus's avatar
cactus committed
27 28 29 30 31 32 33 34
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
35
import VarEnv( emptyTidyEnv, mkInScopeSet )
cactus's avatar
cactus committed
36
import Id
Richard Eisenberg's avatar
Richard Eisenberg committed
37
import IdInfo( RecSelParent(..), setLevityInfoWithType )
cactus's avatar
cactus committed
38 39 40
import TcBinds
import BasicTypes
import TcSimplify
41
import TcUnify
cactus's avatar
cactus committed
42
import TcType
43 44
import TcEvidence
import BuildTyCl
cactus's avatar
cactus committed
45
import VarSet
46
import MkId
47
import TcTyDecls
Matthew Pickering's avatar
Matthew Pickering committed
48 49
import ConLike
import FieldLabel
cactus's avatar
cactus committed
50
import Bag
51
import Util
52
import ErrUtils
53
import Control.Monad ( zipWithM )
54
import Data.List( partition )
cactus's avatar
cactus committed
55 56 57

#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
58 59 60
{-
************************************************************************
*                                                                      *
61
                    Type checking a pattern synonym
Austin Seipp's avatar
Austin Seipp committed
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
cactus's avatar
cactus committed
73

Matthew Pickering's avatar
Matthew Pickering committed
74
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
75
       ; (tclvl, wanted, ((lpat', args), pat_ty))
76
            <- pushLevelAndCaptureConstraints  $
77
               tcInferNoInst $ \ exp_ty ->
78 79
               tcPat PatSyn lpat exp_ty $
               mapM tcLookupId arg_names
80 81

       ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
cactus's avatar
cactus committed
82

83 84
       ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl NoRestrictions []
                                                      named_taus wanted
cactus's avatar
cactus committed
85

86 87 88
       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
             ex_tv_set  = mkVarSet ex_tvs
             univ_tvs   = filterOut (`elemVarSet` ex_tv_set) qtvs
89 90
             prov_theta = map evVarPred prov_dicts
             req_theta  = map evVarPred req_dicts
cactus's avatar
cactus committed
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)
Matthew Pickering's avatar
Matthew Pickering committed
99 100
                          pat_ty rec_fields }

101 102 103

tcCheckPatSynDecl :: PatSynBind Name Name
                  -> TcPatSynInfo
104
                  -> TcM (LHsBinds Id, TcGblEnv)
105 106
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                         , psb_def = lpat, psb_dir = dir }
107 108 109 110
                  TPSI{ patsig_implicit_bndrs = implicit_tvs
                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta
                      , patsig_body_ty    = sig_body_ty }
111
  = addPatSynCtxt lname $
112
    do { let decl_arity = length arg_names
113 114 115
             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

       ; traceTc "tcCheckPatSynDecl" $
116 117
         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
118

119 120
       ; tcCheckPatSynPat lpat

121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
                                 Right stuff  -> return stuff
                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing

       -- Complain about:  pattern P :: () => forall x. x -> P x
       -- The existential 'x' should not appear in the result type
       -- Can't check this until we know P's arity
       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
       ; checkTc (null bad_tvs) $
         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
                   , text "namely" <+> quotes (ppr pat_ty) ])
            2 (text "mentions existential type variable" <> plural bad_tvs
               <+> pprQuotedList bad_tvs)

         -- See Note [The pattern-synonym signature splitting rule]
136
       ; let univ_fvs = closeOverKinds $
137
                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
138 139 140 141 142
             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
             univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
             ex_bndrs   = extra_ex   ++ mkTyVarBinders Specified explicit_ex_tvs
             univ_tvs   = binderVars univ_bndrs
             ex_tvs     = binderVars ex_bndrs
143

144 145
       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
146
       ; req_dicts <- newEvVars req_theta
147 148
       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
149 150 151
           pushLevelAndCaptureConstraints            $
           tcExtendTyVarEnv univ_tvs                 $
           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
152
           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)
153
                    empty_subst = mkEmptyTCvSubst in_scope
154 155 156
              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
                    -- newMetaTyVarX: see the "Existential type variables"
                    -- part of Note [Checking against a pattern signature]
157 158
              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
159
              ; let prov_theta' = substTheta subst prov_theta
160
                  -- Add univ_tvs to the in_scope set to
161
                  -- satisfy the substitution invariant. There's no need to
162 163 164
                  -- add 'ex_tvs' as they are already in the domain of the
                  -- substitution.
                  -- See also Note [The substitution invariant] in TyCoRep.
165
              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
166 167 168
              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
              ; return (ex_tvs', prov_dicts, args') }

169
       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
170 171 172
                         -- The type here is a bit bogus, but we do not print
                         -- the type for PatSynCtxt, so it doesn't matter
                         -- See TcRnTypes Note [Skolem info for pattern synonyms]
173
       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
174

175 176
       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (Trac #10997)
177
       ; simplifyTopImplic implics
178 179 180 181

       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
       -- Otherwise we may get a type error when typechecking the builder,
       -- when that should be impossible
182

183
       ; traceTc "tcCheckPatSynDecl }" $ ppr name
184
       ; tc_patsyn_finish lname dir is_infix lpat'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
185 186
                          (univ_bndrs, req_theta, ev_binds, req_dicts)
                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
187
                          (args', arg_tys)
188
                          pat_ty rec_fields }
189
  where
190 191 192 193 194 195 196
    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId)
    tc_arg subst arg_name arg_ty
      = do {   -- Look up the variable actually bound by lpat
               -- and check that it has the expected type
             arg_id <- tcLookupId arg_name
           ; coi <- unifyType (Just arg_id)
                              (idType arg_id)
197
                              (substTyUnchecked subst arg_ty)
198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
           ; return (mkLHsWrapCo coi $ nlHsVar arg_id) }

{- Note [Checking against a pattern signature]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When checking the actual supplied pattern against the pattern synonym
signature, we need to be quite careful.

----- Provided constraints
Example

    data T a where
      MkT :: Ord a => a -> T a

    pattern P :: () => Eq a => a -> [T a]
    pattern P x = [MkT x]

We must check that the (Eq a) that P claims to bind (and to
Rik Steenkamp's avatar
Rik Steenkamp committed
215 216
make available to matches against P), is derivable from the
actual pattern.  For example:
217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
    f (P (x::a)) = ...here (Eq a) should be available...
And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.

----- Existential type variables
Unusually, we instantiate the existential tyvars of the pattern with
*meta* type variables.  For example

    data S where
      MkS :: Eq a => [a] -> S

    pattern P :: () => Eq x => x -> S
    pattern P x <- MkS x

The pattern synonym conceals from its client the fact that MkS has a
list inside it.  The client just thinks it's a type 'x'.  So we must
unify x := [a] during type checking, and then use the instantiating type
[a] (called ex_tys) when building the matcher.  In this case we'll get

   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
   $mP x k = case x of
               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
                                              dl = $dfunEqList d
                                          in k [a] dl ys

241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260
All this applies when type-checking the /matching/ side of
a pattern synonym.  What about the /building/ side?

* For Unidirectional, there is no builder

* For ExplicitBidirectional, the builder is completely separate
  code, typechecked in tcPatSynBuilderBind

* For ImplicitBidirectional, the builder is still typechecked in
  tcPatSynBuilderBind, by converting the pattern to an expression and
  typechecking it.

  At one point, for ImplicitBidirectional I used SigTvs (instead of
  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
  is redundant since tcPatSynBuilderBind does the job, (b) it was
  still incomplete (SigTvs can unify with each other), and (c) it
  didn't even work (Trac #13441 was accepted with
  ExplicitBidirectional, but rejected if expressed in
  ImplicitBidirectional form.  Conclusion: trying to be too clever is
  a bad idea.
261
-}
262

Matthew Pickering's avatar
Matthew Pickering committed
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277
collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo details =
  case details of
    PrefixPatSyn names      -> (map unLoc names, [], False)
    InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
    RecordPatSyn names ->
      let (vars, sels) = unzip (map splitRecordPatSyn names)
      in (vars, sels, False)

  where
    splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
    splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
                                         , recordPatSynSelectorId = L _ selId })
      = (patVar, selId)

278 279 280
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L loc name) thing_inside
  = setSrcSpan loc $
281
    addErrCtxt (text "In the declaration for pattern synonym"
282 283 284
                <+> quotes (ppr name)) $
    thing_inside

285 286 287 288
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
  = failWithTc $
    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
289
          <+> speakNOf decl_arity (text "argument"))
290
       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
291

292 293
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
Matthew Pickering's avatar
Matthew Pickering committed
294 295 296 297
tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
                 -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                 -> Bool              -- ^ Whether infix
                 -> LPat Id           -- ^ Pattern of the PatSyn
Simon Peyton Jones's avatar
Simon Peyton Jones committed
298 299
                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
300
                 -> ([LHsExpr TcId], [TcType])   -- ^ Pattern arguments and types
Matthew Pickering's avatar
Matthew Pickering committed
301 302 303
                 -> TcType              -- ^ Pattern type
                 -> [Name]              -- ^ Selector names
                 -- ^ Whether fields, empty if not record PatSyn
304
                 -> TcM (LHsBinds Id, TcGblEnv)
305
tc_patsyn_finish lname dir is_infix lpat'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
306 307
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
308
                 (args, arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
309
                 pat_ty field_labels
310 311
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there
Simon Peyton Jones's avatar
Simon Peyton Jones committed
312 313 314 315 316 317 318

         (ze, univ_tvs') <- zonkTyVarBindersX emptyZonkEnv univ_tvs
       ; req_theta'      <- zonkTcTypeToTypes ze req_theta
       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs
       ; prov_theta'       <- zonkTcTypeToTypes ze prov_theta
       ; pat_ty'         <- zonkTcTypeToType ze pat_ty
       ; arg_tys'        <- zonkTcTypeToTypes ze arg_tys
319

Simon Peyton Jones's avatar
Simon Peyton Jones committed
320 321
       ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs'
             (env2, ex_tvs)   = tidyTyVarBinders env1 ex_tvs'
322 323 324 325
             req_theta  = tidyTypes env2 req_theta'
             prov_theta = tidyTypes env2 prov_theta'
             arg_tys    = tidyTypes env2 arg_tys'
             pat_ty     = tidyType  env2 pat_ty'
326

327
       ; traceTc "tc_patsyn_finish {" $
328
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
Simon Peyton Jones's avatar
Simon Peyton Jones committed
329 330
           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, prov_theta, prov_dicts) $$
331 332
           ppr args $$
           ppr arg_tys $$
333
           ppr pat_ty
334 335

       -- Make the 'matcher'
336
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
337 338
                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
339
                                         (args, arg_tys)
cactus's avatar
cactus committed
340
                                         pat_ty
341

342
       -- Make the 'builder'
343
       ; builder_id <- mkPatSynBuilderId dir lname
Simon Peyton Jones's avatar
Simon Peyton Jones committed
344 345
                                         univ_tvs req_theta
                                         ex_tvs   prov_theta
Matthew Pickering's avatar
Matthew Pickering committed
346
                                         arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
347 348

         -- TODO: Make this have the proper information
349 350 351 352
       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
                                            , flIsOverloaded = False
                                            , flSelector = name }
             field_labels' = map mkFieldLabel field_labels
Matthew Pickering's avatar
Matthew Pickering committed
353

Richard Eisenberg's avatar
Richard Eisenberg committed
354

355
       -- Make the PatSyn itself
Matthew Pickering's avatar
Matthew Pickering committed
356
       ; let patSyn = mkPatSyn (unLoc lname) is_infix
Simon Peyton Jones's avatar
Simon Peyton Jones committed
357 358
                        (univ_tvs, req_theta)
                        (ex_tvs, prov_theta)
359
                        arg_tys
cactus's avatar
cactus committed
360
                        pat_ty
361
                        matcher_id builder_id
Matthew Pickering's avatar
Matthew Pickering committed
362 363 364
                        field_labels'

       -- Selectors
365 366 367 368
       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
             tything = AConLike (PatSynCon patSyn)
       ; tcg_env <- tcExtendGlobalEnv [tything] $
                    tcRecSelBinds rn_rec_sel_binds
Matthew Pickering's avatar
Matthew Pickering committed
369

370
       ; traceTc "tc_patsyn_finish }" empty
371
       ; return (matcher_bind, tcg_env) }
372

Austin Seipp's avatar
Austin Seipp committed
373 374 375
{-
************************************************************************
*                                                                      *
376
         Constructing the "matcher" Id and its binding
Austin Seipp's avatar
Austin Seipp committed
377 378 379
*                                                                      *
************************************************************************
-}
380

381
tcPatSynMatcher :: Located Name
cactus's avatar
cactus committed
382
                -> LPat Id
383
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
384 385
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                -> ([LHsExpr TcId], [TcType])
cactus's avatar
cactus committed
386
                -> TcType
387 388
                -> TcM ((Id, Bool), LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
389
tcPatSynMatcher (L loc name) lpat
390
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
391 392
                (ex_tvs, ex_tys, prov_theta, prov_dicts)
                (args, arg_tys) pat_ty
393 394
  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
395 396
       ; let rr_tv  = mkTcTyVar rr_name runtimeRepTy vanillaSkolemTv
             rr     = mkTyVarTy rr_tv
397
             res_tv = mkTcTyVar tv_name (tYPE rr) vanillaSkolemTv
398
             res_ty = mkTyVarTy res_tv
399
             is_unlifted = null args && null prov_dicts
400 401 402
             (cont_args, cont_arg_tys)
               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
               | otherwise   = (args,                 arg_tys)
403
             cont_ty = mkInfSigmaTy ex_tvs prov_theta $
404 405
                       mkFunTys cont_arg_tys res_ty

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
406
             fail_ty  = mkFunTy voidPrimTy res_ty
407

408
       ; matcher_name <- newImplicitBinder name mkMatcherOcc
409 410 411 412 413
       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty

       ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
414
             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
415
             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
416
                             -- See Note [Exported LocalIds] in Id
417

418 419
             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
             cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
cactus's avatar
cactus committed
420

421
             fail' = nlHsApps fail [nlHsVar voidPrimId]
cactus's avatar
cactus committed
422

423
             args = map nlVarPat [scrutinee, cont, fail]
cactus's avatar
cactus committed
424 425
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
426 427 428
                     then [mkHsCaseAlt lpat  cont']
                     else [mkHsCaseAlt lpat  cont',
                           mkHsCaseAlt lwpat fail']
429
             body = mkLHsWrap (mkWpLet req_ev_binds) $
cactus's avatar
cactus committed
430 431
                    L (getLoc lpat) $
                    HsCase (nlHsVar scrutinee) $
432
                    MG{ mg_alts = L (getLoc lpat) cases
cactus's avatar
cactus committed
433 434
                      , mg_arg_tys = [pat_ty]
                      , mg_res_ty = res_ty
435
                      , mg_origin = Generated
cactus's avatar
cactus committed
436 437 438
                      }
             body' = noLoc $
                     HsLam $
439 440
                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
                                                        args body]
Richard Eisenberg's avatar
Richard Eisenberg committed
441
                       , mg_arg_tys = [pat_ty, cont_ty, fail_ty]
cactus's avatar
cactus committed
442
                       , mg_res_ty = res_ty
443
                       , mg_origin = Generated
cactus's avatar
cactus committed
444
                       }
Ben Gamari's avatar
Ben Gamari committed
445
             match = mkMatch (mkPrefixFunRhs (L loc name)) []
446 447
                             (mkHsLams (rr_tv:res_tv:univ_tvs)
                             req_dicts body')
448 449
                             (noLoc EmptyLocalBinds)
             mg = MG{ mg_alts = L (getLoc match) [match]
cactus's avatar
cactus committed
450 451
                    , mg_arg_tys = []
                    , mg_res_ty = res_ty
452
                    , mg_origin = Generated
cactus's avatar
cactus committed
453 454
                    }

455
       ; let bind = FunBind{ fun_id = L loc matcher_id
cactus's avatar
cactus committed
456 457 458
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
                           , bind_fvs = emptyNameSet
459
                           , fun_tick = [] }
460
             matcher_bind = unitBag (noLoc bind)
cactus's avatar
cactus committed
461

462
       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
cactus's avatar
cactus committed
463 464
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

465 466
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
467
mkPatSynRecSelBinds :: PatSyn
468 469 470 471
                    -> [FieldLabel]  -- ^ Visible field labels
                    -> HsValBinds Name
mkPatSynRecSelBinds ps fields
  = ValBindsOut selector_binds sigs
472
  where
473 474
    (sigs, selector_binds) = unzip (map mkRecSel fields)
    mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
475 476 477 478 479 480

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

Austin Seipp's avatar
Austin Seipp committed
481 482 483
{-
************************************************************************
*                                                                      *
484
         Constructing the "builder" Id
Austin Seipp's avatar
Austin Seipp committed
485 486 487
*                                                                      *
************************************************************************
-}
488

489
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
490 491
                  -> [TyVarBinder] -> ThetaType
                  -> [TyVarBinder] -> ThetaType
492
                  -> [Type] -> Type
493
                  -> TcM (Maybe (Id, Bool))
494 495
mkPatSynBuilderId dir (L _ name)
                  univ_bndrs req_theta ex_bndrs prov_theta
496
                  arg_tys pat_ty
497 498 499
  | isUnidirectional dir
  = return Nothing
  | otherwise
500
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
501
       ; let theta          = req_theta ++ prov_theta
502
             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
503
             builder_sigma  = add_void need_dummy_arg $
504 505 506 507 508
                              mkForAllTys univ_bndrs $
                              mkForAllTys ex_bndrs $
                              mkFunTys theta $
                              mkFunTys arg_tys $
                              pat_ty
509
             builder_id     = mkExportedVanillaId builder_name builder_sigma
Matthew Pickering's avatar
Matthew Pickering committed
510
              -- See Note [Exported LocalIds] in Id
511

Richard Eisenberg's avatar
Richard Eisenberg committed
512 513 514
             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id

       ; return (Just (builder_id', need_dummy_arg)) }
515
  where
516

517
tcPatSynBuilderBind :: PatSynBind Name Name
518 519
                    -> TcM (LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
520 521
tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
                         , psb_dir = dir, psb_args = details })
522 523 524
  | isUnidirectional dir
  = return emptyBag

525
  | Left why <- mb_match_group       -- Can't invert the pattern
526
  = setSrcSpan (getLoc lpat) $ failWithTc $
527 528 529 530
    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                 <+> quotes (ppr name) <> colon)
              2 why
         , text "RHS pattern:" <+> ppr lpat ]
531

532
  | Right match_group <- mb_match_group  -- Bidirectional
533
  = do { patsyn <- tcLookupPatSyn name
534
       ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
535 536 537 538 539
                   -- Bidirectional, so patSynBuilder returns Just

             match_group' | need_dummy_arg = add_dummy_arg match_group
                          | otherwise      = match_group

540
             bind = FunBind { fun_id      = L loc (idName builder_id)
541 542 543 544 545
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , bind_fvs    = placeHolderNamesTc
                            , fun_tick    = [] }

546
             sig = completeSigFromId (PatSynCtxt name) builder_id
547

548 549
       ; traceTc "tcPatSynBuilderBind {" $
         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
550
       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
551 552
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
       ; return builder_binds }
553 554

  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
555
  where
556
    mb_match_group
557
       = case dir of
558
           ExplicitBidirectional explicit_mg -> Right explicit_mg
559
           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)
560
           Unidirectional -> panic "tcPatSynBuilderBind"
561 562

    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
563
    mk_mg body = mkMatchGroup Generated [builder_match]
564
             where
565
               builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
Ben Gamari's avatar
Ben Gamari committed
566
               builder_match = mkMatch (mkPrefixFunRhs (L loc name))
567 568
                                       builder_args body
                                       (noLoc EmptyLocalBinds)
569 570

    args = case details of
571
              PrefixPatSyn args     -> args
572
              InfixPatSyn arg1 arg2 -> [arg1, arg2]
Matthew Pickering's avatar
Matthew Pickering committed
573
              RecordPatSyn args     -> map recordPatSynPatVar args
574

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
575 576
    add_dummy_arg :: MatchGroup Name (LHsExpr Name)
                  -> MatchGroup Name (LHsExpr Name)
577 578
    add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })
      = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
579
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
580
                             pprMatches other_mg
581

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
582 583 584
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)
-- monadic only for failure
tcPatSynBuilderOcc ps
585
  | Just (builder_id, add_void_arg) <- builder
Richard Eisenberg's avatar
Richard Eisenberg committed
586
  , let builder_expr = HsConLikeOut (PatSynCon ps)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
587 588 589
        builder_ty   = idType builder_id
  = return $
    if add_void_arg
Richard Eisenberg's avatar
Richard Eisenberg committed
590 591
    then ( builder_expr   -- still just return builder_expr; the void# arg is added
                          -- by dsConLike in the desugarer
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
592 593
         , tcFunResultTy builder_ty )
    else (builder_expr, builder_ty)
594 595

  | otherwise  -- Unidirectional
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
596
  = nonBidirectionalErr name
597 598 599
  where
    name    = patSynName ps
    builder = patSynBuilder ps
cactus's avatar
cactus committed
600

601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659
add_void :: Bool -> Type -> Type
add_void need_dummy_arg ty
  | need_dummy_arg = mkFunTy voidPrimTy ty
  | otherwise      = ty

tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name)
-- Given a /pattern/, return an /expression/ that builds a value
-- that matches the pattern.  E.g. if the pattern is (Just [x]),
-- the expression is (Just [x]).  They look the same, but the
-- input uses constructors from HsPat and the output uses constructors
-- from HsExpr.
--
-- Returns (Left r) if the pattern is not invertible, for reason r.
-- See Note [Builder for a bidirectional pattern synonym]
tcPatToExpr args pat = go pat
  where
    lhsVars = mkNameSet (map unLoc args)

    -- Make a prefix con for prefix and infix patterns for simplicity
    mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name)
    mkPrefixConExpr lcon@(L loc _) pats
      = do { exprs <- mapM go pats
           ; return (foldl (\x y -> HsApp (L loc x) y)
                           (HsVar lcon) exprs) }

    mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name)
                    -> Either MsgDoc (HsExpr Name)
    mkRecordConExpr con fields
      = do { exprFields <- mapM go fields
           ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }

    go :: LPat Name -> Either MsgDoc (LHsExpr Name)
    go (L loc p) = L loc <$> go1 p

    go1 :: Pat Name -> Either MsgDoc (HsExpr Name)
    go1 (ConPatIn con info)
      = case info of
          PrefixCon ps  -> mkPrefixConExpr con ps
          InfixCon l r  -> mkPrefixConExpr con [l,r]
          RecCon fields -> mkRecordConExpr con fields

    go1 (SigPatIn pat _) = go1 (unLoc pat)
        -- See Note [Type signatures and the builder expression]

    go1 (VarPat (L l var))
        | var `elemNameSet` lhsVars
        = return $ HsVar (L l var)
        | otherwise
        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
    go1 (ParPat pat)                = fmap HsPar $ go pat
    go1 (LazyPat pat)               = go1 (unLoc pat)
    go1 (BangPat pat)               = go1 (unLoc pat)
    go1 (PArrPat pats ptt)          = do { exprs <- mapM go pats
                                         ; return $ ExplicitPArr ptt exprs }
    go1 (ListPat pats ptt reb)      = do { exprs <- mapM go pats
                                         ; return $ ExplicitList ptt (fmap snd reb) exprs }
    go1 (TuplePat pats box _)       = do { exprs <- mapM go pats
                                         ; return $ ExplicitTuple
                                              (map (noLoc . Present) exprs) box }
660 661 662
    go1 (SumPat pat alt arity _)    = do { expr <- go1 (unLoc pat)
                                         ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder
                                         }
663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692
    go1 (LitPat lit)                = return $ HsLit lit
    go1 (NPat (L _ n) mb_neg _ _)
        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
        | otherwise                 = return $ HsOverLit n
    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
    go1 (SigPatOut{})               = panic "SigPatOut in output of renamer"
    go1 (CoPat{})                   = panic "CoPat in output of renamer"
    go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")

{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For a bidirectional pattern synonym we need to produce an /expression/
that matches the supplied /pattern/, given values for the arguments
of the pattern synoymy.  For example
  pattern F x y = (Just x, [y])
The 'builder' for F looks like
  $builderF x y = (Just x, [y])

We can't always do this:
 * Some patterns aren't invertible; e.g. view patterns
      pattern F x = (reverse -> x:_)

 * The RHS pattern might bind more variables than the pattern
   synonym, so again we can't invert it
      pattern F x = (x,y)

 * Ditto wildcards
      pattern F x = (x,_)


693 694 695 696 697 698
Note [Redundant constraints for builder]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The builder can have redundant constraints, which are awkard to eliminate.
Consider
   pattern P = Just 34
To match against this pattern we need (Eq a, Num a).  But to build
699 700
(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
sig_warn_redundant to False.
701

Austin Seipp's avatar
Austin Seipp committed
702 703
************************************************************************
*                                                                      *
704
         Helper functions
Austin Seipp's avatar
Austin Seipp committed
705 706
*                                                                      *
************************************************************************
707

708 709
Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
710 711 712
The rationale for rejecting as-patterns in pattern synonym definitions
is that an as-pattern would introduce nonindependent pattern synonym
arguments, e.g. given a pattern synonym like:
713 714 715 716 717 718

        pattern K x y = x@(Just y)

one could write a nonsensical function like

        f (K Nothing x) = ...
cactus's avatar
cactus committed
719

720 721
or
        g (K (Just True) False) = ...
722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741

Note [Type signatures and the builder expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   pattern L x = Left x :: Either [a] [b]

In tc{Infer/Check}PatSynDecl we will check that the pattern has the
specified type.  We check the pattern *as a pattern*, so the type
signature is a pattern signature, and so brings 'a' and 'b' into
scope.  But we don't have a way to bind 'a, b' in the LHS, as we do
'x', say.  Nevertheless, the sigature may be useful to constrain
the type.

When making the binding for the *builder*, though, we don't want
  $buildL x = Left x :: Either [a] [b]
because that wil either mean (forall a b. Either [a] [b]), or we'll
get a complaint that 'a' and 'b' are out of scope. (Actually the
latter; Trac #9867.)  No, the job of the signature is done, so when
converting the pattern to an expression (for the builder RHS) we
simply discard the signature.
Matthew Pickering's avatar
Matthew Pickering committed
742 743 744 745 746 747 748 749

Note [Record PatSyn Desugaring]
-------------------------------
It is important that prov_theta comes before req_theta as this ordering is used
when desugaring record pattern synonym updates.

Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
want to avoid difficult to decipher core lint errors!
750
 -}
751

752 753 754 755 756 757 758 759 760 761
tcCheckPatSynPat :: LPat Name -> TcM ()
tcCheckPatSynPat = go
  where
    go :: LPat Name -> TcM ()
    go = addLocM go1

    go1 :: Pat Name -> TcM ()
    go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)
    go1   VarPat{}            = return ()
    go1   WildPat{}           = return ()
762
    go1 p@(AsPat _ _)         = asPatInPatSynErr p
763 764 765 766 767 768
    go1   (LazyPat pat)       = go pat
    go1   (ParPat pat)        = go pat
    go1   (BangPat pat)       = go pat
    go1   (PArrPat pats _)    = mapM_ go pats
    go1   (ListPat pats _ _)  = mapM_ go pats
    go1   (TuplePat pats _ _) = mapM_ go pats
769
    go1   (SumPat pat _ _ _)  = go pat
770 771
    go1   LitPat{}            = return ()
    go1   NPat{}              = return ()
772 773 774 775 776 777 778 779
    go1   (SigPatIn pat _)    = go pat
    go1   (ViewPat _ pat _)   = go pat
    go1 p@SplicePat{}         = thInPatSynErr p
    go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p
    go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
    go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
    go1   CoPat{}             = panic "CoPat in output of renamer"

780
asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
781 782
asPatInPatSynErr pat
  = failWithTc $
783
    hang (text "Pattern synonym definition cannot contain as-patterns (@):")
784 785
       2 (ppr pat)

786
thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
787 788
thInPatSynErr pat
  = failWithTc $
789
    hang (text "Pattern synonym definition cannot contain Template Haskell:")
790 791
       2 (ppr pat)

792
nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
793 794
nPlusKPatInPatSynErr pat
  = failWithTc $
795
    hang (text "Pattern synonym definition cannot contain n+k-pattern:")
796 797
       2 (ppr pat)

Matthew Pickering's avatar
Matthew Pickering committed
798 799
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
800 801
    text "non-bidirectional pattern synonym"
    <+> quotes (ppr name) <+> text "used in an expression"
Matthew Pickering's avatar
Matthew Pickering committed
802

803 804 805 806 807 808
-- Walk the whole pattern and for all ConPatOuts, collect the
-- existentially-bound type variables and evidence binding variables.
--
-- These are used in computing the type of a pattern synonym and also
-- in generating matcher functions, since success continuations need
-- to be passed these pattern-bound evidences.
809 810
tcCollectEx
  :: LPat Id
811 812 813 814 815
  -> ( [TyVar]        -- Existentially-bound type variables
                      -- in correctly-scoped order; e.g. [ k:*, x:k ]
     , [EvVar] )      -- and evidence variables

tcCollectEx pat = go pat
cactus's avatar
cactus committed
816
  where
817
    go :: LPat Id -> ([TyVar], [EvVar])
cactus's avatar
cactus committed
818 819
    go = go1 . unLoc

820
    go1 :: Pat Id -> ([TyVar], [EvVar])
cactus's avatar
cactus committed
821 822 823 824
    go1 (LazyPat p)         = go p
    go1 (AsPat _ p)         = go p
    go1 (ParPat p)          = go p
    go1 (BangPat p)         = go p
825 826
    go1 (ListPat ps _ _)    = mergeMany . map go $ ps
    go1 (TuplePat ps _ _)   = mergeMany . map go $ ps
827
    go1 (SumPat p _ _ _)    = go p
828
    go1 (PArrPat ps _)      = mergeMany . map go $ ps
cactus's avatar
cactus committed
829
    go1 (ViewPat _ p _)     = go p
830 831
    go1 con@ConPatOut{}     = merge (pat_tvs con, pat_dicts con) $
                              goConDetails $ pat_args con
cactus's avatar
cactus committed
832 833
    go1 (SigPatOut p _)     = go p
    go1 (CoPat _ p _)       = go1 p
834
    go1 (NPlusKPat n k _ geq subtract _)
cactus's avatar
cactus committed
835
      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
836
    go1 _                   = empty
cactus's avatar
cactus committed
837

838
    goConDetails :: HsConPatDetails Id -> ([TyVar], [EvVar])
839 840
    goConDetails (PrefixCon ps) = mergeMany . map go $ ps
    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
cactus's avatar
cactus committed
841
    goConDetails (RecCon HsRecFields{ rec_flds = flds })
842
      = mergeMany . map goRecFd $ flds
cactus's avatar
cactus committed
843

844
    goRecFd :: LHsRecField Id (LPat Id) -> ([TyVar], [EvVar])
845
    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p
846

847
    merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
848
    mergeMany = foldr merge empty
849
    empty     = ([], [])