TcPatSyn.hs 40.5 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

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

8 9
{-# LANGUAGE CPP #-}

10
module TcPatSyn ( tcPatSynSig, tcInferPatSynDecl, tcCheckPatSynDecl
Matthew Pickering's avatar
Matthew Pickering committed
11
                , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
12
  ) where
Gergő Érdi's avatar
Gergő Érdi committed
13 14 15

import HsSyn
import TcPat
16
import TcHsType( tcImplicitTKBndrs, tcExplicitTKBndrs
17
               , tcHsContext, tcHsLiftedType, tcHsOpenType )
Gergő Érdi's avatar
Gergő Érdi committed
18 19 20 21
import TcRnMonad
import TcEnv
import TcMType
import TysPrim
22
import TysWiredIn  ( runtimeRepTy )
Gergő Érdi's avatar
Gergő Érdi committed
23 24 25 26 27 28 29 30 31
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
import Id
32
import IdInfo( RecSelParent(..))
Gergő Érdi's avatar
Gergő Érdi committed
33 34 35
import TcBinds
import BasicTypes
import TcSimplify
36
import TcUnify
Gergő Érdi's avatar
Gergő Érdi committed
37
import TcType
38
import Type
39 40
import TcEvidence
import BuildTyCl
Gergő Érdi's avatar
Gergő Érdi committed
41
import VarSet
42
import MkId
43
import TcTyDecls
Matthew Pickering's avatar
Matthew Pickering committed
44 45
import ConLike
import FieldLabel
Gergő Érdi's avatar
Gergő Érdi committed
46
import Bag
47
import Util
48
import ErrUtils
49 50 51
import Control.Monad ( unless, zipWithM )
import Data.List( partition )
import Pair( Pair(..) )
Gergő Érdi's avatar
Gergő Érdi committed
52 53 54

#include "HsVersions.h"

55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
{- *********************************************************************
*                                                                      *
        Type checking a pattern synonym signature
*                                                                      *
************************************************************************

Note [Pattern synonym signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example).
In general they look like this:

   pattern P :: forall univ_tvs. req
             => forall ex_tvs. prov
             => arg1 -> .. -> argn -> body_ty

For parsing and renaming we treat the signature as an ordinary LHsSigType.

Once we get to type checking, we decompose it into its parts, in tcPatSynSig.

* Note that 'forall univ_tvs' and 'req =>'
        and 'forall ex_tvs'   and 'prov =>'
  are all optional.  We gather the pieces at the the top of tcPatSynSig

* Initially the implicitly-bound tyvars (added by the renamer) include both
  universal and existential vars.

* After we kind-check the pieces and convert to Types, we do kind generalisation.

* Note [Splitting the implicit tyvars in a pattern synonym]
  Now the tricky bit: we must split
     the implicitly-bound variables, and
     the kind-generalised variables
  into universal and existential.  We do so as follows:

     Note [The pattern-synonym signature splitting rule]
     the universals are the ones mentioned in
          - univ_tvs (and the kinds thereof)
Rik Steenkamp's avatar
Rik Steenkamp committed
92
          - req
93
          - body_ty
Rik Steenkamp's avatar
Rik Steenkamp committed
94
     the existentials are the rest
95 96 97 98 99 100 101 102 103 104 105 106 107 108

* Moreover see Note
-}

tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo
tcPatSynSig name sig_ty
  | HsIB { hsib_vars = implicit_hs_tvs
         , hsib_body = hs_ty }  <- sig_ty
  , (univ_hs_tvs, hs_req,  hs_ty1) <- splitLHsSigmaTy hs_ty
  , (ex_hs_tvs,   hs_prov, hs_ty2) <- splitLHsSigmaTy hs_ty1
  , (hs_arg_tys, hs_body_ty)       <- splitHsFunType  hs_ty2
  = do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty))
           <- solveEqualities $
              tcImplicitTKBndrs implicit_hs_tvs $
109 110
              tcExplicitTKBndrs univ_hs_tvs  $ \ univ_tvs ->
              tcExplicitTKBndrs ex_hs_tvs    $ \ ex_tvs   ->
