TcPatSyn.hs 47.8 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
{-# LANGUAGE TypeFamilies #-}
11

12 13
module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
                , tcPatSynBuilderOcc, nonBidirectionalErr
14
  ) where
cactus's avatar
cactus committed
15

16 17
import GhcPrelude

cactus's avatar
cactus committed
18 19
import HsSyn
import TcPat
David Eichmann's avatar
David Eichmann committed
20
import Type( tidyTyCoVarBinders, tidyTypes, tidyType )
cactus's avatar
cactus committed
21
import TcRnMonad
22
import TcSigs( emptyPragEnv, completeSigFromId )
cactus's avatar
cactus committed
23 24
import TcEnv
import TcMType
25
import TcHsSyn
cactus's avatar
cactus committed
26 27 28 29 30 31 32 33 34
import TysPrim
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
42 43
import Type( PredTree(..), EqRel(..), classifyPredType )
import TysWiredIn
cactus's avatar
cactus committed
44
import TcType
45 46
import TcEvidence
import BuildTyCl
cactus's avatar
cactus committed
47
import VarSet
48
import MkId
49
import TcTyDecls
Matthew Pickering's avatar
Matthew Pickering committed
50 51
import ConLike
import FieldLabel
cactus's avatar
cactus committed
52
import Bag
53
import Util
54
import ErrUtils
55
import Data.Maybe( mapMaybe )
56
import Control.Monad ( zipWithM )
57
import Data.List( partition )
cactus's avatar
cactus committed
58 59 60

#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
61 62 63
{-
************************************************************************
*                                                                      *
64
                    Type checking a pattern synonym
Austin Seipp's avatar
Austin Seipp committed
65 66 67
*                                                                      *
************************************************************************
-}
68

69 70 71
tcPatSynDecl :: PatSynBind GhcRn GhcRn
             -> Maybe TcSigInfo
             -> TcM (LHsBinds GhcTc, TcGblEnv)
72 73
tcPatSynDecl psb mb_sig
  = recoverM (recoverPSB psb) $
74 75 76
    case mb_sig of
      Nothing                 -> tcInferPatSynDecl psb
      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
77 78 79 80 81 82 83 84 85 86 87
      _                       -> panic "tcPatSynDecl"

recoverPSB :: PatSynBind GhcRn GhcRn
           -> TcM (LHsBinds GhcTc, TcGblEnv)
-- See Note [Pattern synonym error recovery]
recoverPSB (PSB { psb_id = L _ name, psb_args = details })
 = do { matcher_name <- newImplicitBinder name mkMatcherOcc
      ; let placeholder = AConLike $ PatSynCon $
                          mk_placeholder matcher_name
      ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
      ; return (emptyBag, gbl_env) }
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
  where
    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
    mk_placeholder matcher_name
      = mkPatSyn name is_infix
                        ([mkTyVarBinder Specified alphaTyVar], []) ([], [])
                        [] -- Arg tys
                        alphaTy
                        (matcher_id, True) Nothing
                        []  -- Field labels
       where
         -- The matcher_id is used only by the desugarer, so actually
         -- and error-thunk would probably do just as well here.
         matcher_id = mkLocalId matcher_name $
                      mkSpecForAllTys [alphaTyVar] alphaTy

103
recoverPSB (XPatSynBind {}) = panic "recoverPSB"
104 105 106

{- Note [Pattern synonym error recovery]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
107
If type inference for a pattern synonym fails, we can't continue with
108 109 110 111
the rest of tc_patsyn_finish, because we may get knock-on errors, or
even a crash.  E.g. from
   pattern What = True :: Maybe
we get a kind error; and we must stop right away (Trac #15289).
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130

We stop if there are /any/ unsolved constraints, not just insoluble
ones; because pattern synonyms are top-level things, we will never
solve them later if we can't solve them now.  And if we were to carry
on, tc_patsyn_finish does zonkTcTypeToType, which defaults any
unsolved unificatdion variables to Any, which confuses the error
reporting no end (Trac #15685).

So we use simplifyTop to completely solve the constraint, report
any errors, throw an exception.

Even in the event of such an error we can recover and carry on, just
as we do for value bindings, provided we plug in placeholder for the
pattern synonym: see recoverPSB.  The goal of the placeholder is not
to cause a raft of follow-on errors.  I've used the simplest thing for
now, but we might need to elaborate it a bit later.  (e.g.  I've given
it zero args, which may cause knock-on errors if it is used in a
pattern.) But it'll do for now.

131 132
-}

133 134
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
135 136
tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
                       , psb_def = lpat, psb_dir = dir })