111 112 113 114 115 116 117 118 119 120 121 122
              do { req     <- tcHsContext hs_req
                 ; prov    <- tcHsContext hs_prov
                 ; arg_tys <- mapM tcHsOpenType (hs_arg_tys :: [LHsType Name])
                 ; body_ty <- tcHsLiftedType hs_body_ty
                 ; let bound_tvs
                         = unionVarSets [ allBoundVariabless req
                                        , allBoundVariabless prov
                                        , allBoundVariabless (body_ty : arg_tys)
                                        ]
                 ; return ( (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty)
                          , bound_tvs) }

123
       -- Kind generalisation; c.f. kindGeneralise
124 125 126 127 128 129 130 131 132
       ; free_kvs <- zonkTcTypeAndFV $
                     mkSpecForAllTys (implicit_tvs ++ univ_tvs) $
                     mkFunTys req $
                     mkSpecForAllTys ex_tvs $
                     mkFunTys prov $
                     mkFunTys arg_tys $
                     body_ty

       ; kvs <- quantifyZonkedTyVars emptyVarSet (Pair free_kvs emptyVarSet)
133

134
       -- These are /signatures/ so we zonk to squeeze out any kind
135 136
       -- unification variables.  Do this after quantifyTyVars which may
       -- default kind variables to *.
137
       -- ToDo: checkValidType?
138
       ; traceTc "about zonk" empty
139 140 141 142 143 144 145 146 147 148 149 150 151
       ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs
       ; univ_tvs     <- mapM zonkTcTyCoVarBndr univ_tvs
       ; ex_tvs       <- mapM zonkTcTyCoVarBndr ex_tvs
       ; req          <- zonkTcTypes req
       ; prov         <- zonkTcTypes prov
       ; arg_tys      <- zonkTcTypes arg_tys
       ; body_ty      <- zonkTcType  body_ty

       -- Complain about:  pattern P :: () => forall x. x -> P x
       -- The renamer thought it was fine, but the existential 'x'
       -- should not appear in the result type
       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType body_ty) ex_tvs
       ; unless (null bad_tvs) $ addErr $
152 153
         hang (text "The result type" <+> quotes (ppr body_ty))
            2 (text "mentions existential type variable" <> plural bad_tvs
154 155 156 157 158
               <+> pprQuotedList bad_tvs)

         -- Split [Splitting the implicit tyvars in a pattern synonym]
       ; let univ_fvs = closeOverKinds $
                        (tyCoVarsOfTypes (body_ty : req) `extendVarSetList` univ_tvs)
159 160 161 162
             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) .
                                                 binderVar "tcPatSynSig") $
                                      mkNamedBinders Invisible kvs ++
                                      mkNamedBinders Specified implicit_tvs
163
       ; traceTc "tcTySig }" $
164 165
         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
              , text "kvs" <+> ppr_tvs kvs
166
              , text "extra_univ" <+> ppr extra_univ
167
              , text "univ_tvs" <+> ppr_tvs univ_tvs
168
              , text "req" <+> ppr req
169
              , text "extra_ex" <+> ppr extra_ex
170
              , text "ex_tvs" <+> ppr_tvs ex_tvs
171 172 173 174
              , text "prov" <+> ppr prov
              , text "arg_tys" <+> ppr arg_tys
              , text "body_ty" <+> ppr body_ty ]
       ; return (TPSI { patsig_name = name
175 176 177 178 179 180 181 182
                      , patsig_univ_bndrs = extra_univ ++
                                            mkNamedBinders Specified univ_tvs
                      , patsig_req        = req
                      , patsig_ex_bndrs   = extra_ex   ++
                                            mkNamedBinders Specified ex_tvs
                      , patsig_prov       = prov
                      , patsig_arg_tys    = arg_tys
                      , patsig_body_ty    = body_ty }) }
183 184 185 186 187
  where

ppr_tvs :: [TyVar] -> SDoc
ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
                           | tv <- tvs])
188 189


Austin Seipp's avatar
Austin Seipp committed
190 191 192
{-
************************************************************************
*                                                                      *
193
                    Type checking a pattern synonym
Austin Seipp's avatar
Austin Seipp committed
194 195 196
*                                                                      *
************************************************************************
-}
197

198
tcInferPatSynDecl :: PatSynBind Name Name
199
                  -> TcM (LHsBinds Id, TcGblEnv)
200
tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
201
                       psb_def = lpat, psb_dir = dir }
202
  = addPatSynCtxt lname $
203
    do { traceTc "tcInferPatSynDecl {" $ ppr name
204
       ; tcCheckPatSynPat lpat
Gergő Érdi's avatar
Gergő Érdi committed
205

Matthew Pickering's avatar
Matthew Pickering committed
206
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
207
       ; (tclvl, wanted, ((lpat', args), pat_ty))
208
            <- pushLevelAndCaptureConstraints  $
209 210 211 212 213
               do { pat_ty <- newOpenInferExpType
                  ; stuff <- tcPat PatSyn lpat pat_ty $
                             mapM tcLookupId arg_names
                  ; pat_ty <- readExpType pat_ty
                  ; return (stuff, pat_ty) }
214 215

       ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
Gergő Érdi's avatar
Gergő Érdi committed
216

217
       ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
Gergő Érdi's avatar
Gergő Érdi committed
218

219 220
       ; let (ex_vars, prov_dicts) = tcCollectEx lpat'
             univ_tvs   = filter (not . (`elemVarSet` ex_vars)) qtvs
221 222 223
             ex_tvs     = varSetElems ex_vars
             prov_theta = map evVarPred prov_dicts
             req_theta  = map evVarPred req_dicts
Gergő Érdi's avatar
Gergő Érdi committed
224

225
       ; traceTc "tcInferPatSynDecl }" $ ppr name
226 227 228 229 230
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, mkNamedBinders Invisible univ_tvs
                            , req_theta,  ev_binds, req_dicts)
                          (ex_tvs,   mkNamedBinders Invisible ex_tvs
                            , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
231
                          (map nlHsVar args, map idType args)
Matthew Pickering's avatar
Matthew Pickering committed
232 233
                          pat_ty rec_fields }

234 235 236

tcCheckPatSynDecl :: PatSynBind Name Name
                  -> TcPatSynInfo
237
                  -> TcM (LHsBinds Id, TcGblEnv)
238 239
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                         , psb_def = lpat, psb_dir = dir }
240 241 242
                  TPSI{ patsig_univ_bndrs = univ_bndrs, patsig_prov = prov_theta
                      , patsig_ex_bndrs   = ex_bndrs,   patsig_req  = req_theta
                      , patsig_arg_tys    = arg_tys,    patsig_body_ty = pat_ty }
243
  = addPatSynCtxt lname $
244
    do { let origin     = ProvCtxtOrigin psb
245
             skol_info  = PatSynSigSkol name
246 247 248 249
             decl_arity = length arg_names
             ty_arity   = length arg_tys
             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

250 251 252
             univ_tvs   = map (binderVar "tcCheckPatSynDecl 1") univ_bndrs
             ex_tvs     = map (binderVar "tcCheckPatSynDecl 2") ex_bndrs

253
       ; traceTc "tcCheckPatSynDecl" $
254
         vcat [ ppr univ_bndrs, ppr req_theta, ppr ex_bndrs
255 256 257 258 259
              , ppr prov_theta, ppr arg_tys, ppr pat_ty ]

       ; checkTc (decl_arity == ty_arity)
                 (wrongNumberOfParmsErr name decl_arity ty_arity)

260 261
       ; tcCheckPatSynPat lpat

262 263
       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
264
       ; req_dicts <- newEvVars req_theta
265 266
       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
267 268 269
           pushLevelAndCaptureConstraints            $
           tcExtendTyVarEnv univ_tvs                 $
           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
270 271 272
           do { (subst, ex_tvs') <- if   isUnidirectional dir
                                    then newMetaTyVars    ex_tvs
                                    else newMetaSigTyVars ex_tvs
Rik Steenkamp's avatar
Rik Steenkamp committed
273
                    -- See the "Existential type variables" part of
274
                    -- Note [Checking against a pattern signature]
275 276
              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
277 278 279 280 281 282 283
              ; prov_dicts <- mapM (emitWanted origin)
                  (substTheta (extendTCvInScopeList subst univ_tvs) prov_theta)
                  -- Add the free vars of 'prov_theta' to the in_scope set to
                  -- satisfy the substition invariant. There's no need to
                  -- add 'ex_tvs' as they are already in the domain of the
                  -- substitution.
                  -- See also Note [The substitution invariant] in TyCoRep.
284 285 286 287
              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
              ; return (ex_tvs', prov_dicts, args') }

       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
288

289 290 291
       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (Trac #10997)
       -- Since all the inputs are implications the returned bindings will be empty
292
       ; _ <- simplifyTop (mkImplicWC implics)
293 294 295 296

       -- 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
297

298
       ; traceTc "tcCheckPatSynDecl }" $ ppr name
299 300 301
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, univ_bndrs, req_theta, ev_binds, req_dicts)
                          (ex_tvs, ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
302
                          (args', arg_tys)
303
                          pat_ty rec_fields }
304
  where
305 306 307 308 309 310 311
    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)
312
                              (substTyUnchecked subst arg_ty)
313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
           ; 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
330 331
make available to matches against P), is derivable from the
actual pattern.  For example:
332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
    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

This "concealing" story works for /uni-directional/ pattern synonmys,
but obviously not for bidirectional ones.  So in the bidirectional case
we use SigTv, rather than a generic TauTv, meta-tyvar so that.  And
we should really check that those SigTvs don't get unified with each
other.

-}
363

Matthew Pickering's avatar
Matthew Pickering committed
364 365 366 367 368 369 370 371 372 373 374 375 376 377 378
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)

379 380 381
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L loc name) thing_inside
  = setSrcSpan loc $