137
  = addPatSynCtxt lname $
138
    do { traceTc "tcInferPatSynDecl {" $ ppr name
cactus's avatar
cactus committed
139

Matthew Pickering's avatar
Matthew Pickering committed
140
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
141
       ; (tclvl, wanted, ((lpat', args), pat_ty))
142
            <- pushLevelAndCaptureConstraints  $
143 144
               tcInferNoInst                   $ \ exp_ty ->
               tcPat PatSyn lpat exp_ty        $
145
               mapM tcLookupId arg_names
146 147

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

149
       ; (qtvs, req_dicts, ev_binds, residual, _)
150
               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted
151 152
       ; top_ev_binds <- checkNoErrs (simplifyTop residual)
       ; addTopEvBinds top_ev_binds $
153

154
    do { let (ex_tvs, prov_dicts) = tcCollectEx lpat'
155 156
             ex_tv_set  = mkVarSet ex_tvs
             univ_tvs   = filterOut (`elemVarSet` ex_tv_set) qtvs
157
             req_theta  = map evVarPred req_dicts
cactus's avatar
cactus committed
158

159 160 161
       ; prov_dicts <- mapM zonkId prov_dicts
       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
             -- Filtering: see Note [Remove redundant provided dicts]
162 163
             (prov_theta, prov_evs)
                 = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
164 165 166 167 168 169 170 171 172

       -- Report coercions that esacpe
       -- See Note [Coercions that escape]
       ; args <- mapM zonkId args
       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
                              , let bad_cos = filterDVarSet isId $
                                              (tyCoVarsOfTypeDSet (idType arg))
                              , not (isEmptyDVarSet bad_cos) ]
       ; mapM_ dependentArgErr bad_args
173

174
       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
175
       ; tc_patsyn_finish lname dir is_infix lpat'
176
                          (mkTyVarBinders Inferred univ_tvs
177
                            , req_theta,  ev_binds, req_dicts)
178
                          (mkTyVarBinders Inferred ex_tvs
179
                            , mkTyVarTys ex_tvs, prov_theta, prov_evs)
180
                          (map nlHsVar args, map idType args)
181
                          pat_ty rec_fields } }
182
tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"
Matthew Pickering's avatar
Matthew Pickering committed
183

184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
-- See Note [Equality evidence in pattern synonyms]
mkProvEvidence ev_id
  | EqPred r ty1 ty2 <- classifyPredType pred
  , let k1 = typeKind ty1
        k2 = typeKind ty2
        is_homo = k1 `tcEqType` k2
        homo_tys   = [k1, ty1, ty2]
        hetero_tys = [k1, k2, ty1, ty2]
  = case r of
      ReprEq | is_homo
             -> Just ( mkClassPred coercibleClass    homo_tys
                     , evDataConApp coercibleDataCon homo_tys eq_con_args )
             | otherwise -> Nothing
      NomEq  | is_homo
             -> Just ( mkClassPred eqClass    homo_tys
                     , evDataConApp eqDataCon homo_tys eq_con_args )
             | otherwise
             -> Just ( mkClassPred heqClass    hetero_tys
                     , evDataConApp heqDataCon hetero_tys eq_con_args )

  | otherwise
  = Just (pred, EvExpr (evId ev_id))
  where
    pred = evVarPred ev_id
    eq_con_args = [evId ev_id]

211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr (arg, bad_cos)
  = addErrTc $
    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
         , hang (text "Pattern-bound variable")
              2 (ppr arg <+> dcolon <+> ppr (idType arg))
         , nest 2 $
           hang (text "has a type that mentions pattern-bound coercion"
                 <> plural bad_co_list <> colon)
              2 (pprWithCommas ppr bad_co_list)
         , text "Hint: use -fprint-explicit-coercions to see the coercions"
         , text "Probable fix: add a pattern signature" ]
  where
    bad_co_list = dVarSetElems bad_cos

227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
{- Note [Remove redundant provided dicts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that
   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
                                       => a1 :~~: a2
(NB: technically the (k1~k2) existential dictionary is not necessary,
but it's there at the moment.)

Now consider (Trac #14394):
   pattern Foo = HRefl
in a non-poly-kinded module.  We don't want to get
    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
with that redundant (* ~ *).  We'd like to remove it; hence the call to
mkMinimalWithSCs.

Similarly consider
  data S a where { MkS :: Ord a => a -> S a }
  pattern Bam x y <- (MkS (x::a), MkS (y::a)))

The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
need one.  Agian mkMimimalWithSCs removes the redundant one.
248

249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
Note [Equality evidence in pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data X a where
     MkX :: Eq a => [a] -> X (Maybe a)
  pattern P x = MkG x

Then there is a danger that GHC will infer
  P :: forall a.  () =>
       forall b. (a ~# Maybe b, Eq b) => [b] -> X a

The 'builder' for P, which is called in user-code, will then
have type
  $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a

and that is bad because (a ~# Maybe b) is not a predicate type
(see Note [Types for coercions, predicates, and evidence] in Type)
and is not implicitly instantiated.

So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and
marginally less efficient, if the builder/martcher are not inlined.

See also Note [Lift equality constaints when quantifying] in TcType

273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299
Note [Coercions that escape]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trac #14507 showed an example where the inferred type of the matcher
for the pattern synonym was somethign like
   $mSO :: forall (r :: TYPE rep) kk (a :: k).
           TypeRep k a
           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
           -> (Void# -> r)
           -> r

What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass
selection) by the pattern being matched; and indeed it is implicit in
the context (Bool ~ k).  You could imagine trying to extract it like
this:
   $mSO :: forall (r :: TYPE rep) kk (a :: k).
           TypeRep k a
           -> ( co :: ((Bool :: *) ~ (k :: *)) =>
                  let co_a2sv = sc_sel co
                  in TypeRep Bool (a |> co_a2sv) -> r)
           -> (Void# -> r)
           -> r

But we simply don't allow that in types.  Maybe one day but not now.

How to detect this situation?  We just look for free coercion variables
in the types of any of the arguments to the matcher.  The error message
is not very helpful, but at least we don't get a Lint error.
300
-}
301

302
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
303
                  -> TcPatSynInfo
304
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
305 306
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                         , psb_def = lpat, psb_dir = dir }
307 308 309 310
                  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 }
311
  = addPatSynCtxt lname $
312
    do { let decl_arity = length arg_names
313 314 315
             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

       ; traceTc "tcCheckPatSynDecl" $
316 317
         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
318

319 320 321 322 323 324 325 326 327 328 329 330 331 332
       ; (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)

333
         -- See Note [The pattern-synonym signature splitting rule] in TcSigs
334
       ; let univ_fvs = closeOverKinds $
335
                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
336 337 338 339 340
             (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
341

342 343
       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
344
       ; req_dicts <- newEvVars req_theta
345 346
       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
347 348
           pushLevelAndCaptureConstraints            $
           tcExtendTyVarEnv univ_tvs                 $
349 350 351
           tcExtendKindEnvList [(getName (binderVar ex_tv), APromotionErr PatSynExPE)
                               | ex_tv <- extra_ex] $
               -- See Note [Pattern synonym existentials do not scope]
352
           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
353
           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)
354
                    empty_subst = mkEmptyTCvSubst in_scope
355 356 357
              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
                    -- newMetaTyVarX: see the "Existential type variables"
                    -- part of Note [Checking against a pattern signature]
358 359
              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
360
              ; let prov_theta' = substTheta subst prov_theta
361
                  -- Add univ_tvs to the in_scope set to
362
                  -- satisfy the substitution invariant. There's no need to
363 364 365
                  -- add 'ex_tvs' as they are already in the domain of the
                  -- substitution.
                  -- See also Note [The substitution invariant] in TyCoRep.
366
              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
367 368 369
              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
              ; return (ex_tvs', prov_dicts, args') }

370
       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
371 372 373
                         -- 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]
374
       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
375

376 377
       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (Trac #10997)
378
       ; simplifyTopImplic implics
379 380 381 382

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

384
       ; traceTc "tcCheckPatSynDecl }" $ ppr name
385
       ; tc_patsyn_finish lname dir is_infix lpat'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
386 387
                          (univ_bndrs, req_theta, ev_binds, req_dicts)
                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
388
                          (args', arg_tys)
389
                          pat_ty rec_fields }
390
  where
391
    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
392 393 394 395
    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
396 397 398 399 400 401
           ; wrap <- tcSubType_NC GenSigCtxt
                                 (idType arg_id)
                                 (substTyUnchecked subst arg_ty)
                -- Why do we need tcSubType here?
                -- See Note [Pattern synonyms and higher rank types]
           ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
402
tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"
403 404 405 406 407 408 409 410 411 412

{- [Pattern synonyms and higher rank types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data T = MkT (forall a. a->a)

  pattern P :: (Int -> Int) -> T
  pattern P x <- MkT x

This should work.  But in the matcher we must match against MkT, and then
Gabor Greif's avatar
Gabor Greif committed
413
instantiate its argument 'x', to get a function of type (Int -> Int).
414 415
Equality is not enough!  Trac #13752 was an example.

416 417 418 419 420 421 422 423 424 425 426 427
Note [Pattern synonym existentials do not scope]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (Trac #14498):
  pattern SS :: forall (t :: k). () =>
                => forall (a :: kk -> k) (n :: kk).
                => TypeRep n -> TypeRep t
  pattern SS n <- (App (Typeable :: TypeRep (a::kk -> k)) n)

Here 'k' is implicitly bound in the signature, but (with
-XScopedTypeVariables) it does still scope over the pattern-synonym
definition.  But what about 'kk', which is oexistential?  It too is
implicitly bound in the signature; should it too scope?  And if so,
Gabor Greif's avatar
Gabor Greif committed
428
what type variable is it bound to?
429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507

The trouble is that the type variable to which it is bound is itself
only brought into scope in part the pattern, so it makes no sense for
'kk' to scope over the whole pattern.  See the discussion on
Trac #14498, esp comment:16ff. Here is a simpler example:
  data T where { MkT :: x -> (x->Int) -> T }
  pattern P :: () => forall x. x -> (x->Int) -> T
  pattern P a b = (MkT a b, True)

Here it would make no sense to mention 'x' in the True pattern,
like this:
  pattern P a b = (MkT a b, True :: x)

The 'x' only makes sense "under" the MkT pattern. Conclusion: the
existential type variables of a pattern-synonym signature should not
scope.

But it's not that easy to implement, because we don't know
exactly what the existentials /are/ until we get to type checking.
(See Note [The pattern-synonym signature splitting rule], and
the partition of implicit_tvs in tcCheckPatSynDecl.)

So we do this:

- The reaner brings all the implicitly-bound kind variables into
  scope, without trying to distinguish universal from existential

- tcCheckPatSynDecl uses tcExtendKindEnvList to bind the
  implicitly-bound existentials to
      APromotionErr PatSynExPE
  It's not really a promotion error, but it's a way to bind the Name
  (which the renamer has not complained about) to something that, when
  looked up, will cause a complaint (in this case
  TcHsType.promotionErr)


Note [The pattern-synonym signature splitting rule]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given a pattern signature, we must split
     the kind-generalised variables, and
     the implicitly-bound variables
into universal and existential.  The rule is this
(see discussion on Trac #11224):

     The universal tyvars are the ones mentioned in
          - univ_tvs: the user-specified (forall'd) universals
          - req_theta
          - res_ty
     The existential tyvars are all the rest

For example

   pattern P :: () => b -> T a
   pattern P x = ...

Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
how do we split the arg_tys from req_ty?  Consider

   pattern Q :: () => b -> S c -> T a
   pattern Q x = ...

This is an odd example because Q has only one syntactic argument, and
so presumably is defined by a view pattern matching a function.  But
it can happen (Trac #11977, #12108).

We don't know Q's arity from the pattern signature, so we have to wait
until we see the pattern declaration itself before deciding res_ty is,
and hence which variables are existential and which are universal.

And that in turn is why TcPatSynInfo has a separate field,
patsig_implicit_bndrs, to capture the implicitly bound type variables,
because we don't yet know how to split them up.

It's a slight compromise, because it means we don't really know the
pattern synonym's real signature until we see its declaration.  So,
for example, in hs-boot file, we may need to think what to do...
(eg don't have any implicitly-bound variables).


508
Note [Checking against a pattern signature]
509 510 511 512 513 514 515 516 517 518 519 520 521 522
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
523 524
make available to matches against P), is derivable from the
actual pattern.  For example:
525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548
    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

549 550 551 552 553 554 555 556 557 558 559 560
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.

561
  At one point, for ImplicitBidirectional I used TyVarTvs (instead of
562 563
  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
  is redundant since tcPatSynBuilderBind does the job, (b) it was
564
  still incomplete (TyVarTvs can unify with each other), and (c) it
565 566 567 568
  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.
569
-}
570

571 572
collectPatSynArgInfo :: HsPatSynDetails (Located Name)
                     -> ([Name], [Name], Bool)
Matthew Pickering's avatar
Matthew Pickering committed
573 574
collectPatSynArgInfo details =
  case details of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
575 576 577 578 579
    PrefixCon names      -> (map unLoc names, [], False)
    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
    RecCon names         -> (vars, sels, False)
                         where
                            (vars, sels) = unzip (map splitRecordPatSyn names)
Matthew Pickering's avatar
Matthew Pickering committed
580
  where
581 582
    splitRecordPatSyn :: RecordPatSynField (Located Name)
                      -> (Name, Name)
Matthew Pickering's avatar
Matthew Pickering committed
583 584 585 586
    splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
                                         , recordPatSynSelectorId = L _ selId })
      = (patVar, selId)

587 588 589
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L loc name) thing_inside
  = setSrcSpan loc $
590
    addErrCtxt (text "In the declaration for pattern synonym"
591 592 593
                <+> quotes (ppr name)) $
    thing_inside

594 595 596 597
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
  = failWithTc $
    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
598
          <+> speakNOf decl_arity (text "argument"))
599
       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
600

601 602
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
603 604
tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
Matthew Pickering's avatar
Matthew Pickering committed
605
                 -> Bool              -- ^ Whether infix
606
                 -> LPat GhcTc        -- ^ Pattern of the PatSyn
Simon Peyton Jones's avatar
Simon Peyton Jones committed
607
                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
608
                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
609 610 611 612
                 -> ([LHsExpr GhcTcId], [TcType])   -- ^ Pattern arguments and
                                                    -- types
                 -> TcType            -- ^ Pattern type
                 -> [Name]            -- ^ Selector names
Matthew Pickering's avatar
Matthew Pickering committed
613
                 -- ^ Whether fields, empty if not record PatSyn
614
                 -> TcM (LHsBinds GhcTc, TcGblEnv)
615
tc_patsyn_finish lname dir is_infix lpat'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
616 617
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
618
                 (args, arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
619
                 pat_ty field_labels
620 621
  = 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
622

623 624
         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs
       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta
Simon Peyton Jones's avatar
Simon Peyton Jones committed
625
       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs
626 627 628
       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta
       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty
       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys
629

Ningning Xie's avatar
Ningning Xie committed
630 631
       ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'
             (env2, ex_tvs)   = tidyTyCoVarBinders env1 ex_tvs'
632 633 634 635
             req_theta  = tidyTypes env2 req_theta'
             prov_theta = tidyTypes env2 prov_theta'
             arg_tys    = tidyTypes env2 arg_tys'
             pat_ty     = tidyType  env2 pat_ty'
636

637
       ; traceTc "tc_patsyn_finish {" $
638
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
Simon Peyton Jones's avatar
Simon Peyton Jones committed
639 640
           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, prov_theta, prov_dicts) $$
641 642
           ppr args $$
           ppr arg_tys $$
643
           ppr pat_ty
644 645

       -- Make the 'matcher'
646
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
647 648
                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
649
                                         (args, arg_tys)
cactus's avatar
cactus committed
650
                                         pat_ty
651

652
       -- Make the 'builder'
653
       ; builder_id <- mkPatSynBuilderId dir lname
Simon Peyton Jones's avatar
Simon Peyton Jones committed
654 655
                                         univ_tvs req_theta
                                         ex_tvs   prov_theta
Matthew Pickering's avatar
Matthew Pickering committed
656
                                         arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
657 658

         -- TODO: Make this have the proper information
659 660 661 662
       ; 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
663

Richard Eisenberg's avatar
Richard Eisenberg committed
664

665
       -- Make the PatSyn itself
Matthew Pickering's avatar
Matthew Pickering committed
666
       ; let patSyn = mkPatSyn (unLoc lname) is_infix
Simon Peyton Jones's avatar
Simon Peyton Jones committed
667 668
                        (univ_tvs, req_theta)
                        (ex_tvs, prov_theta)
669
                        arg_tys
cactus's avatar
cactus committed
670
                        pat_ty
671
                        matcher_id builder_id
Matthew Pickering's avatar
Matthew Pickering committed
672 673 674
                        field_labels'

       -- Selectors
675 676 677 678
       ; 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
679

680
       ; traceTc "tc_patsyn_finish }" empty
681
       ; return (matcher_bind, tcg_env) }
682

Austin Seipp's avatar
Austin Seipp committed
683 684 685
{-
************************************************************************
*                                                                      *
686
         Constructing the "matcher" Id and its binding
Austin Seipp's avatar
Austin Seipp committed
687 688 689
*                                                                      *
************************************************************************
-}
690

691
tcPatSynMatcher :: Located Name
692
                -> LPat GhcTc
693
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
694
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
695
                -> ([LHsExpr GhcTcId], [TcType])
cactus's avatar
cactus committed
696
                -> TcType
697
                -> TcM ((Id, Bool), LHsBinds GhcTc)
698
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
699
tcPatSynMatcher (L loc name) lpat
700
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
701 702
                (ex_tvs, ex_tys, prov_theta, prov_dicts)
                (args, arg_tys) pat_ty
703 704
  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
705
       ; let rr_tv  = mkTyVar rr_name runtimeRepTy
706
             rr     = mkTyVarTy rr_tv
707
             res_tv = mkTyVar tv_name (tYPE rr)
708
             res_ty = mkTyVarTy res_tv
709
             is_unlifted = null args && null prov_dicts
710 711 712
             (cont_args, cont_arg_tys)
               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
               | otherwise   = (args,                 arg_tys)
713
             cont_ty = mkInfSigmaTy ex_tvs prov_theta $
714 715
                       mkFunTys cont_arg_tys res_ty

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
716
             fail_ty  = mkFunTy voidPrimTy res_ty
717

718
       ; matcher_name <- newImplicitBinder name mkMatcherOcc
719 720 721 722 723
       ; 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
724
             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
725
             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
726
                             -- See Note [Exported LocalIds] in Id
727

728
             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
729
             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
cactus's avatar
cactus committed
730

731
             fail' = nlHsApps fail [nlHsVar voidPrimId]
cactus's avatar
cactus committed
732

733
             args = map nlVarPat [scrutinee, cont, fail]
cactus's avatar
cactus committed
734 735
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
736 737 738
                     then [mkHsCaseAlt lpat  cont']
                     else [mkHsCaseAlt lpat  cont',
                           mkHsCaseAlt lwpat fail']
739
             body = mkLHsWrap (mkWpLet req_ev_binds) $
cactus's avatar
cactus committed
740
                    L (getLoc lpat) $
741
                    HsCase noExt (nlHsVar scrutinee) $
742
                    MG{ mg_alts = L (getLoc lpat) cases
743
                      , mg_ext = MatchGroupTc [pat_ty] res_ty
744
                      , mg_origin = Generated
cactus's avatar
cactus committed
745 746
                      }
             body' = noLoc $
747
                     HsLam noExt $
748 749
                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
                                                        args body]
750
                       , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
751
                       , mg_origin = Generated
cactus's avatar
cactus committed
752
                       }
Ben Gamari's avatar
Ben Gamari committed
753
             match = mkMatch (mkPrefixFunRhs (L loc name)) []
754
                             (mkHsLams (rr_tv:res_tv:univ_tvs)
755
                                       req_dicts body')
756
                             (noLoc (EmptyLocalBinds noExt))
757
             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
758
             mg = MG{ mg_alts = L (getLoc match) [match]
759
                    , mg_ext = MatchGroupTc [] res_ty
760
                    , mg_origin = Generated
cactus's avatar
cactus committed
761 762
                    }

763 764
       ; let bind = FunBind{ fun_ext = emptyNameSet
                           , fun_id = L loc matcher_id
cactus's avatar
cactus committed
765 766
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
767
                           , fun_tick = [] }
768
             matcher_bind = unitBag (noLoc bind)
cactus's avatar
cactus committed
769

770
       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
cactus's avatar
cactus committed
771 772
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

773 774
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
775
mkPatSynRecSelBinds :: PatSyn
776
                    -> [FieldLabel]  -- ^ Visible field labels
777
                    -> [(Id, LHsBind GhcRn)]
778
mkPatSynRecSelBinds ps fields
779 780
  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
    | fld_lbl <- fields ]
781 782 783 784 785 786

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

Austin Seipp's avatar
Austin Seipp committed
787 788 789
{-
************************************************************************
*                                                                      *
790
         Constructing the "builder" Id
Austin Seipp's avatar
Austin Seipp committed
791 792 793
*                                                                      *
************************************************************************
-}
794

795
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
796 797
                  -> [TyVarBinder] -> ThetaType
                  -> [TyVarBinder] -> ThetaType
798
                  -> [Type] -> Type
799
                  -> TcM (Maybe (Id, Bool))
800 801
mkPatSynBuilderId dir (L _ name)
                  univ_bndrs req_theta ex_bndrs prov_theta
802
                  arg_tys pat_ty
803 804 805
  | isUnidirectional dir
  = return Nothing
  | otherwise
806
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
807
       ; let theta          = req_theta ++ prov_theta
808
             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
809
             builder_sigma  = add_void need_dummy_arg $
810 811 812 813 814
                              mkForAllTys univ_bndrs $
                              mkForAllTys ex_bndrs $
                              mkFunTys theta $
                              mkFunTys arg_tys $
                              pat_ty
815
             builder_id     = mkExportedVanillaId builder_name builder_sigma
Matthew Pickering's avatar
Matthew Pickering committed
816
              -- See Note [Exported LocalIds] in Id
817

Richard Eisenberg's avatar
Richard Eisenberg committed
818 819 820
             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id

       ; return (Just (builder_id', need_dummy_arg)) }
821
  where
822

823 824
tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
                    -> TcM (LHsBinds GhcTc)
825
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
826 827
tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
                         , psb_dir = dir, psb_args = details })
828 829 830
  | isUnidirectional dir
  = return emptyBag

831
  | Left why <- mb_match_group       -- Can't invert the pattern
832
  = setSrcSpan (getLoc lpat) $ failWithTc $
833 834 835 836
    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                 <+> quotes (ppr name) <> colon)
              2 why
         , text "RHS pattern:" <+> ppr lpat ]
837

838
  | Right match_group <- mb_match_group  -- Bidirectional
839
  = do { patsyn <- tcLookupPatSyn name
840 841 842 843 844 845 846 847 848
       ; case patSynBuilder patsyn of {
           Nothing -> return emptyBag ;
             -- This case happens if we found a type error in the
             -- pattern synonym, recovered, and put a placeholder
             -- with patSynBuilder=Nothing in the environment

           Just (builder_id, need_dummy_arg) ->  -- Normal case
    do { -- Bidirectional, so patSynBuilder returns Just
         let match_group' | need_dummy_arg = add_dummy_arg match_group
849 850
                          | otherwise      = match_group

851 852
             bind = FunBind { fun_ext = placeHolderNamesTc
                            , fun_id      = L loc (idName builder_id)
853 854 855 856
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , fun_tick    = [] }

857
             sig = completeSigFromId (PatSynCtxt name) builder_id
858

859 860
       ; traceTc "tcPatSynBuilderBind {" $
         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
861
       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
862
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
863
       ; return builder_binds } } }
864 865

  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
866
  where
867
    mb_match_group
868
       = case dir of
869
           ExplicitBidirectional explicit_mg -> Right explicit_mg
870
           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
871
           Unidirectional -> panic "tcPatSynBuilderBind"
872

873
    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
874
    mk_mg body = mkMatchGroup Generated [builder_match]
875 876 877 878
          where
            builder_args  = [L loc (VarPat noExt (L loc n)) | L loc n <- args]
            builder_match = mkMatch (mkPrefixFunRhs (L loc name))
                                    builder_args body
879
                                    (noLoc (EmptyLocalBinds noExt))
880 881

    args = case details of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
882 883 884
              PrefixCon args     -> args
              InfixCon arg1 arg2 -> [arg1, arg2]
              RecCon args        -> map recordPatSynPatVar args
885

886 887
    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
                  -> MatchGroup GhcRn (LHsExpr GhcRn)
888 889
    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 })] }