382
    addErrCtxt (text "In the declaration for pattern synonym"
383 384 385 386 387
                <+> quotes (ppr name)) $
    thing_inside

wrongNumberOfParmsErr :: Name -> Arity -> Arity -> SDoc
wrongNumberOfParmsErr name decl_arity ty_arity
388
  = hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
389 390
          <+> speakNOf decl_arity (text "argument"))
       2 (text "but its type signature has" <+> speakN ty_arity)
391

392 393
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
Matthew Pickering's avatar
Matthew Pickering committed
394 395 396 397
tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
                 -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                 -> Bool              -- ^ Whether infix
                 -> LPat Id           -- ^ Pattern of the PatSyn
398 399
                 -> ([TcTyVar], [TcTyBinder], [PredType], TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcTyBinder], [TcType], [PredType], [EvTerm])
400
                 -> ([LHsExpr TcId], [TcType])   -- ^ Pattern arguments and types
Matthew Pickering's avatar
Matthew Pickering committed
401 402 403
                 -> TcType              -- ^ Pattern type
                 -> [Name]              -- ^ Selector names
                 -- ^ Whether fields, empty if not record PatSyn
404
                 -> TcM (LHsBinds Id, TcGblEnv)
405 406 407
tc_patsyn_finish lname dir is_infix lpat'
                 (univ_tvs, univ_bndrs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_bndrs, ex_tys, prov_theta, prov_dicts)