890
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
891
                             pprMatches other_mg
892
tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"
893

894
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
895 896
-- monadic only for failure
tcPatSynBuilderOcc ps
897
  | Just (builder_id, add_void_arg) <- builder
898
  , let builder_expr = HsConLikeOut noExt (PatSynCon ps)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
899 900 901
        builder_ty   = idType builder_id
  = return $
    if add_void_arg
Richard Eisenberg's avatar
Richard Eisenberg committed
902 903
    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
904 905
         , tcFunResultTy builder_ty )
    else (builder_expr, builder_ty)
906 907

  | otherwise  -- Unidirectional
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
908
  = nonBidirectionalErr name
909 910 911
  where
    name    = patSynName ps
    builder = patSynBuilder ps
cactus's avatar
cactus committed
912

913 914 915 916 917
add_void :: Bool -> Type -> Type
add_void need_dummy_arg ty
  | need_dummy_arg = mkFunTy voidPrimTy ty
  | otherwise      = ty

918 919
tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
            -> Either MsgDoc (LHsExpr GhcRn)
920 921 922 923 924 925 926 927
-- 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]
928
tcPatToExpr name args pat = go pat
929 930 931 932
  where
    lhsVars = mkNameSet (map unLoc args)

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

940 941
    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
                    -> Either MsgDoc (HsExpr GhcRn)
942 943
    mkRecordConExpr con fields
      = do { exprFields <- mapM go fields
944
           ; return (RecordCon noExt con exprFields) }
945

946
    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
947 948
    go (L loc p) = L loc <$> go1 p

949
    go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
950 951 952 953 954 955
    go1 (ConPatIn con info)
      = case info of
          PrefixCon ps  -> mkPrefixConExpr con ps
          InfixCon l r  -> mkPrefixConExpr con [l,r]
          RecCon fields -> mkRecordConExpr con fields

956
    go1 (SigPat _ pat _) = go1 (unLoc pat)
957 958
        -- See Note [Type signatures and the builder expression]

959
    go1 (VarPat _ (L l var))
960
        | var `elemNameSet` lhsVars
961
        = return $ HsVar noExt (L l var)
962 963
        | otherwise
        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
964
    go1 (ParPat _ pat)          = fmap (HsPar noExt) $ go pat
965
    go1 p@(ListPat reb pats)
966 967
      | Nothing <- reb = do { exprs <- mapM go pats
                            ; return $ ExplicitList noExt Nothing exprs }
968
      | otherwise                   = notInvertibleListPat p