408
                 (args, arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
409
                 pat_ty field_labels
410 411
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there
412 413 414 415
         univ_tvs     <- mapMaybeM zonkQuantifiedTyVar univ_tvs
       ; ex_tvs       <- mapMaybeM zonkQuantifiedTyVar ex_tvs
       ; prov_theta   <- zonkTcTypes prov_theta
       ; req_theta    <- zonkTcTypes req_theta
416
       ; pat_ty       <- zonkTcType pat_ty
417
       ; arg_tys      <- zonkTcTypes arg_tys
418

419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
          -- We need to update the univ and ex binders after zonking.
          -- But zonking may have defaulted some erstwhile binders,
          -- so we need to make sure the tyvars and tybinders remain
          -- lined up
       ; let update_binders :: [TyVar] -> [TcTyBinder] -> [TyBinder]
             update_binders [] _ = []
             update_binders all_tvs@(tv:tvs) (bndr:bndrs)
               | tv == bndr_var
               = mkNamedBinder (binderVisibility bndr) tv : update_binders tvs bndrs
               | otherwise
               = update_binders all_tvs bndrs
               where
                 bndr_var = binderVar "tc_patsyn_finish" bndr
             update_binders tvs _ = pprPanic "tc_patsyn_finish" (ppr lname $$ ppr tvs)

             univ_bndrs' = update_binders univ_tvs univ_bndrs
             ex_bndrs'   = update_binders ex_tvs   ex_bndrs

437
       ; traceTc "tc_patsyn_finish {" $
438
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
439 440
           ppr (univ_tvs, univ_bndrs', req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, ex_bndrs', prov_theta, prov_dicts) $$
441 442
           ppr args $$
           ppr arg_tys $$
443
           ppr pat_ty
444 445

       -- Make the 'matcher'
446
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
447
                                         (univ_tvs, req_theta, req_ev_binds, req_dicts)
448 449
                                         (ex_tvs, ex_tys, prov_theta, prov_dicts)
                                         (args, arg_tys)
Gergő Érdi's avatar
Gergő Érdi committed
450
                                         pat_ty
451

Matthew Pickering's avatar
Matthew Pickering committed
452

453
       -- Make the 'builder'
454 455 456
       ; builder_id <- mkPatSynBuilderId dir lname
                                         univ_bndrs' req_theta
                                         ex_bndrs'   prov_theta
Matthew Pickering's avatar
Matthew Pickering committed
457
                                         arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
458 459 460 461 462

         -- TODO: Make this have the proper information
       ; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
             field_labels' = (map mkFieldLabel field_labels)

Gergő Érdi's avatar
Gergő Érdi committed
463

464
       -- Make the PatSyn itself
Matthew Pickering's avatar
Matthew Pickering committed
465
       ; let patSyn = mkPatSyn (unLoc lname) is_infix
466 467
                        (univ_tvs, univ_bndrs', req_theta)
                        (ex_tvs, ex_bndrs', prov_theta)
468
                        arg_tys
Gergő Érdi's avatar
Gergő Érdi committed
469
                        pat_ty
470
                        matcher_id builder_id
Matthew Pickering's avatar
Matthew Pickering committed
471 472 473 474 475 476 477 478 479 480 481
                        field_labels'

       -- Selectors
       ; let (sigs, selector_binds) =
                unzip (mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn))
       ; let tything = AConLike (PatSynCon patSyn)
       ; tcg_env <-
          tcExtendGlobalEnv [tything] $
            tcRecSelBinds
              (ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs)

482
       ; traceTc "tc_patsyn_finish }" empty
483
       ; return (matcher_bind, tcg_env) }
484

Austin Seipp's avatar
Austin Seipp committed
485 486 487
{-
************************************************************************
*                                                                      *
488
         Constructing the "matcher" Id and its binding
Austin Seipp's avatar
Austin Seipp committed
489 490 491
*                                                                      *
************************************************************************
-}
492

493
tcPatSynMatcher :: Located Name
Gergő Érdi's avatar
Gergő Érdi committed
494
                -> LPat Id
495
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
496 497
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                -> ([LHsExpr TcId], [TcType])
Gergő Érdi's avatar
Gergő Érdi committed
498
                -> TcType
499 500
                -> TcM ((Id, Bool), LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
501
tcPatSynMatcher (L loc name) lpat
502
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
503 504
                (ex_tvs, ex_tys, prov_theta, prov_dicts)
                (args, arg_tys) pat_ty
505 506 507
  = do { rr_uniq <- newUnique
       ; tv_uniq <- newUnique
       ; let rr_name  = mkInternalName rr_uniq (mkTyVarOcc "rep") loc
508
             tv_name  = mkInternalName tv_uniq (mkTyVarOcc "r") loc
509 510 511
             rr_tv    = mkTcTyVar rr_name runtimeRepTy (SkolemTv False)
             rr       = mkTyVarTy rr_tv
             res_tv   = mkTcTyVar tv_name  (tYPE rr) (SkolemTv False)
512
             is_unlifted = null args && null prov_dicts
513
             res_ty = mkTyVarTy res_tv
514 515 516
             (cont_args, cont_arg_tys)
               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
               | otherwise   = (args,                 arg_tys)
517
             cont_ty = mkInvSigmaTy ex_tvs prov_theta $
518 519
                       mkFunTys cont_arg_tys res_ty

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
520
             fail_ty  = mkFunTy voidPrimTy res_ty
521

522
       ; matcher_name <- newImplicitBinder name mkMatcherOcc
523 524 525 526 527
       ; 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
528
             matcher_sigma = mkInvSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
529
             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
530
                             -- See Note [Exported LocalIds] in Id
531

532 533
             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
             cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
Gergő Érdi's avatar
Gergő Érdi committed
534

535
             fail' = nlHsApps fail [nlHsVar voidPrimId]
Gergő Érdi's avatar
Gergő Érdi committed
536

537
             args = map nlVarPat [scrutinee, cont, fail]
Gergő Érdi's avatar
Gergő Érdi committed
538 539 540 541 542
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
                     then [mkSimpleHsAlt lpat  cont']
                     else [mkSimpleHsAlt lpat  cont',
                           mkSimpleHsAlt lwpat fail']
543
             body = mkLHsWrap (mkWpLet req_ev_binds) $
Gergő Érdi's avatar
Gergő Érdi committed
544 545
                    L (getLoc lpat) $
                    HsCase (nlHsVar scrutinee) $
546
                    MG{ mg_alts = L (getLoc lpat) cases
Gergő Érdi's avatar
Gergő Érdi committed
547 548
                      , mg_arg_tys = [pat_ty]
                      , mg_res_ty = res_ty
549
                      , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
550 551 552
                      }
             body' = noLoc $
                     HsLam $
553
                     MG{ mg_alts = noLoc [mkSimpleMatch args body]
Gergő Érdi's avatar
Gergő Érdi committed
554 555
                       , mg_arg_tys = [pat_ty, cont_ty, res_ty]
                       , mg_res_ty = res_ty
556
                       , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
557
                       }
558
             match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body')
559 560
                             (noLoc EmptyLocalBinds)
             mg = MG{ mg_alts = L (getLoc match) [match]
Gergő Érdi's avatar
Gergő Érdi committed
561 562
                    , mg_arg_tys = []
                    , mg_res_ty = res_ty
563
                    , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
564 565
                    }

566
       ; let bind = FunBind{ fun_id = L loc matcher_id
Gergő Érdi's avatar
Gergő Érdi committed
567 568 569
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
                           , bind_fvs = emptyNameSet
570
                           , fun_tick = [] }
571
             matcher_bind = unitBag (noLoc bind)
Gergő Érdi's avatar
Gergő Érdi committed
572

573
       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
Gergő Érdi's avatar
Gergő Érdi committed
574 575
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

576 577
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
578 579 580 581
mkPatSynRecSelBinds :: PatSyn
                    -> [FieldLabel]
                    -- ^ Visible field labels
                    -> [(LSig Name, LHsBinds Name)]
582 583 584 585 586
mkPatSynRecSelBinds ps fields = map mkRecSel fields
  where
    mkRecSel fld_lbl =
      case mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl of
        (name, (_rec_flag, binds)) -> (name, binds)
587 588 589 590 591 592

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

Austin Seipp's avatar
Austin Seipp committed
593 594 595
{-
************************************************************************
*                                                                      *
596
         Constructing the "builder" Id
Austin Seipp's avatar
Austin Seipp committed
597 598 599
*                                                                      *
************************************************************************
-}
600

601 602 603
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
                  -> [TyBinder] -> ThetaType
                  -> [TyBinder] -> ThetaType
604
                  -> [Type] -> Type
605
                  -> TcM (Maybe (Id, Bool))
606 607
mkPatSynBuilderId dir (L _ name)
                  univ_bndrs req_theta ex_bndrs prov_theta
608
                  arg_tys pat_ty
609 610 611
  | isUnidirectional dir
  = return Nothing
  | otherwise
612
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
613
       ; let theta          = req_theta ++ prov_theta
614
             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
615
             builder_sigma  = add_void need_dummy_arg $
616 617 618 619 620
                              mkForAllTys univ_bndrs $
                              mkForAllTys ex_bndrs $
                              mkFunTys theta $
                              mkFunTys arg_tys $
                              pat_ty
621
             builder_id     = mkExportedVanillaId builder_name builder_sigma
Matthew Pickering's avatar
Matthew Pickering committed
622
              -- See Note [Exported LocalIds] in Id
623

624
       ; return (Just (builder_id, need_dummy_arg)) }
625
  where
626

627 628
tcPatSynBuilderBind :: TcSigFun
                    -> PatSynBind Name Name
629 630
                    -> TcM (LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
631 632
tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat
                               , psb_dir = dir, psb_args = details }
633 634 635
  | isUnidirectional dir
  = return emptyBag

636
  | Left why <- mb_match_group       -- Can't invert the pattern
637
  = setSrcSpan (getLoc lpat) $ failWithTc $
638 639 640 641
    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                 <+> quotes (ppr name) <> colon)
              2 why
         , text "RHS pattern:" <+> ppr lpat ]
642

643
  | Right match_group <- mb_match_group  -- Bidirectional
644
  = do { patsyn <- tcLookupPatSyn name
645
       ; traceTc "tcPatSynBuilderBind {" $ ppr patsyn
646
       ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
647 648 649 650 651
                   -- Bidirectional, so patSynBuilder returns Just

             match_group' | need_dummy_arg = add_dummy_arg match_group
                          | otherwise      = match_group

652
             bind = FunBind { fun_id      = L loc (idName builder_id)
653 654 655 656 657
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , bind_fvs    = placeHolderNamesTc
                            , fun_tick    = [] }

658
       ; sig <- get_builder_sig sig_fun name builder_id need_dummy_arg
659

660
       ; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind)
661 662
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
       ; return builder_binds }
663 664

  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
665
  where
666
    mb_match_group
667
       = case dir of
668
           ExplicitBidirectional explicit_mg -> Right explicit_mg
669
           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)
670
           Unidirectional -> panic "tcPatSynBuilderBind"
671 672

    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
673
    mk_mg body = mkMatchGroupName Generated [builder_match]
674
             where
675
               builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
676
               builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds)
677 678

    args = case details of
679
              PrefixPatSyn args     -> args
680
              InfixPatSyn arg1 arg2 -> [arg1, arg2]
Matthew Pickering's avatar
Matthew Pickering committed
681
              RecordPatSyn args     -> map recordPatSynPatVar args
682

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
683 684
    add_dummy_arg :: MatchGroup Name (LHsExpr Name)
                  -> MatchGroup Name (LHsExpr Name)
685 686
    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 })] }
687 688 689
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
                             pprMatches (PatSyn :: HsMatchContext Name) other_mg

690 691 692
get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo
get_builder_sig sig_fun name builder_id need_dummy_arg
  | Just (TcPatSynSig sig) <- sig_fun name
693 694 695 696 697 698
  , TPSI { patsig_univ_bndrs = univ_bndrs
         , patsig_req        = req
         , patsig_ex_bndrs   = ex_bndrs
         , patsig_prov       = prov
         , patsig_arg_tys    = arg_tys
         , patsig_body_ty    = body_ty } <- sig
699 700 701 702 703 704 705
  = -- Constuct a TcIdSigInfo from a TcPatSynInfo
    -- This does unfortunately mean that we have to know how to
    -- make the builder Id's type from the TcPatSynInfo, which
    -- duplicates the construction in mkPatSynBuilderId
    -- But we really want to use the scoped type variables from
    -- the actual sigature, so this is really the Right Thing
    return (TISI { sig_bndr  = CompleteSig builder_id
706 707 708
                 , sig_skols = [ (tyVarName tv, tv)
                               | bndr <- univ_bndrs ++ ex_bndrs
                               , let tv = binderVar "get_builder_sig" bndr ]
709 710 711
                 , sig_theta = req ++ prov
                 , sig_tau   = add_void need_dummy_arg $
                               mkFunTys arg_tys body_ty
712
                 , sig_ctxt  = PatSynBuilderCtxt name
713 714 715 716 717 718
                 , sig_loc   = getSrcSpan name })
  | otherwise
  = -- No signature, so fake up a TcIdSigInfo from the builder Id
    instTcTySigFromId builder_id
    -- See Note [Redundant constraints for builder]

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
719 720 721
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)
-- monadic only for failure
tcPatSynBuilderOcc ps
722
  | Just (builder_id, add_void_arg) <- builder
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
723 724 725 726 727 728 729
  , let builder_expr = HsVar (noLoc builder_id)
        builder_ty   = idType builder_id
  = return $
    if add_void_arg
    then ( HsApp (noLoc $ builder_expr) (nlHsVar voidPrimId)
         , tcFunResultTy builder_ty )
    else (builder_expr, builder_ty)
730 731

  | otherwise  -- Unidirectional
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
732
  = nonBidirectionalErr name
733 734 735
  where
    name    = patSynName ps
    builder = patSynBuilder ps
Gergő Érdi's avatar
Gergő Érdi committed
736

737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825
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 }
    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,_)


826 827 828 829 830 831
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
832 833
(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
sig_warn_redundant to False.
834

Austin Seipp's avatar
Austin Seipp committed
835 836
************************************************************************
*                                                                      *
837
         Helper functions
Austin Seipp's avatar
Austin Seipp committed
838 839
*                                                                      *
************************************************************************
840

841 842
Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
843 844 845
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:
846 847 848 849 850 851

        pattern K x y = x@(Just y)

one could write a nonsensical function like

        f (K Nothing x) = ...
Gergő Érdi's avatar
Gergő Érdi committed
852

853 854
or
        g (K (Just True) False) = ...
855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874

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
875 876 877 878 879 880 881 882

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!
883
 -}
884

885 886 887 888 889 890 891 892 893 894
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 ()
895
    go1 p@(AsPat _ _)         = asPatInPatSynErr p
896 897 898 899 900 901
    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
902 903
    go1   LitPat{}            = return ()
    go1   NPat{}              = return ()
904 905 906 907 908 909 910 911 912 913 914
    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"

asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
asPatInPatSynErr pat
  = failWithTc $
915
    hang (text "Pattern synonym definition cannot contain as-patterns (@):")
916 917 918 919 920
       2 (ppr pat)

thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
thInPatSynErr pat
  = failWithTc $
921
    hang (text "Pattern synonym definition cannot contain Template Haskell:")
922 923 924 925 926
       2 (ppr pat)

nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
nPlusKPatInPatSynErr pat
  = failWithTc $
927
    hang (text "Pattern synonym definition cannot contain n+k-pattern:")
928 929
       2 (ppr pat)

Matthew Pickering's avatar
Matthew Pickering committed
930 931
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
932 933
    text "non-bidirectional pattern synonym"
    <+> quotes (ppr name) <+> text "used in an expression"
Matthew Pickering's avatar
Matthew Pickering committed
934

935 936 937 938 939 940
-- 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.
941 942
tcCollectEx :: LPat Id -> (TyVarSet, [EvVar])
tcCollectEx pat = go pat
Gergő Érdi's avatar
Gergő Érdi committed
943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959
  where
    go :: LPat Id -> (TyVarSet, [EvVar])
    go = go1 . unLoc

    go1 :: Pat Id -> (TyVarSet, [EvVar])
    go1 (LazyPat p)         = go p
    go1 (AsPat _ p)         = go p
    go1 (ParPat p)          = go p
    go1 (BangPat p)         = go p
    go1 (ListPat ps _ _)    = mconcat . map go $ ps
    go1 (TuplePat ps _ _)   = mconcat . map go $ ps
    go1 (PArrPat ps _)      = mconcat . map go $ ps
    go1 (ViewPat _ p _)     = go p
    go1 con@ConPatOut{}     = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
                                 goConDetails $ pat_args con
    go1 (SigPatOut