{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

-}

-- | Typechecking pattern synonym declarations
module GHC.Tc.TyCl.PatSyn
   ( tcPatSynDecl
   , tcPatSynBuilderBind
   , patSynBuilderOcc
   )
where

import GHC.Prelude

import GHC.Hs

import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Zonk.Type
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Zonk.TcType
import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv
                      , addInlinePrags, addInlinePragArity )
import GHC.Tc.Solver
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build

import GHC.Core.Multiplicity
import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp )
import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Core.Predicate

import GHC.Builtin.Types.Prim
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Core.PatSyn
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Var
import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList )
import GHC.Types.Id
import GHC.Types.Id.Info( RecSelParent(..) )
import GHC.Tc.Gen.Bind
import GHC.Types.Basic
import GHC.Builtin.Types
import GHC.Types.Var.Set
import GHC.Tc.TyCl.Utils
import GHC.Core.ConLike
import GHC.Types.FieldLabel
import GHC.Rename.Env
import GHC.Rename.Utils (wrapGenSpan, isIrrefutableHsPatRn)
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Driver.DynFlags ( getDynFlags, xopt_FieldSelectors )
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
import Data.List( partition, mapAccumL )
import Data.List.NonEmpty (NonEmpty, nonEmpty)

{-
************************************************************************
*                                                                      *
                    Type checking a pattern synonym
*                                                                      *
************************************************************************
-}

tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)
             -> TcSigFun
             -> TcPragEnv -- See Note [Pragmas for pattern synonyms]
             -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)
-> TcSigFun -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl (L SrcSpanAnnA
loc psb :: PatSynBind GhcRn GhcRn
psb@(PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ Name
name })) TcSigFun
sig_fn TcPragEnv
prag_fn
  = SrcSpanAnnA
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    SDoc
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the declaration for pattern synonym"
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)) (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    TcM (LHsBinds GhcTc, TcGblEnv)
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
recoverPSB PatSynBind GhcRn GhcRn
psb) (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    case (TcSigFun
sig_fn Name
name) of
      Maybe TcSigInfo
Nothing                 -> PatSynBind GhcRn GhcRn
-> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl PatSynBind GhcRn GhcRn
psb TcPragEnv
prag_fn
      Just (TcPatSynSig TcPatSynInfo
tpsi) -> PatSynBind GhcRn GhcRn
-> TcPatSynInfo -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl PatSynBind GhcRn GhcRn
psb TcPatSynInfo
tpsi TcPragEnv
prag_fn
      Maybe TcSigInfo
_                       -> String
-> TcRn
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. HasCallStack => String -> a
panic String
"tcPatSynDecl"

recoverPSB :: PatSynBind GhcRn GhcRn
           -> TcM (LHsBinds GhcTc, TcGblEnv)
-- See Note [Pattern synonym error recovery]
recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
recoverPSB (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ Name
name
                , psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details })
 = do { Name
matcher_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkMatcherOcc
      ; let placeholder :: TyThing
placeholder = ConLike -> TyThing
AConLike (ConLike -> TyThing) -> ConLike -> TyThing
forall a b. (a -> b) -> a -> b
$ PatSyn -> ConLike
PatSynCon (PatSyn -> ConLike) -> PatSyn -> ConLike
forall a b. (a -> b) -> a -> b
$
                          Name -> PatSyn
mk_placeholder Name
matcher_name
      ; TcGblEnv
gbl_env <- [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
placeholder] TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, TcGblEnv
gbl_env) }
  where
    ([Name]
_arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
    mk_placeholder :: Name -> PatSyn
mk_placeholder Name
matcher_name
      = Name
-> Bool
-> ([VarBndr Id Specificity], [Kind])
-> ([VarBndr Id Specificity], [Kind])
-> [Kind]
-> Kind
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
name Bool
is_infix
                        ([Specificity -> Id -> VarBndr Id Specificity
forall vis. vis -> Id -> VarBndr Id vis
mkTyVarBinder Specificity
SpecifiedSpec Id
alphaTyVar], []) ([], [])
                        [] -- Arg tys
                        Kind
alphaTy
                        (Name
matcher_name, Kind
matcher_ty, Bool
True) PatSynBuilder
forall a. Maybe a
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_ty :: Kind
matcher_ty = [Id] -> Kind -> Kind
mkSpecForAllTys [Id
alphaTyVar] Kind
alphaTy

{- Note [Pattern synonym error recovery]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If type inference for a pattern synonym fails, we can't continue with
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 (#15289).

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 unification variables to Any, which confuses the error
reporting no end (#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.

-}

tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
                  -> TcPragEnv
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = lname :: LIdP GhcRn
lname@(L SrcSpanAnnN
_ Name
name), psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details
                       , psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir })
                  TcPragEnv
prag_fn
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcInferPatSynDecl {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name

       ; let ([Name]
arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
       ; (TcLevel
tclvl, WantedConstraints
wanted, ((GenLocated SrcSpanAnnA (Pat GhcTc)
lpat', [Id]
args), Kind
pat_ty))
            <- TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)
-> TcM
     (TcLevel, WantedConstraints,
      ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints      (TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)
 -> TcM
      (TcLevel, WantedConstraints,
       ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)
-> TcM
     (TcLevel, WantedConstraints,
      ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind))
forall a b. (a -> b) -> a -> b
$
               FixedRuntimeRepContext
-> HsMatchContext GhcTc
-> LPat GhcRn
-> TcM [Id]
-> TcM ((LPat GhcTc, [Id]), Kind)
forall a.
FixedRuntimeRepContext
-> HsMatchContext GhcTc
-> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTc, a), Kind)
tcInferPat FixedRuntimeRepContext
FRRPatSynArg HsMatchContext GhcTc
forall p. HsMatchContext p
PatSyn LPat GhcRn
lpat (TcM [Id] -> TcM ((LPat GhcTc, [Id]), Kind))
-> TcM [Id] -> TcM ((LPat GhcTc, [Id]), Kind)
forall a b. (a -> b) -> a -> b
$
               (Name -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Name] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId [Name]
arg_names

       ; let ([Id]
ex_tvs, [Id]
prov_dicts) = LPat GhcTc -> ([Id], [Id])
tcCollectEx LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat'

             named_taus :: [(Name, Kind)]
named_taus = (Name
name, Kind
pat_ty) (Name, Kind) -> [(Name, Kind)] -> [(Name, Kind)]
forall a. a -> [a] -> [a]
: (Id -> (Name, Kind)) -> [Id] -> [(Name, Kind)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> (Name, Kind)
mk_named_tau [Id]
args
             mk_named_tau :: Id -> (Name, Kind)
mk_named_tau Id
arg
               = (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
arg, [Id] -> Kind -> Kind
mkSpecForAllTys [Id]
ex_tvs (Id -> Kind
varType Id
arg))
               -- The mkSpecForAllTys is important (#14552), albeit
               -- slightly artificial (there is no variable with this funny type).
               -- We do not want to quantify over variable (alpha::k)
               -- that mention the existentially-bound type variables
               -- ex_tvs in its kind k.
               -- See Note [Type variables whose kind is captured]

       ; (([Id]
univ_tvs, [Id]
req_dicts, TcEvBinds
ev_binds, Bool
_), WantedConstraints
residual)
               <- TcM ([Id], [Id], TcEvBinds, Bool)
-> TcM (([Id], [Id], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([Id], [Id], TcEvBinds, Bool)
 -> TcM (([Id], [Id], TcEvBinds, Bool), WantedConstraints))
-> TcM ([Id], [Id], TcEvBinds, Bool)
-> TcM (([Id], [Id], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                  TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Kind)]
-> WantedConstraints
-> TcM ([Id], [Id], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
NoRestrictions [] [(Name, Kind)]
named_taus WantedConstraints
wanted
       ; Bag EvBind
top_ev_binds <- TcM (Bag EvBind) -> TcM (Bag EvBind)
forall r. TcM r -> TcM r
checkNoErrs (WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
residual)
       ; Bag EvBind
-> TcRn
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
top_ev_binds (TcRn
   (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
 -> TcRn
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$

    do { [Id]
prov_dicts <- ZonkM [Id] -> TcM [Id]
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM [Id] -> TcM [Id]) -> ZonkM [Id] -> TcM [Id]
forall a b. (a -> b) -> a -> b
$ (Id -> ZonkM Id) -> [Id] -> ZonkM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> ZonkM Id
zonkId [Id]
prov_dicts
       ; let filtered_prov_dicts :: [Id]
filtered_prov_dicts = (Id -> Kind) -> [Id] -> [Id]
forall a. (a -> Kind) -> [a] -> [a]
mkMinimalBySCs Id -> Kind
evVarPred [Id]
prov_dicts
             -- Filtering: see Note [Remove redundant provided dicts]
             ([Kind]
prov_theta, [EvTerm]
prov_evs)
                 = [(Kind, EvTerm)] -> ([Kind], [EvTerm])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Id -> Maybe (Kind, EvTerm)) -> [Id] -> [(Kind, EvTerm)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Id -> Maybe (Kind, EvTerm)
mkProvEvidence [Id]
filtered_prov_dicts)
             req_theta :: [Kind]
req_theta = (Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
evVarPred [Id]
req_dicts

       -- Report coercions that escape
       -- See Note [Coercions that escape]
       ; [Id]
args <- ZonkM [Id] -> TcM [Id]
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM [Id] -> TcM [Id]) -> ZonkM [Id] -> TcM [Id]
forall a b. (a -> b) -> a -> b
$ (Id -> ZonkM Id) -> [Id] -> ZonkM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> ZonkM Id
zonkId [Id]
args
       ; let bad_arg :: Id -> Maybe (Id, NonEmpty Id)
bad_arg Id
arg = (NonEmpty Id -> (Id, NonEmpty Id))
-> Maybe (NonEmpty Id) -> Maybe (Id, NonEmpty Id)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NonEmpty Id
bad_cos -> (Id
arg, NonEmpty Id
bad_cos)) (Maybe (NonEmpty Id) -> Maybe (Id, NonEmpty Id))
-> Maybe (NonEmpty Id) -> Maybe (Id, NonEmpty Id)
forall a b. (a -> b) -> a -> b
$
                           [Id] -> Maybe (NonEmpty Id)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Id] -> Maybe (NonEmpty Id)) -> [Id] -> Maybe (NonEmpty Id)
forall a b. (a -> b) -> a -> b
$
                           DVarSet -> [Id]
dVarSetElems (DVarSet -> [Id]) -> DVarSet -> [Id]
forall a b. (a -> b) -> a -> b
$
                           (Id -> Bool) -> DVarSet -> DVarSet
filterDVarSet Id -> Bool
isId (Kind -> DVarSet
tyCoVarsOfTypeDSet (Id -> Kind
idType Id
arg))
             bad_args :: [(Id, NonEmpty Id)]
bad_args = (Id -> Maybe (Id, NonEmpty Id)) -> [Id] -> [(Id, NonEmpty Id)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Id -> Maybe (Id, NonEmpty Id)
bad_arg ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
prov_dicts)
       ; ((Id, NonEmpty Id) -> TcRn ()) -> [(Id, NonEmpty Id)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Id, NonEmpty Id) -> TcRn ()
dependentArgErr [(Id, NonEmpty Id)]
bad_args

       -- Report un-quantifiable type variables:
       -- see Note [Unquantified tyvars in a pattern synonym]
       ; CandidatesQTvs
dvs <- [Kind] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Kind]
prov_theta
       ; let err_ctx :: TidyEnv -> ZonkM (TidyEnv, UninferrableTyVarCtx)
err_ctx TidyEnv
tidy_env
               = do { (TidyEnv
tidy_env2, [Kind]
theta) <- TidyEnv -> [Kind] -> ZonkM (TidyEnv, [Kind])
zonkTidyTcTypes TidyEnv
tidy_env [Kind]
prov_theta
                    ; (TidyEnv, UninferrableTyVarCtx)
-> ZonkM (TidyEnv, UninferrableTyVarCtx)
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2, [Kind] -> UninferrableTyVarCtx
UninfTyCtx_ProvidedContext [Kind]
theta ) }
       ; CandidatesQTvs
-> (TidyEnv -> ZonkM (TidyEnv, UninferrableTyVarCtx)) -> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> ZonkM (TidyEnv, UninferrableTyVarCtx)
err_ctx

       ; String -> SDoc -> TcRn ()
traceTc String
"tcInferPatSynDecl }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
ex_tvs)
       ; [FieldLabel]
rec_fields <- HasDebugCallStack => Name -> RnM [FieldLabel]
Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
       ; GenLocated SrcSpanAnnN Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> TcPragEnv
-> ([VarBndr Id Specificity], [Kind], TcEvBinds, [Id])
-> ([VarBndr Id Specificity], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish LIdP GhcRn
GenLocated SrcSpanAnnN Name
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat' TcPragEnv
prag_fn
                          (Specificity -> [Id] -> [VarBndr Id Specificity]
forall vis. vis -> [Id] -> [VarBndr Id vis]
mkTyVarBinders Specificity
InferredSpec [Id]
univ_tvs
                            , [Kind]
req_theta,  TcEvBinds
ev_binds, [Id]
req_dicts)
                          (Specificity -> [Id] -> [VarBndr Id Specificity]
forall vis. vis -> [Id] -> [VarBndr Id vis]
mkTyVarBinders Specificity
InferredSpec [Id]
ex_tvs
                            , [Id] -> [Kind]
mkTyVarTys [Id]
ex_tvs, [Kind]
prov_theta, [EvTerm]
prov_evs)
                          ((Id -> LocatedA (HsExpr GhcTc))
-> [Id] -> [LocatedA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map IdP GhcTc -> LHsExpr GhcTc
Id -> LocatedA (HsExpr GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar [Id]
args, (Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
args)
                          Kind
pat_ty [FieldLabel]
rec_fields } }

mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
-- See Note [Equality evidence in pattern synonyms]
mkProvEvidence :: Id -> Maybe (Kind, EvTerm)
mkProvEvidence Id
ev_id
  | EqPred EqRel
r Kind
ty1 Kind
ty2 <- Kind -> Pred
classifyPredType Kind
pred
  , let k1 :: Kind
k1 = HasDebugCallStack => Kind -> Kind
Kind -> Kind
typeKind Kind
ty1
        k2 :: Kind
k2 = HasDebugCallStack => Kind -> Kind
Kind -> Kind
typeKind Kind
ty2
        is_homo :: Bool
is_homo = Kind
k1 HasDebugCallStack => Kind -> Kind -> Bool
Kind -> Kind -> Bool
`tcEqType` Kind
k2
        homo_tys :: [Kind]
homo_tys   = [Kind
k1, Kind
ty1, Kind
ty2]
        hetero_tys :: [Kind]
hetero_tys = [Kind
k1, Kind
k2, Kind
ty1, Kind
ty2]
  = case EqRel
r of
      EqRel
ReprEq | Bool
is_homo
             -> (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just ( Class -> [Kind] -> Kind
mkClassPred Class
coercibleClass    [Kind]
homo_tys
                     , DataCon -> [Kind] -> [EvExpr] -> EvTerm
evDataConApp DataCon
coercibleDataCon [Kind]
homo_tys [EvExpr]
eq_con_args )
             | Bool
otherwise -> Maybe (Kind, EvTerm)
forall a. Maybe a
Nothing
      EqRel
NomEq  | Bool
is_homo
             -> (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just ( Class -> [Kind] -> Kind
mkClassPred Class
eqClass    [Kind]
homo_tys
                     , DataCon -> [Kind] -> [EvExpr] -> EvTerm
evDataConApp DataCon
eqDataCon [Kind]
homo_tys [EvExpr]
eq_con_args )
             | Bool
otherwise
             -> (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just ( Class -> [Kind] -> Kind
mkClassPred Class
heqClass    [Kind]
hetero_tys
                     , DataCon -> [Kind] -> [EvExpr] -> EvTerm
evDataConApp DataCon
heqDataCon [Kind]
hetero_tys [EvExpr]
eq_con_args )

  | Bool
otherwise
  = (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just (Kind
pred, EvExpr -> EvTerm
EvExpr (Id -> EvExpr
evId Id
ev_id))
  where
    pred :: Kind
pred = Id -> Kind
evVarPred Id
ev_id
    eq_con_args :: [EvExpr]
eq_con_args = [Id -> EvExpr
evId Id
ev_id]

dependentArgErr :: (Id, NonEmpty CoVar) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr :: (Id, NonEmpty Id) -> TcRn ()
dependentArgErr (Id
arg, NonEmpty Id
bad_cos)
  = TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$  -- fail here: otherwise we get downstream errors
    Id -> NonEmpty Id -> TcRnMessage
TcRnPatSynEscapedCoercion Id
arg NonEmpty Id
bad_cos

{- Note [Type variables whose kind is captured]
~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data AST a = Sym [a]
  class Prj s where { prj :: [a] -> Maybe (s a) }
  pattern P x <= Sym (prj -> Just x)

Here we get a matcher with this type
  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r

No problem.  But note that 's' is not fixed by the type of the
pattern (AST a), nor is it existentially bound.  It's really only
fixed by the type of the continuation.

#14552 showed that this can go wrong if the kind of 's' mentions
existentially bound variables.  We obviously can't make a type like
  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
                                   -> r -> r
But neither is 's' itself existentially bound, so the forall (s::k->*)
can't go in the inner forall either.  (What would the matcher apply
the continuation to?)

Solution: do not quantify over any unification variable whose kind
mentions the existentials.  We can conveniently do that by making the
"taus" passed to simplifyInfer look like
   forall ex_tvs. arg_ty

After that, Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType takes
over and errors.

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 (#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.  Again mkMimimalWithSCs removes the redundant one.

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 GHC.Core.TyCo.Rep
and is not implicitly instantiated.

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

See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver

Note [Coercions that escape]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#14507 showed an example where the inferred type of the matcher
for the pattern synonym was something 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.

Note [Unquantified tyvars in a pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#21479)

   data T a where MkT :: Int -> T Char   -- A GADT
   foo :: forall b. Bool -> T b          -- Somewhat strange type

   pattern T1 <- (foo -> MkT)

In the view pattern, foo is instantiated, let's say b :-> b0
where b0 is a unification variable.  Then matching the GADT
MkT will add the "provided" constraint b0~Char, so we might infer
   pattern T1 :: () => (b0~Char) => Int -> Bool

Nothing constrains that `b0`. We don't want to quantify over it.
We don't want to to zonk to Any (we don't like Any showing up in
user-visible types).  So we want to error here. See
Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType

Hence the call to doNotQuantifyTyVars here.
-}

tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
                  -> TcPatSynInfo
                  -> TcPragEnv
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPatSynInfo -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl psb :: PatSynBind GhcRn GhcRn
psb@PSB{ psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = lname :: LIdP GhcRn
lname@(L SrcSpanAnnN
_ Name
name), psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details
                         , psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir }
                  TPSI{ patsig_implicit_bndrs :: TcPatSynInfo -> [VarBndr Id Specificity]
patsig_implicit_bndrs = [VarBndr Id Specificity]
implicit_bndrs
                      , patsig_univ_bndrs :: TcPatSynInfo -> [VarBndr Id Specificity]
patsig_univ_bndrs = [VarBndr Id Specificity]
explicit_univ_bndrs, patsig_req :: TcPatSynInfo -> [Kind]
patsig_req  = [Kind]
req_theta
                      , patsig_ex_bndrs :: TcPatSynInfo -> [VarBndr Id Specificity]
patsig_ex_bndrs   = [VarBndr Id Specificity]
explicit_ex_bndrs,   patsig_prov :: TcPatSynInfo -> [Kind]
patsig_prov = [Kind]
prov_theta
                      , patsig_body_ty :: TcPatSynInfo -> Kind
patsig_body_ty    = Kind
sig_body_ty }
                  TcPragEnv
prag_fn
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcCheckPatSynDecl" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [VarBndr Id Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
implicit_bndrs, [VarBndr Id Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
explicit_univ_bndrs, [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
req_theta
              , [VarBndr Id Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
explicit_ex_bndrs, [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
prov_theta, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
sig_body_ty ]

       ; let decl_arity :: Int
decl_arity = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
arg_names
             ([Name]
arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details

       ; ([Scaled Kind]
arg_tys, Kind
pat_ty) <- case Int -> Kind -> Either Int ([Scaled Kind], Kind)
tcSplitFunTysN Int
decl_arity Kind
sig_body_ty of
                                 Right ([Scaled Kind], Kind)
stuff  -> ([Scaled Kind], Kind)
-> IOEnv (Env TcGblEnv TcLclEnv) ([Scaled Kind], Kind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Scaled Kind], Kind)
stuff
                                 Left Int
missing -> Name
-> Int
-> Int
-> IOEnv (Env TcGblEnv TcLclEnv) ([Scaled Kind], Kind)
forall a. Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
name Int
decl_arity Int
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 (decl_arity above)
       ; let bad_tvs :: [Id]
bad_tvs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` Kind -> VarSet
tyCoVarsOfType Kind
pat_ty) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
explicit_ex_bndrs
       ; Bool -> TcRnMessage -> TcRn ()
checkTc ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bad_tvs) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> Kind -> [Id] -> TcRnMessage
TcRnPatSynExistentialInResult Name
name Kind
pat_ty [Id]
bad_tvs

         -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig
       ; let univ_fvs :: VarSet
univ_fvs = VarSet -> VarSet
closeOverKinds (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
                        ([Kind] -> VarSet
tyCoVarsOfTypes (Kind
pat_ty Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [Kind]
req_theta) VarSet -> [Id] -> VarSet
`extendVarSetList` ([VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
explicit_univ_bndrs))
             ([VarBndr Id Specificity]
extra_univ, [VarBndr Id Specificity]
extra_ex) = (VarBndr Id Specificity -> Bool)
-> [VarBndr Id Specificity]
-> ([VarBndr Id Specificity], [VarBndr Id Specificity])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Id -> VarSet -> Bool
`elemVarSet` VarSet
univ_fvs) (Id -> Bool)
-> (VarBndr Id Specificity -> Id) -> VarBndr Id Specificity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarBndr Id Specificity -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar) [VarBndr Id Specificity]
implicit_bndrs
             univ_bndrs :: [VarBndr Id Specificity]
univ_bndrs = [VarBndr Id Specificity]
extra_univ [VarBndr Id Specificity]
-> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr Id Specificity]
explicit_univ_bndrs
             ex_bndrs :: [VarBndr Id Specificity]
ex_bndrs   = [VarBndr Id Specificity]
extra_ex   [VarBndr Id Specificity]
-> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr Id Specificity]
explicit_ex_bndrs
             univ_tvs :: [Id]
univ_tvs   = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
univ_bndrs
             ex_tvs :: [Id]
ex_tvs     = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
ex_bndrs

         -- Pattern synonyms currently cannot be linear (#18806)
       ; Bool -> TcRnMessage -> TcRn ()
checkTc ((Scaled Kind -> Bool) -> [Scaled Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Kind -> Bool
isManyTy (Kind -> Bool) -> (Scaled Kind -> Kind) -> Scaled Kind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Kind -> Kind
forall a. Scaled a -> Kind
scaledMult) [Scaled Kind]
arg_tys) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           Kind -> TcRnMessage
TcRnLinearPatSyn Kind
sig_body_ty

       ; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (UserTypeCtxt -> Kind -> [(Name, Id)] -> SkolemInfoAnon
SigSkol (Name -> UserTypeCtxt
PatSynCtxt Name
name) Kind
pat_ty [])
                         -- The type here is a bit bogus, but we do not print
                         -- the type for PatSynCtxt, so it doesn't matter
                         -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"

         -- Skolemise the quantified type variables. This is necessary
         -- in order to check the actual pattern type against the
         -- expected type. Even though the tyvars in the type are
         -- already skolems, this step changes their TcLevels,
         -- avoiding level-check errors when unifying.
       ; (Subst
skol_subst0, [VarBndr Id Specificity]
skol_univ_bndrs) <- SkolemInfo
-> Subst
-> [VarBndr Id Specificity]
-> TcM (Subst, [VarBndr Id Specificity])
forall flag.
SkolemInfo
-> Subst -> [VarBndr Id flag] -> TcM (Subst, [VarBndr Id flag])
skolemiseTvBndrsX SkolemInfo
skol_info Subst
emptySubst [VarBndr Id Specificity]
univ_bndrs
       ; (Subst
skol_subst, [VarBndr Id Specificity]
skol_ex_bndrs)    <- SkolemInfo
-> Subst
-> [VarBndr Id Specificity]
-> TcM (Subst, [VarBndr Id Specificity])
forall flag.
SkolemInfo
-> Subst -> [VarBndr Id flag] -> TcM (Subst, [VarBndr Id flag])
skolemiseTvBndrsX SkolemInfo
skol_info Subst
skol_subst0   [VarBndr Id Specificity]
ex_bndrs
       ; let skol_univ_tvs :: [Id]
skol_univ_tvs   = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
skol_univ_bndrs
             skol_ex_tvs :: [Id]
skol_ex_tvs     = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
skol_ex_bndrs
             skol_req_theta :: [Kind]
skol_req_theta  = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst0 [Kind]
req_theta
             skol_prov_theta :: [Kind]
skol_prov_theta = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst  [Kind]
prov_theta
             skol_arg_tys :: [Kind]
skol_arg_tys    = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTys   Subst
skol_subst  ((Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing [Scaled Kind]
arg_tys)
             skol_pat_ty :: Kind
skol_pat_ty     = HasDebugCallStack => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy    Subst
skol_subst  Kind
pat_ty

             univ_tv_prs :: [(Name, Id)]
univ_tv_prs     = [ (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
orig_univ_tv, Id
skol_univ_tv)
                               | (Id
orig_univ_tv, Id
skol_univ_tv) <- [Id]
univ_tvs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
skol_univ_tvs ]

       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
       ; [Id]
req_dicts <- [Kind] -> TcM [Id]
newEvVars [Kind]
skol_req_theta
       ; (TcLevel
tclvl, WantedConstraints
wanted, (GenLocated SrcSpanAnnA (Pat GhcTc)
lpat', ([Id]
ex_tvs', [EvTerm]
prov_dicts, [LocatedA (HsExpr GhcTc)]
args'))) <-
           Bool
-> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (Pat GhcTc),
       ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (Pat GhcTc),
       ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Name] -> [Scaled Kind] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Name]
arg_names [Scaled Kind]
arg_tys) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
arg_names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Scaled Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Scaled Kind]
arg_tys) (IOEnv
   (Env TcGblEnv TcLclEnv)
   (TcLevel, WantedConstraints,
    (GenLocated SrcSpanAnnA (Pat GhcTc),
     ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TcLevel, WantedConstraints,
       (GenLocated SrcSpanAnnA (Pat GhcTc),
        ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (Pat GhcTc),
       ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (Pat GhcTc),
       ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
forall a b. (a -> b) -> a -> b
$
           TcM
  (GenLocated SrcSpanAnnA (Pat GhcTc),
   ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (Pat GhcTc),
       ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints   (TcM
   (GenLocated SrcSpanAnnA (Pat GhcTc),
    ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TcLevel, WantedConstraints,
       (GenLocated SrcSpanAnnA (Pat GhcTc),
        ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))))
-> TcM
     (GenLocated SrcSpanAnnA (Pat GhcTc),
      ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (Pat GhcTc),
       ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
forall a b. (a -> b) -> a -> b
$
           [(Name, Id)]
-> TcM
     (GenLocated SrcSpanAnnA (Pat GhcTc),
      ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
-> TcM
     (GenLocated SrcSpanAnnA (Pat GhcTc),
      ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, Id)]
univ_tv_prs (TcM
   (GenLocated SrcSpanAnnA (Pat GhcTc),
    ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
 -> TcM
      (GenLocated SrcSpanAnnA (Pat GhcTc),
       ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
-> TcM
     (GenLocated SrcSpanAnnA (Pat GhcTc),
      ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
-> TcM
     (GenLocated SrcSpanAnnA (Pat GhcTc),
      ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
forall a b. (a -> b) -> a -> b
$
           HsMatchContext GhcTc
-> LPat GhcRn
-> Scaled Kind
-> TcM ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
forall a.
HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Kind -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat HsMatchContext GhcTc
forall p. HsMatchContext p
PatSyn LPat GhcRn
lpat (Kind -> Scaled Kind
forall a. a -> Scaled a
unrestricted Kind
skol_pat_ty)   (TcM ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])
 -> TcM (LPat GhcTc, ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])))
-> TcM ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)]))
forall a b. (a -> b) -> a -> b
$
           do { let in_scope :: InScopeSet
in_scope    = [Id] -> InScopeSet
mkInScopeSetList [Id]
skol_univ_tvs
                    empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
              ; (Subst
inst_subst, [Id]
ex_tvs') <- (Subst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (Subst, Id))
-> Subst -> [Id] -> IOEnv (Env TcGblEnv TcLclEnv) (Subst, [Id])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM Subst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (Subst, Id)
newMetaTyVarX Subst
empty_subst [Id]
skol_ex_tvs
                    -- newMetaTyVarX: see the "Existential type variables"
                    -- part of Note [Checking against a pattern signature]
              ; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn1" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs])
              ; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn2" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs'])
              ; let prov_theta' :: [Kind]
prov_theta' = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
inst_subst [Kind]
skol_prov_theta
                  -- Add univ_tvs to the in_scope set to
                  -- satisfy the substitution 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 GHC.Core.TyCo.Subst.
              ; [EvTerm]
prov_dicts <- (Kind -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm)
-> [Kind] -> IOEnv (Env TcGblEnv TcLclEnv) [EvTerm]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CtOrigin -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
emitWanted (PatSynBind GhcRn GhcRn -> CtOrigin
ProvCtxtOrigin PatSynBind GhcRn GhcRn
psb)) [Kind]
prov_theta'
              ; [LocatedA (HsExpr GhcTc)]
args'      <- (Name
 -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc)))
-> [Name]
-> [Kind]
-> IOEnv (Env TcGblEnv TcLclEnv) [LocatedA (HsExpr GhcTc)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Subst -> Name -> Kind -> TcM (LHsExpr GhcTc)
tc_arg Subst
inst_subst) [Name]
arg_names
                                       [Kind]
skol_arg_tys
              ; ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])
-> TcM ([Id], [EvTerm], [LocatedA (HsExpr GhcTc)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ex_tvs', [EvTerm]
prov_dicts, [LocatedA (HsExpr GhcTc)]
args') }

       ; (Bag Implication
implics, TcEvBinds
ev_binds) <- TcLevel
-> SkolemInfoAnon
-> [Id]
-> [Id]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tclvl (SkolemInfo -> SkolemInfoAnon
getSkolemInfo SkolemInfo
skol_info) [Id]
skol_univ_tvs
                                                    [Id]
req_dicts WantedConstraints
wanted

       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (#10997)
       ; Bag Implication -> TcRn ()
simplifyTopImplic Bag Implication
implics

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

       ; String -> SDoc -> TcRn ()
traceTc String
"tcCheckPatSynDecl }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name

       ; [FieldLabel]
rec_fields <- HasDebugCallStack => Name -> RnM [FieldLabel]
Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
       ; GenLocated SrcSpanAnnN Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> TcPragEnv
-> ([VarBndr Id Specificity], [Kind], TcEvBinds, [Id])
-> ([VarBndr Id Specificity], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish LIdP GhcRn
GenLocated SrcSpanAnnN Name
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat' TcPragEnv
prag_fn
                          ([VarBndr Id Specificity]
skol_univ_bndrs, [Kind]
skol_req_theta, TcEvBinds
ev_binds, [Id]
req_dicts)
                          ([VarBndr Id Specificity]
skol_ex_bndrs, [Id] -> [Kind]
mkTyVarTys [Id]
ex_tvs', [Kind]
skol_prov_theta, [EvTerm]
prov_dicts)
                          ([LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
args', [Kind]
skol_arg_tys)
                          Kind
skol_pat_ty [FieldLabel]
rec_fields }
  where
    tc_arg :: Subst -> Name -> Type -> TcM (LHsExpr GhcTc)
     -- Look up the variable actually bound by lpat
     -- and check that it has the expected type
    tc_arg :: Subst -> Name -> Kind -> TcM (LHsExpr GhcTc)
tc_arg Subst
subst Name
arg_name Kind
arg_ty
      = SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
arg_name) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
           -- Set the SrcSpan to be the binding site of the Id (#18856)
           -- e.g.  pattern P :: Int -> Maybe (Int,Bool)
           --       pattern P x = Just (x,True)
           -- Before unifying x's actual type with its expected type, in tc_arg, set
           -- location to x's binding site in lpat, namely the 'x' in Just (x,True).
           -- Else the error message location is wherever tcCheckPat finished,
           -- namely the right-hand corner of the pattern
        do { Id
arg_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId Name
arg_name
           ; HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> Kind -> Kind -> TcM HsWrapper
tcSubTypeSigma (Name -> CtOrigin
OccurrenceOf (Id -> Name
idName Id
arg_id))
                                    UserTypeCtxt
GenSigCtxt
                                    (Id -> Kind
idType Id
arg_id)
                                    (HasDebugCallStack => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
subst Kind
arg_ty)
                -- Why do we need tcSubType here?
                -- See Note [Pattern synonyms and higher rank types]
           ; LocatedA (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Id
arg_id) }

skolemiseTvBndrsX :: SkolemInfo -> Subst -> [VarBndr TyVar flag]
                  -> TcM (Subst, [VarBndr TcTyVar flag])
-- Make new TcTyVars, all skolems with levels, but do not clone
-- The level is one level deeper than the current level
-- See Note [Skolemising when checking a pattern synonym]
skolemiseTvBndrsX :: forall flag.
SkolemInfo
-> Subst -> [VarBndr Id flag] -> TcM (Subst, [VarBndr Id flag])
skolemiseTvBndrsX SkolemInfo
skol_info Subst
orig_subst [VarBndr Id flag]
tvs
  = do { TcLevel
tc_lvl <- TcM TcLevel
getTcLevel
       ; let pushed_lvl :: TcLevel
pushed_lvl = TcLevel -> TcLevel
pushTcLevel TcLevel
tc_lvl
             details :: TcTyVarDetails
details    = SkolemInfo -> TcLevel -> Bool -> TcTyVarDetails
SkolemTv SkolemInfo
skol_info TcLevel
pushed_lvl Bool
False

             mk_skol_tv_x :: Subst -> VarBndr TyVar flag
                          -> (Subst, VarBndr TcTyVar flag)
             mk_skol_tv_x :: forall flag. Subst -> VarBndr Id flag -> (Subst, VarBndr Id flag)
mk_skol_tv_x Subst
subst (Bndr Id
tv flag
flag)
               = (Subst
subst', Id -> flag -> VarBndr Id flag
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
new_tv flag
flag)
               where
                 new_kind :: Kind
new_kind = Subst -> Kind -> Kind
substTyUnchecked Subst
subst (Id -> Kind
tyVarKind Id
tv)
                 new_tv :: Id
new_tv   = Name -> Kind -> TcTyVarDetails -> Id
mkTcTyVar (Id -> Name
tyVarName Id
tv) Kind
new_kind TcTyVarDetails
details
                 subst' :: Subst
subst'   = Subst -> Id -> Id -> Subst
extendTvSubstWithClone Subst
subst Id
tv Id
new_tv

       ; (Subst, [VarBndr Id flag]) -> TcM (Subst, [VarBndr Id flag])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Subst -> VarBndr Id flag -> (Subst, VarBndr Id flag))
-> Subst -> [VarBndr Id flag] -> (Subst, [VarBndr Id flag])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Subst -> VarBndr Id flag -> (Subst, VarBndr Id flag)
forall flag. Subst -> VarBndr Id flag -> (Subst, VarBndr Id flag)
mk_skol_tv_x Subst
orig_subst [VarBndr Id flag]
tvs) }

{- Note [Skolemising when checking a pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   pattern P1 :: forall a. a -> Maybe a
   pattern P1 x <- Just x where
      P1 x = Just (x :: a)

The scoped type variable 'a' scopes over the builder RHS, Just (x::a).
But the builder RHS is typechecked much later in tcPatSynBuilderBind,
and gets its scoped type variables from the type of the builder_id.
The easiest way to achieve this is not to clone when skolemising.

Hence a special-purpose skolemiseTvBndrX here, similar to
GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter
does cloning.

Note [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
instantiate its argument 'x', to get a function of type (Int -> Int).
Equality is not enough!  #13752 was an example.


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 #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 (#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).


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
make available to matches against P), is derivable from the
actual pattern.  For example:
    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

All this applies when type-checking the /matching/ side of
a pattern synonym.  What about the /building/ side?

* For Unidirectional, there is no builder

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

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

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

collectPatSynArgInfo :: HsPatSynDetails GhcRn
                     -> ([Name], Bool)
collectPatSynArgInfo :: HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details =
  case HsPatSynDetails GhcRn
details of
    PrefixCon [Void]
_ [LIdP GhcRn]
names    -> ((GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
names, Bool
False)
    InfixCon LIdP GhcRn
name1 LIdP GhcRn
name2 -> ((GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn
GenLocated SrcSpanAnnN Name
name1, LIdP GhcRn
GenLocated SrcSpanAnnN Name
name2], Bool
True)
    RecCon [RecordPatSynField GhcRn]
names         -> ((RecordPatSynField GhcRn -> Name)
-> [RecordPatSynField GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name)
-> RecordPatSynField GhcRn
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField GhcRn -> LIdP GhcRn
RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar) [RecordPatSynField GhcRn]
names, Bool
False)

wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr :: forall a. Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
name Int
decl_arity Int
missing
  = TcRnMessage -> TcM a
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM a) -> TcRnMessage -> TcM a
forall a b. (a -> b) -> a -> b
$ Name -> Int -> Int -> TcRnMessage
TcRnPatSynArityMismatch Name
name Int
decl_arity Int
missing

-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
tc_patsyn_finish :: LocatedN Name   -- ^ PatSyn Name
                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                 -> Bool              -- ^ Whether infix
                 -> LPat GhcTc        -- ^ Pattern of the PatSyn
                 -> TcPragEnv
                 -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])
                 -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
                 -> ([LHsExpr GhcTc], [TcTypeFRR])
                   -- ^ Pattern arguments and types.
                   -- These must have a syntactically fixed RuntimeRep as per
                   -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
                 -> TcType            -- ^ Pattern type
                 -> [FieldLabel]      -- ^ Selector names
                 -- ^ Whether fields, empty if not record PatSyn
                 -> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish :: GenLocated SrcSpanAnnN Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> TcPragEnv
-> ([VarBndr Id Specificity], [Kind], TcEvBinds, [Id])
-> ([VarBndr Id Specificity], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish GenLocated SrcSpanAnnN Name
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
lpat' TcPragEnv
prag_fn
                 ([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
                 ([VarBndr Id Specificity]
ex_tvs,   [Kind]
ex_tys,    [Kind]
prov_theta,   [EvTerm]
prov_dicts)
                 ([LHsExpr GhcTc]
args, [Kind]
arg_tys)
                 Kind
pat_ty [FieldLabel]
field_labels
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there

       ([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta, [VarBndr Id Specificity]
ex_tvs, [Kind]
prov_theta, [Kind]
arg_tys, Kind
pat_ty) <-
         ZonkFlexi
-> ZonkT
     (IOEnv (Env TcGblEnv TcLclEnv))
     ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
      [Kind], [Kind], Kind)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
      [Kind], [Kind], Kind)
forall (m :: * -> *) b. MonadIO m => ZonkFlexi -> ZonkT m b -> m b
initZonkEnv ZonkFlexi
NoFlexi (ZonkT
   (IOEnv (Env TcGblEnv TcLclEnv))
   ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
    [Kind], [Kind], Kind)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
       [Kind], [Kind], Kind))
-> ZonkT
     (IOEnv (Env TcGblEnv TcLclEnv))
     ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
      [Kind], [Kind], Kind)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
      [Kind], [Kind], Kind)
forall a b. (a -> b) -> a -> b
$
         ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Id Specificity]
-> forall r.
   ([VarBndr Id Specificity]
    -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
   -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([VarBndr Id Specificity]
-> ZonkBndrT
     (IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Id Specificity]
forall vis. [VarBndr Id vis] -> ZonkBndrTcM [VarBndr Id vis]
zonkTyVarBindersX   [VarBndr Id Specificity]
univ_tvs) (([VarBndr Id Specificity]
  -> ZonkT
       (IOEnv (Env TcGblEnv TcLclEnv))
       ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
        [Kind], [Kind], Kind))
 -> ZonkT
      (IOEnv (Env TcGblEnv TcLclEnv))
      ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
       [Kind], [Kind], Kind))
-> ([VarBndr Id Specificity]
    -> ZonkT
         (IOEnv (Env TcGblEnv TcLclEnv))
         ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
          [Kind], [Kind], Kind))
-> ZonkT
     (IOEnv (Env TcGblEnv TcLclEnv))
     ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
      [Kind], [Kind], Kind)
forall a b. (a -> b) -> a -> b
$ \ [VarBndr Id Specificity]
univ_tvs' ->
         do { [Kind]
req_theta'  <- [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX [Kind]
req_theta
            ; ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Id Specificity]
-> forall r.
   ([VarBndr Id Specificity]
    -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
   -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([VarBndr Id Specificity]
-> ZonkBndrT
     (IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Id Specificity]
forall vis. [VarBndr Id vis] -> ZonkBndrTcM [VarBndr Id vis]
zonkTyVarBindersX [VarBndr Id Specificity]
ex_tvs) (([VarBndr Id Specificity]
  -> ZonkT
       (IOEnv (Env TcGblEnv TcLclEnv))
       ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
        [Kind], [Kind], Kind))
 -> ZonkT
      (IOEnv (Env TcGblEnv TcLclEnv))
      ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
       [Kind], [Kind], Kind))
-> ([VarBndr Id Specificity]
    -> ZonkT
         (IOEnv (Env TcGblEnv TcLclEnv))
         ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
          [Kind], [Kind], Kind))
-> ZonkT
     (IOEnv (Env TcGblEnv TcLclEnv))
     ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
      [Kind], [Kind], Kind)
forall a b. (a -> b) -> a -> b
$ \ [VarBndr Id Specificity]
ex_tvs' ->
         do { [Kind]
prov_theta' <- [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX [Kind]
prov_theta
            ; Kind
pat_ty'     <- Kind -> ZonkTcM Kind
zonkTcTypeToTypeX   Kind
pat_ty
            ; [Kind]
arg_tys'    <- [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX [Kind]
arg_tys

            ; let (TidyEnv
env1, [VarBndr Id Specificity]
univ_tvs) = TidyEnv
-> [VarBndr Id Specificity] -> (TidyEnv, [VarBndr Id Specificity])
forall vis.
TidyEnv -> [VarBndr Id vis] -> (TidyEnv, [VarBndr Id vis])
tidyForAllTyBinders TidyEnv
emptyTidyEnv [VarBndr Id Specificity]
univ_tvs'
                  (TidyEnv
env2, [VarBndr Id Specificity]
ex_tvs)   = TidyEnv
-> [VarBndr Id Specificity] -> (TidyEnv, [VarBndr Id Specificity])
forall vis.
TidyEnv -> [VarBndr Id vis] -> (TidyEnv, [VarBndr Id vis])
tidyForAllTyBinders TidyEnv
env1 [VarBndr Id Specificity]
ex_tvs'
                  req_theta :: [Kind]
req_theta  = TidyEnv -> [Kind] -> [Kind]
tidyTypes TidyEnv
env2 [Kind]
req_theta'
                  prov_theta :: [Kind]
prov_theta = TidyEnv -> [Kind] -> [Kind]
tidyTypes TidyEnv
env2 [Kind]
prov_theta'
                  arg_tys :: [Kind]
arg_tys    = TidyEnv -> [Kind] -> [Kind]
tidyTypes TidyEnv
env2 [Kind]
arg_tys'
                  pat_ty :: Kind
pat_ty     = TidyEnv -> Kind -> Kind
tidyType  TidyEnv
env2 Kind
pat_ty'

            ; ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
 [Kind], [Kind], Kind)
-> ZonkT
     (IOEnv (Env TcGblEnv TcLclEnv))
     ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
      [Kind], [Kind], Kind)
forall a. a -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta,
                       [VarBndr Id Specificity]
ex_tvs, [Kind]
prov_theta, [Kind]
arg_tys, Kind
pat_ty) } }

       ; String -> SDoc -> TcRn ()
traceTc String
"tc_patsyn_finish {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
lname) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat') SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           ([VarBndr Id Specificity], [Kind], TcEvBinds, [Id]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           ([VarBndr Id Specificity], [Kind], [EvTerm]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([VarBndr Id Specificity]
ex_tvs, [Kind]
prov_theta, [EvTerm]
prov_dicts) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           [LocatedA (HsExpr GhcTc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
arg_tys SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
pat_ty

       -- Make the 'matcher'
       ; (PatSynMatcher
matcher, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind) <- GenLocated SrcSpanAnnN Name
-> LPat GhcTc
-> TcPragEnv
-> ([Id], [Kind], TcEvBinds, [Id])
-> ([Id], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> TcM (PatSynMatcher, LHsBinds GhcTc)
tcPatSynMatcher GenLocated SrcSpanAnnN Name
lname LPat GhcTc
lpat' TcPragEnv
prag_fn
                                         ([VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
                                         ([VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
ex_tvs, [Kind]
ex_tys, [Kind]
prov_theta, [EvTerm]
prov_dicts)
                                         ([LHsExpr GhcTc]
args, [Kind]
arg_tys)
                                         Kind
pat_ty

       -- Make the 'builder'
       ; PatSynBuilder
builder <- HsPatSynDir GhcRn
-> GenLocated SrcSpanAnnN Name
-> [VarBndr Id Specificity]
-> [Kind]
-> [VarBndr Id Specificity]
-> [Kind]
-> [Kind]
-> Kind
-> TcM PatSynBuilder
forall a.
HsPatSynDir a
-> GenLocated SrcSpanAnnN Name
-> [VarBndr Id Specificity]
-> [Kind]
-> [VarBndr Id Specificity]
-> [Kind]
-> [Kind]
-> Kind
-> TcM PatSynBuilder
mkPatSynBuilder HsPatSynDir GhcRn
dir GenLocated SrcSpanAnnN Name
lname
                                    [VarBndr Id Specificity]
univ_tvs [Kind]
req_theta
                                    [VarBndr Id Specificity]
ex_tvs   [Kind]
prov_theta
                                    [Kind]
arg_tys Kind
pat_ty

       -- Make the PatSyn itself
       ; let patSyn :: PatSyn
patSyn = Name
-> Bool
-> ([VarBndr Id Specificity], [Kind])
-> ([VarBndr Id Specificity], [Kind])
-> [Kind]
-> Kind
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
lname) Bool
is_infix
                        ([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta)
                        ([VarBndr Id Specificity]
ex_tvs, [Kind]
prov_theta)
                        [Kind]
arg_tys
                        Kind
pat_ty
                        PatSynMatcher
matcher PatSynBuilder
builder
                        [FieldLabel]
field_labels

       -- Selectors
       ; FieldSelectors
has_sel <- DynFlags -> FieldSelectors
xopt_FieldSelectors (DynFlags -> FieldSelectors)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) FieldSelectors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let rn_rec_sel_binds :: [(Id, LHsBind GhcRn)]
rn_rec_sel_binds = PatSyn -> [FieldLabel] -> FieldSelectors -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
patSyn (PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
patSyn) FieldSelectors
has_sel
             tything :: TyThing
tything = ConLike -> TyThing
AConLike (PatSyn -> ConLike
PatSynCon PatSyn
patSyn)
       ; TcGblEnv
tcg_env <- [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
tything] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
                    [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds [(Id, LHsBind GhcRn)]
rn_rec_sel_binds

       ; String -> SDoc -> TcRn ()
traceTc String
"tc_patsyn_finish }" SDoc
forall doc. IsOutput doc => doc
empty
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind, TcGblEnv
tcg_env) }

{-
************************************************************************
*                                                                      *
         Constructing the "matcher" Id and its binding
*                                                                      *
************************************************************************
-}

tcPatSynMatcher :: LocatedN Name
                -> LPat GhcTc
                -> TcPragEnv
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                -> ([LHsExpr GhcTc], [TcType])
                -> TcType
                -> TcM (PatSynMatcher, LHsBinds GhcTc)
-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
tcPatSynMatcher :: GenLocated SrcSpanAnnN Name
-> LPat GhcTc
-> TcPragEnv
-> ([Id], [Kind], TcEvBinds, [Id])
-> ([Id], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> TcM (PatSynMatcher, LHsBinds GhcTc)
tcPatSynMatcher (L SrcSpanAnnN
loc Name
ps_name) LPat GhcTc
lpat TcPragEnv
prag_fn
                ([Id]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
                ([Id]
ex_tvs, [Kind]
ex_tys, [Kind]
prov_theta, [EvTerm]
prov_dicts)
                ([LHsExpr GhcTc]
args, [Kind]
arg_tys) Kind
pat_ty
  = do { let loc' :: SrcSpan
loc' = SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc
       ; Name
rr_name <- OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
newNameAt (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"rep")) SrcSpan
loc'
       ; Name
tv_name <- OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
newNameAt (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"r"))   SrcSpan
loc'
       ; let rr_tv :: Id
rr_tv  = Name -> Kind -> Id
mkTyVar Name
rr_name Kind
runtimeRepTy
             rr :: Kind
rr     = Id -> Kind
mkTyVarTy Id
rr_tv
             res_tv :: Id
res_tv = Name -> Kind -> Id
mkTyVar Name
tv_name (Kind -> Kind
mkTYPEapp Kind
rr)
             res_ty :: Kind
res_ty = Id -> Kind
mkTyVarTy Id
res_tv
             is_unlifted :: Bool
is_unlifted = [LocatedA (HsExpr GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
args Bool -> Bool -> Bool
&& [EvTerm] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvTerm]
prov_dicts
             ([LocatedA (HsExpr GhcTc)]
cont_args, [Kind]
cont_arg_tys)
               | Bool
is_unlifted = ([DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
unboxedUnitDataCon], [Kind
unboxedUnitTy])
               | Bool
otherwise   = ([LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
args,                             [Kind]
arg_tys)
             cont_ty :: Kind
cont_ty = [Id] -> [Kind] -> Kind -> Kind
HasDebugCallStack => [Id] -> [Kind] -> Kind -> Kind
mkInfSigmaTy [Id]
ex_tvs [Kind]
prov_theta (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
                       [Kind] -> Kind -> Kind
mkVisFunTysMany [Kind]
cont_arg_tys Kind
res_ty

             fail_ty :: Kind
fail_ty  = HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
mkVisFunTyMany Kind
unboxedUnitTy Kind
res_ty

       ; Name
matcher_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
ps_name OccName -> OccName
mkMatcherOcc
       ; Id
scrutinee    <- FastString -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"scrut") Kind
ManyTy Kind
pat_ty
       ; Id
cont         <- FastString -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"cont")  Kind
ManyTy Kind
cont_ty
       ; Id
fail         <- FastString -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"fail")  Kind
ManyTy Kind
fail_ty

       ; DynFlags
dflags       <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let matcher_tau :: Kind
matcher_tau   = [Kind] -> Kind -> Kind
mkVisFunTysMany [Kind
pat_ty, Kind
cont_ty, Kind
fail_ty] Kind
res_ty
             matcher_sigma :: Kind
matcher_sigma = [Id] -> [Kind] -> Kind -> Kind
HasDebugCallStack => [Id] -> [Kind] -> Kind -> Kind
mkInfSigmaTy (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs) [Kind]
req_theta Kind
matcher_tau
             matcher_id :: Id
matcher_id    = Name -> Kind -> Id
mkExportedVanillaId Name
matcher_name Kind
matcher_sigma
             patsyn_id :: Id
patsyn_id     = Name -> Kind -> Id
mkExportedVanillaId Name
ps_name Kind
matcher_sigma
                             -- See Note [Exported LocalIds] in GHC.Types.Id

             inst_wrap :: HsWrapper
inst_wrap = [EvTerm] -> HsWrapper
mkWpEvApps [EvTerm]
prov_dicts HsWrapper -> HsWrapper -> HsWrapper
<.> [Kind] -> HsWrapper
mkWpTyApps [Kind]
ex_tys
             cont' :: LocatedA (HsExpr GhcTc)
cont' = (LocatedA (HsExpr GhcTc)
 -> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> [LocatedA (HsExpr GhcTc)]
-> LocatedA (HsExpr GhcTc)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
-> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
inst_wrap (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Id
cont)) [LocatedA (HsExpr GhcTc)]
cont_args

             fail' :: LHsExpr GhcTc
fail' = IdP GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcTc
Id
fail [DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
unboxedUnitDataCon]

             args :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
args = (Id -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map IdP GhcTc -> LPat GhcTc
Id -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id
scrutinee, Id
cont, Id
fail]
             lwpat :: GenLocated SrcSpanAnnA (Pat GhcTc)
lwpat = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcTc
Kind
pat_ty
             cases :: [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
cases = if DynFlags -> LPat GhcTc -> Bool
forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPatRn DynFlags
dflags LPat GhcTc
lpat
                     then [LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat  LocatedA (HsExpr GhcTc)
cont']
                     else [LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat  LocatedA (HsExpr GhcTc)
cont',
                           LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lwpat LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
fail']
             gen :: Origin
gen = DoPmc -> Origin
Generated DoPmc
SkipPmc
             body :: LHsExpr GhcTc
body = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
req_ev_binds) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                    SrcSpanAnnA -> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat) (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                    XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcTc
HsMatchContext GhcTc
forall p. HsMatchContext p
PatSyn (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Id
scrutinee) (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                    MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnL
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l (SrcSpanAnnA -> SrcSpanAnnL) -> SrcSpanAnnA -> SrcSpanAnnL
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat) [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
cases
                      , mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = [Scaled Kind] -> Kind -> Origin -> MatchGroupTc
MatchGroupTc [Kind -> Scaled Kind
forall a. a -> Scaled a
unrestricted Kind
pat_ty] Kind
res_ty Origin
gen
                      }
             body' :: LocatedA (HsExpr GhcTc)
body' = HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                     XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
NoExtField
noExtField (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                     MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
-> LocatedAn AnnList [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
forall a an. a -> LocatedAn an a
noLocA [HsMatchContext GhcTc
-> [LPat GhcTc]
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext GhcTc
forall p. HsMatchContext p
LambdaExpr
                                                         [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
args LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
body]
                       , mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = [Scaled Kind] -> Kind -> Origin -> MatchGroupTc
MatchGroupTc ((Kind -> Scaled Kind) -> [Kind] -> [Scaled Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Scaled Kind
forall a. a -> Scaled a
unrestricted [Kind
pat_ty, Kind
cont_ty, Kind
fail_ty]) Kind
res_ty Origin
gen
                       }
             match :: LMatch GhcTc (LHsExpr GhcTc)
match = HsMatchContext GhcTc
-> [LPat GhcTc]
-> LHsExpr GhcTc
-> HsLocalBinds GhcTc
-> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP (NoGhcTc GhcTc) -> HsMatchContext GhcTc
forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (Id -> Name
idName Id
patsyn_id))) []
                             ([Id] -> [Id] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs)
                                       [Id]
req_dicts LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
body')
                             (XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
NoExtField
noExtField)
             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg = MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = SrcSpanAnnL
-> [GenLocated
      (Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
      (Match GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        (Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
        (Match GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnL
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l (SrcSpanAnnA -> SrcSpanAnnL) -> SrcSpanAnnA -> SrcSpanAnnL
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))
-> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LMatch GhcTc (LHsExpr GhcTc)
GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))
match) [LMatch GhcTc (LHsExpr GhcTc)
GenLocated
  (Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
  (Match GhcTc (LocatedA (HsExpr GhcTc)))
match]
                    , mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = [Scaled Kind] -> Kind -> Origin -> MatchGroupTc
MatchGroupTc [] Kind
res_ty Origin
gen
                    }
             matcher_arity :: Int
matcher_arity = [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
req_theta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
             -- See Note [Pragmas for pattern synonyms]

       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name
       ; Id
matcher_prag_id <- Id -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
addInlinePrags Id
matcher_id              ([LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a b. (a -> b) -> a -> b
$
                            (LSig GhcRn -> LSig GhcRn) -> [LSig GhcRn] -> [LSig GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Int
matcher_arity) ([LSig GhcRn] -> [LSig GhcRn]) -> [LSig GhcRn] -> [LSig GhcRn]
forall a b. (a -> b) -> a -> b
$
                            TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
ps_name

       ; let bind :: HsBindLR GhcTc GhcTc
bind = FunBind{ fun_id :: LIdP GhcTc
fun_id = SrcSpanAnnN -> Id -> GenLocated SrcSpanAnnN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Id
matcher_prag_id
                           , fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
mg
                           , fun_ext :: XFunBind GhcTc GhcTc
fun_ext = (HsWrapper
idHsWrapper, [])
                           }
             matcher_bind :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind = GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsBindLR GhcTc GhcTc
bind)
       ; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynMatcher" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
ps_name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
matcher_id))
       ; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynMatcher" (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind)

       ; (PatSynMatcher,
 Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (PatSynMatcher,
      Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
matcher_name, Kind
matcher_sigma, Bool
is_unlifted), Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind) }

mkPatSynRecSelBinds :: PatSyn
                    -> [FieldLabel]  -- ^ Visible field labels
                    -> FieldSelectors
                    -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -> FieldSelectors -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
ps [FieldLabel]
fields FieldSelectors
has_sel
  = [ [ConLike]
-> RecSelParent
-> FieldLabel
-> FieldSelectors
-> (Id, LHsBind GhcRn)
mkOneRecordSelector [PatSyn -> ConLike
PatSynCon PatSyn
ps] (PatSyn -> RecSelParent
RecSelPatSyn PatSyn
ps) FieldLabel
fld_lbl FieldSelectors
has_sel
    | FieldLabel
fld_lbl <- [FieldLabel]
fields ]

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

{-
************************************************************************
*                                                                      *
         Constructing the "builder" Id
*                                                                      *
************************************************************************
-}

mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name
                -> [InvisTVBinder] -> ThetaType
                -> [InvisTVBinder] -> ThetaType
                -> [Type] -> Type
                -> TcM PatSynBuilder
mkPatSynBuilder :: forall a.
HsPatSynDir a
-> GenLocated SrcSpanAnnN Name
-> [VarBndr Id Specificity]
-> [Kind]
-> [VarBndr Id Specificity]
-> [Kind]
-> [Kind]
-> Kind
-> TcM PatSynBuilder
mkPatSynBuilder HsPatSynDir a
dir (L SrcSpanAnnN
_ Name
name)
                  [VarBndr Id Specificity]
univ_bndrs [Kind]
req_theta [VarBndr Id Specificity]
ex_bndrs [Kind]
prov_theta
                  [Kind]
arg_tys Kind
pat_ty
  | HsPatSynDir a -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir a
dir
  = PatSynBuilder -> TcM PatSynBuilder
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return PatSynBuilder
forall a. Maybe a
Nothing
  | Bool
otherwise
  = do { Name
builder_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkBuilderOcc
       ; let theta :: [Kind]
theta          = [Kind]
req_theta [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
prov_theta
             need_dummy_arg :: Bool
need_dummy_arg = HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
pat_ty Bool -> Bool -> Bool
&& [Kind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
arg_tys Bool -> Bool -> Bool
&& [Kind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
theta
                              -- NB: pattern arguments cannot be representation-polymorphic,
                              -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here.
             builder_sigma :: Kind
builder_sigma  = Bool -> Kind -> Kind
add_void Bool
need_dummy_arg (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
                              [VarBndr Id Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr Id Specificity]
univ_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
                              [VarBndr Id Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr Id Specificity]
ex_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
                              [Kind] -> Kind -> Kind
HasDebugCallStack => [Kind] -> Kind -> Kind
mkPhiTy [Kind]
theta (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
                              [Kind] -> Kind -> Kind
mkVisFunTysMany [Kind]
arg_tys (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
                              Kind
pat_ty

       ; PatSynBuilder -> TcM PatSynBuilder
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatSynMatcher -> PatSynBuilder
forall a. a -> Maybe a
Just (Name
builder_name, Kind
builder_sigma, Bool
need_dummy_arg)) }

tcPatSynBuilderBind :: TcPragEnv
                    -> PatSynBind GhcRn GhcRn
                    -> TcM (LHsBinds GhcTc)
-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind TcPragEnv
prag_fn (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = ps_lname :: LIdP GhcRn
ps_lname@(L SrcSpanAnnN
loc Name
ps_name)
                                 , psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat
                                 , psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir
                                 , psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details })
  | HsPatSynDir GhcRn -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir GhcRn
dir
  = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag

  | Left PatSynInvalidRhsReason
why <- Either
  PatSynInvalidRhsReason
  (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group       -- Can't invert the pattern
  = SrcSpan -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (Pat GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
lpat) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcM (LHsBinds GhcTc)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (LHsBinds GhcTc))
-> TcRnMessage -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ Name
-> LPat GhcRn
-> [LIdP GhcRn]
-> PatSynInvalidRhsReason
-> TcRnMessage
TcRnPatSynInvalidRhs Name
ps_name LPat GhcRn
lpat [LIdP GhcRn]
args PatSynInvalidRhsReason
why

  | Right MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group <- Either
  PatSynInvalidRhsReason
  (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group  -- Bidirectional
  = do { PatSyn
patsyn <- Name -> TcM PatSyn
tcLookupPatSyn Name
ps_name
       ; case PatSyn -> PatSynBuilder
patSynBuilder PatSyn
patsyn of {
           PatSynBuilder
Nothing -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
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 (Name
builder_name, Kind
builder_ty, Bool
need_dummy_arg) ->  -- Normal case
    do { -- Bidirectional, so patSynBuilder returns Just
         let builder_id :: Id
builder_id = Name -> Kind -> Id
mkExportedVanillaId Name
builder_name Kind
builder_ty
                         -- See Note [Exported LocalIds] in GHC.Types.Id

             ([VarBndr Id Specificity]
_, [Kind]
req_theta, [VarBndr Id Specificity]
_, [Kind]
prov_theta, [Scaled Kind]
arg_tys, Kind
_) = PatSyn
-> ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
    [Kind], [Scaled Kind], Kind)
patSynSigBndr PatSyn
patsyn
             builder_arity :: Int
builder_arity = [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
req_theta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
prov_theta
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Scaled Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Kind]
arg_tys
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
need_dummy_arg then Int
1 else Int
0)

       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) builder name
       ; Id
builder_id <- Id -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
addInlinePrags Id
builder_id              ([LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a b. (a -> b) -> a -> b
$
                       (LSig GhcRn -> LSig GhcRn) -> [LSig GhcRn] -> [LSig GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Int
builder_arity) ([LSig GhcRn] -> [LSig GhcRn]) -> [LSig GhcRn] -> [LSig GhcRn]
forall a b. (a -> b) -> a -> b
$
                       TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
ps_name

       ; let match_group' :: MatchGroup GhcRn (LHsExpr GhcRn)
match_group' | Bool
need_dummy_arg = MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group
                          | Bool
otherwise      = MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group

             bind :: HsBindLR GhcRn GhcRn
bind = FunBind { fun_id :: LIdP GhcRn
fun_id      = SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (Id -> Name
idName Id
builder_id)
                            , fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
match_group'
                            , fun_ext :: XFunBind GhcRn GhcRn
fun_ext     = XFunBind GhcRn GhcRn
NameSet
emptyNameSet
                            }

             sig :: TcIdSigInfo
sig = UserTypeCtxt -> Id -> TcIdSigInfo
completeSigFromId (Name -> UserTypeCtxt
PatSynCtxt Name
ps_name) Id
builder_id

       ; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
patsyn
              , Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
builder_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
builder_id) ]
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder_binds, [Id]
_) <- TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [Id])
tcPolyCheck TcPragEnv
emptyPragEnv TcIdSigInfo
sig (HsBindLR GhcRn GhcRn
-> LocatedAn AnnListItem (HsBindLR GhcRn GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsBindLR GhcRn GhcRn
bind)
       ; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder_binds
       ; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder_binds } } }

#if __GLASGOW_HASKELL__ <= 810
  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
#endif
  where
    mb_match_group :: Either
  PatSynInvalidRhsReason
  (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
       = case HsPatSynDir GhcRn
dir of
           ExplicitBidirectional MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg -> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either
     PatSynInvalidRhsReason
     (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b. b -> Either a b
Right MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
explicit_mg
           HsPatSynDir GhcRn
ImplicitBidirectional -> (GenLocated SrcSpanAnnA (HsExpr GhcRn)
 -> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Either
     PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either
     PatSynInvalidRhsReason
     (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b.
(a -> b)
-> Either PatSynInvalidRhsReason a
-> Either PatSynInvalidRhsReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
mk_mg ([GenLocated SrcSpanAnnN Name]
-> LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
tcPatToExpr [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
args LPat GhcRn
lpat)
           HsPatSynDir GhcRn
Unidirectional -> String
-> Either
     PatSynInvalidRhsReason
     (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a. HasCallStack => String -> a
panic String
"tcPatSynBuilderBind"

    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg LHsExpr GhcRn
body = Origin
-> LocatedL
     [LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup (DoPmc -> Origin
Generated DoPmc
SkipPmc) ([LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> LocatedL
     [LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a an. a -> LocatedAn an a
noLocA [LMatch GhcRn (LHsExpr GhcRn)
LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
builder_match])
          where
            builder_args :: [GenLocated SrcSpanAnnA (Pat GhcRn)]
builder_args  = [SrcSpanAnnA -> Pat GhcRn -> GenLocated SrcSpanAnnA (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnnN
loc) (XVarPat GhcRn -> LIdP GhcRn -> Pat GhcRn
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcRn
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n))
                            | L SrcSpanAnnN
loc Name
n <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
args]
            builder_match :: LMatch GhcRn (LHsExpr GhcRn)
builder_match = HsMatchContext GhcRn
-> [LPat GhcRn]
-> LHsExpr GhcRn
-> HsLocalBinds GhcRn
-> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP (NoGhcTc GhcRn) -> HsMatchContext GhcRn
forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LIdP (NoGhcTc GhcRn)
LIdP GhcRn
ps_lname)
                                    [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
builder_args LHsExpr GhcRn
body
                                    (XEmptyLocalBinds GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
NoExtField
noExtField)

    args :: [LIdP GhcRn]
args = case HsPatSynDetails GhcRn
details of
              PrefixCon [Void]
_ [LIdP GhcRn]
args   -> [LIdP GhcRn]
args
              InfixCon LIdP GhcRn
arg1 LIdP GhcRn
arg2 -> [LIdP GhcRn
arg1, LIdP GhcRn
arg2]
              RecCon [RecordPatSynField GhcRn]
args        -> (RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name)
-> [RecordPatSynField GhcRn] -> [GenLocated SrcSpanAnnN Name]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField GhcRn -> LIdP GhcRn
RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar [RecordPatSynField GhcRn]
args

    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
                  -> MatchGroup GhcRn (LHsExpr GhcRn)
    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg mg :: MatchGroup GhcRn (LHsExpr GhcRn)
mg@(MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts =
                           (L SrcSpanAnnL
l [L SrcSpanAnnA
loc match :: Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats })]) })
      = MatchGroup GhcRn (LHsExpr GhcRn)
mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
    add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
other_mg = String -> SDoc -> MatchGroup GhcRn (LHsExpr GhcRn)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"add_dummy_arg" (SDoc -> MatchGroup GhcRn (LHsExpr GhcRn))
-> SDoc -> MatchGroup GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$
                             MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
other_mg

patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, Kind)
patSynBuilderOcc PatSyn
ps
  | Just (Name
_, Kind
builder_ty, Bool
add_void_arg) <- PatSyn -> PatSynBuilder
patSynBuilder PatSyn
ps
  , let builder_expr :: HsExpr GhcTc
builder_expr = ConLike -> HsExpr GhcTc
mkConLikeTc (PatSyn -> ConLike
PatSynCon PatSyn
ps)
  = (HsExpr GhcTc, Kind) -> Maybe (HsExpr GhcTc, Kind)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, Kind) -> Maybe (HsExpr GhcTc, Kind))
-> (HsExpr GhcTc, Kind) -> Maybe (HsExpr GhcTc, Kind)
forall a b. (a -> b) -> a -> b
$
    if Bool
add_void_arg
    then ( HsExpr GhcTc
builder_expr   -- still just return builder_expr; the void# arg
                          -- is added by dsConLike in the desugarer
         , Kind -> Kind
tcFunResultTy Kind
builder_ty )
    else (HsExpr GhcTc
builder_expr, Kind
builder_ty)

  | Bool
otherwise  -- Unidirectional
  = Maybe (HsExpr GhcTc, Kind)
forall a. Maybe a
Nothing

add_void :: Bool -> Type -> Type
add_void :: Bool -> Kind -> Kind
add_void Bool
need_dummy_arg Kind
ty
  | Bool
need_dummy_arg = HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
mkVisFunTyMany Kind
unboxedUnitTy Kind
ty
  | Bool
otherwise      = Kind
ty

tcPatToExpr :: [LocatedN Name] -> LPat GhcRn
            -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
-- 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 :: [GenLocated SrcSpanAnnN Name]
-> LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
tcPatToExpr [GenLocated SrcSpanAnnN Name]
args LPat GhcRn
pat = LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go LPat GhcRn
pat
  where
    lhsVars :: NameSet
lhsVars = [Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpanAnnN Name]
args)

    -- Make a prefix con for prefix and infix patterns for simplicity
    mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
                    -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
    mkPrefixConExpr :: GenLocated SrcSpanAnnN Name
-> [LPat GhcRn] -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr lcon :: GenLocated SrcSpanAnnN Name
lcon@(L SrcSpanAnnN
loc Name
_) [LPat GhcRn]
pats
      = do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
 -> Either
      PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either
     PatSynInvalidRhsReason [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
     PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
           ; let con :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
con = SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
loc) (XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField LIdP GhcRn
GenLocated SrcSpanAnnN Name
lcon)
           ; HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
con [LHsExpr GhcRn]
[GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs)
           }

    mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)
                    -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
    mkRecordConExpr :: GenLocated SrcSpanAnnN Name
-> HsRecFields GhcRn (LPat GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkRecordConExpr GenLocated SrcSpanAnnN Name
con (HsRecFields [LHsRecField GhcRn (LPat GhcRn)]
fields Maybe (XRec GhcRn RecFieldsDotDot)
dd)
      = do { [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
exprFields <- (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (Pat GhcRn)))
 -> Either
      PatSynInvalidRhsReason
      (GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
            (GenLocated SrcSpanAnnA (HsExpr GhcRn)))))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (Pat GhcRn)))]
-> Either
     PatSynInvalidRhsReason
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
           (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsRecField GhcRn (LPat GhcRn)
-> Either
     PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
     (GenLocated SrcSpanAnnA (Pat GhcRn)))
-> Either
     PatSynInvalidRhsReason
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
           (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
go' [LHsRecField GhcRn (LPat GhcRn)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (Pat GhcRn)))]
fields
           ; HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRecordCon GhcRn
-> XRec GhcRn (ConLikeP GhcRn)
-> HsRecordBinds GhcRn
-> HsExpr GhcRn
forall p.
XRecordCon p -> XRec p (ConLikeP p) -> HsRecordBinds p -> HsExpr p
RecordCon XRecordCon GhcRn
NoExtField
noExtField XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
con ([LHsRecField GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> Maybe (XRec GhcRn RecFieldsDotDot)
-> HsRecFields GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields [LHsRecField GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
exprFields Maybe (XRec GhcRn RecFieldsDotDot)
dd)) }

    go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
    go' :: LHsRecField GhcRn (LPat GhcRn)
-> Either
     PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
go' (L SrcSpanAnnA
l HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (Pat GhcRn))
rf) = SrcSpanAnnA
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
     (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
        (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
   (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
-> Either
     PatSynInvalidRhsReason
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
        (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Either
     PatSynInvalidRhsReason
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
           (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (Pat GhcRn)
 -> Either
      PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
     (GenLocated SrcSpanAnnA (Pat GhcRn))
-> Either
     PatSynInvalidRhsReason
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
        (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) a
-> f (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) b)
traverse LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
     PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (Pat GhcRn))
rf

    go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
    go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go (L SrcSpanAnnA
loc Pat GhcRn
p) = SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
-> Either
     PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 Pat GhcRn
p

    go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
    go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (ConPat XConPat GhcRn
NoExtField
NoExtField XRec GhcRn (ConLikeP GhcRn)
con HsConPatDetails GhcRn
info)
      = case HsConPatDetails GhcRn
info of
          PrefixCon [HsConPatTyArg (NoGhcTc GhcRn)]
_ [LPat GhcRn]
ps -> GenLocated SrcSpanAnnN Name
-> [LPat GhcRn] -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
con [LPat GhcRn]
ps
          InfixCon LPat GhcRn
l LPat GhcRn
r   -> GenLocated SrcSpanAnnN Name
-> [LPat GhcRn] -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
con [LPat GhcRn
l,LPat GhcRn
r]
          RecCon HsRecFields GhcRn (LPat GhcRn)
fields  -> GenLocated SrcSpanAnnN Name
-> HsRecFields GhcRn (LPat GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkRecordConExpr XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
con HsRecFields GhcRn (LPat GhcRn)
fields

    go1 (SigPat XSigPat GhcRn
_ LPat GhcRn
pat HsPatSigType (NoGhcTc GhcRn)
_) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)
        -- See Note [Type signatures and the builder expression]

    go1 (VarPat XVarPat GhcRn
_ (L SrcSpanAnnN
l Name
var))
        | Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
lhsVars
        = HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
var)
        | Bool
otherwise
        = PatSynInvalidRhsReason
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. a -> Either a b
Left (Name -> PatSynInvalidRhsReason
PatSynUnboundVar Name
var)
    go1 (ParPat XParPat GhcRn
_ LHsToken "(" GhcRn
lpar LPat GhcRn
pat LHsToken ")" GhcRn
rpar) = (LHsExpr GhcRn -> HsExpr GhcRn)
-> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b.
(a -> b)
-> Either PatSynInvalidRhsReason a
-> Either PatSynInvalidRhsReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\LHsExpr GhcRn
e -> XPar GhcRn
-> LHsToken "(" GhcRn
-> LHsExpr GhcRn
-> LHsToken ")" GhcRn
-> HsExpr GhcRn
forall p.
XPar p -> LHsToken "(" p -> LHsExpr p -> LHsToken ")" p -> HsExpr p
HsPar XPar GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn LHsToken "(" GhcRn
lpar LHsExpr GhcRn
e LHsToken ")" GhcRn
rpar) (Either PatSynInvalidRhsReason (LHsExpr GhcRn)
 -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go LPat GhcRn
pat
    go1 (ListPat XListPat GhcRn
_ [LPat GhcRn]
pats)
      = do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
 -> Either
      PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either
     PatSynInvalidRhsReason [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
     PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
           ; HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcRn -> [LHsExpr GhcRn] -> HsExpr GhcRn
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcRn
NoExtField
noExtField [LHsExpr GhcRn]
[GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs }
    go1 (TuplePat XTuplePat GhcRn
_ [LPat GhcRn]
pats Boxity
box)       = do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
 -> Either
      PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either
     PatSynInvalidRhsReason [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
     PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
                                         ; HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcRn -> [HsTupArg GhcRn] -> Boxity -> HsExpr GhcRn
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
NoExtField
noExtField
                                           ((GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsTupArg GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)] -> [HsTupArg GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (XPresent GhcRn -> LHsExpr GhcRn -> HsTupArg GhcRn
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn) [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs) Boxity
box }
    go1 (SumPat XSumPat GhcRn
_ LPat GhcRn
pat Int
alt Int
arity)    = do { HsExpr GhcRn
expr <- Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)
                                         ; HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitSum GhcRn -> Int -> Int -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcRn
NoExtField
noExtField Int
alt Int
arity
                                                                   (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
expr)
                                         }
    go1 (LitPat XLitPat GhcRn
_ HsLit GhcRn
lit)              = HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
EpAnn NoEpAnns
noComments HsLit GhcRn
lit
    go1 (NPat XNPat GhcRn
_ (L SrcAnn NoEpAnns
_ HsOverLit GhcRn
n) Maybe (SyntaxExpr GhcRn)
mb_neg SyntaxExpr GhcRn
_)
        | Just (SyntaxExprRn HsExpr GhcRn
neg) <- Maybe (SyntaxExpr GhcRn)
mb_neg
                                    = HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcRn)
 -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
 -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
neg)
                                                       [HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsOverLit GhcRn
n)]
        | Bool
otherwise                 = HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsOverLit GhcRn
n
    go1 (SplicePat (HsUntypedSpliceTop ThModFinalizers
_ Pat GhcRn
pat) HsUntypedSplice GhcRn
_) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 Pat GhcRn
pat
    go1 (SplicePat (HsUntypedSpliceNested Name
_) HsUntypedSplice GhcRn
_)  = String -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. HasCallStack => String -> a
panic String
"tcPatToExpr: invalid nested splice"
    go1 (XPat (HsPatExpanded Pat GhcRn
_ Pat GhcRn
pat))= Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 Pat GhcRn
pat

    -- See Note [Invertible view patterns]
    go1 p :: Pat GhcRn
p@(ViewPat XViewPat GhcRn
mbInverse LHsExpr GhcRn
_ LPat GhcRn
pat) = case XViewPat GhcRn
mbInverse of
      Maybe (HsExpr GhcRn)
XViewPat GhcRn
Nothing      -> Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
      Just HsExpr GhcRn
inverse ->
        (HsExpr GhcRn -> HsExpr GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b.
(a -> b)
-> Either PatSynInvalidRhsReason a
-> Either PatSynInvalidRhsReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\ HsExpr GhcRn
expr -> XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
inverse) (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
expr))
          (Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat))

    -- The following patterns are not invertible.
    go1 p :: Pat GhcRn
p@(BangPat {})                       = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p -- #14112
    go1 p :: Pat GhcRn
p@(LazyPat {})                       = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
    go1 p :: Pat GhcRn
p@(WildPat {})                       = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
    go1 p :: Pat GhcRn
p@(AsPat {})                         = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
    go1 p :: Pat GhcRn
p@(NPlusKPat {})                     = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p

    notInvertible :: Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p = PatSynInvalidRhsReason -> Either PatSynInvalidRhsReason b
forall a b. a -> Either a b
Left (Pat GhcRn -> PatSynInvalidRhsReason
PatSynNotInvertible Pat GhcRn
p)

{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For a bidirectional pattern synonym, the function 'tcPatToExpr'
needs to produce an /expression/ that matches the supplied /pattern/,
given values for the arguments of the pattern synonym. 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. general view patterns
      pattern F x = (f -> x)
   as we don't have the ability to write down an expression that matches
   the view pattern specified by an arbitrary view function `f`.
   It is however sometimes possible to write down an inverse;
     see Note [Invertible view patterns].

 * 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,_)

Note [Invertible view patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For some view patterns, such as those that arise from expansion of overloaded
patterns (as detailed in Note [Handling overloaded and rebindable patterns]),
we are able to explicitly write out an inverse (in the sense of the previous
Note [Builder for a bidirectional pattern synonym]).
For instance, the inverse to the pattern

  (toList -> [True, False])

is the expression

  (fromListN 2 [True,False])

Keeping track of the inverse for such view patterns fixed #14380.

Note [Redundant constraints for builder]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The builder can have redundant constraints, which are awkward to eliminate.
Consider
   pattern P = Just 34
To match against this pattern we need (Eq a, Num a).  But to build
(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
sig_warn_redundant to False.

************************************************************************
*                                                                      *
         Helper functions
*                                                                      *
************************************************************************

Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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:

        pattern K x y = x@(Just y)

one could write a nonsensical function like

        f (K Nothing x) = ...

or
        g (K (Just True) False) = ...

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 signature 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; #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.

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 GHC.HsToCore.Expr if you
want to avoid difficult to decipher core lint errors!

Note [Pragmas for pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
INLINE and NOINLINE pragmas are supported for pattern synonyms.
They affect both the matcher and the builder.
(See Note [Matchers and builders for pattern synonyms] in PatSyn)

For example:
    pattern InlinedPattern x = [x]
    {-# INLINE InlinedPattern #-}

    pattern NonInlinedPattern x = [x]
    {-# NOINLINE NonInlinedPattern #-}

For pattern synonyms with explicit builders, only a pragma for the
entire pattern synonym is supported. For example:
    pattern HeadC x <- x:xs where
      HeadC x = [x]
      -- This wouldn't compile: {-# INLINE HeadC #-}
    {-# INLINE HeadC #-} -- But this works

When no pragma is provided for a pattern, the inlining decision might change
between different versions of GHC.

Implementation notes.  The prag_fn passed in to tcPatSynDecl will have a binding
for the /pattern synonym/ Name, thus
      InlinedPattern :-> INLINE
From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher)
and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/
Name in the prag_fn, and then using addInlinePragArity to add the right
inl_sat field to that INLINE pragma for the matcher or builder respectively.
 -}


-- 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.
tcCollectEx
  :: LPat GhcTc
  -> ( [TyVar]        -- Existentially-bound type variables
                      -- in correctly-scoped order; e.g. [ k:*, x:k ]
     , [EvVar] )      -- and evidence variables

tcCollectEx :: LPat GhcTc -> ([Id], [Id])
tcCollectEx LPat GhcTc
pat = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
pat
  where
    go :: LPat GhcTc -> ([TyVar], [EvVar])
    go :: LPat GhcTc -> ([Id], [Id])
go = Pat GhcTc -> ([Id], [Id])
go1 (Pat GhcTc -> ([Id], [Id]))
-> (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc

    go1 :: Pat GhcTc -> ([TyVar], [EvVar])
    go1 :: Pat GhcTc -> ([Id], [Id])
go1 (LazyPat XLazyPat GhcTc
_ LPat GhcTc
p)      = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (AsPat XAsPat GhcTc
_ LIdP GhcTc
_ LHsToken "@" GhcTc
_ LPat GhcTc
p)    = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (ParPat XParPat GhcTc
_ LHsToken "(" GhcTc
_ LPat GhcTc
p LHsToken ")" GhcTc
_)   = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (BangPat XBangPat GhcTc
_ LPat GhcTc
p)      = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (ListPat XListPat GhcTc
_ [LPat GhcTc]
ps)     = [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
    go1 (TuplePat XTuplePat GhcTc
_ [LPat GhcTc]
ps Boxity
_)  = [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
    go1 (SumPat XSumPat GhcTc
_ LPat GhcTc
p Int
_ Int
_)   = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ LPat GhcTc
p)    = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 con :: Pat GhcTc
con@ConPat{ pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = XConPat GhcTc
con' }
                           = ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge (ConPatTc -> [Id]
cpt_tvs XConPat GhcTc
ConPatTc
con', ConPatTc -> [Id]
cpt_dicts XConPat GhcTc
ConPatTc
con') (([Id], [Id]) -> ([Id], [Id])) -> ([Id], [Id]) -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
                              HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (HsConPatDetails GhcTc -> ([Id], [Id]))
-> HsConPatDetails GhcTc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ Pat GhcTc -> HsConPatDetails GhcTc
forall p. Pat p -> HsConPatDetails p
pat_args Pat GhcTc
con
    go1 (SigPat XSigPat GhcTc
_ LPat GhcTc
p HsPatSigType (NoGhcTc GhcTc)
_)     = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (XPat XXPat GhcTc
ext) = case XXPat GhcTc
ext of
      CoPat HsWrapper
_ Pat GhcTc
p Kind
_      -> Pat GhcTc -> ([Id], [Id])
go1 Pat GhcTc
p
      ExpansionPat Pat GhcRn
_ Pat GhcTc
p -> Pat GhcTc -> ([Id], [Id])
go1 Pat GhcTc
p
    go1 (NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
n XRec GhcTc (HsOverLit GhcTc)
k HsOverLit GhcTc
_ SyntaxExpr GhcTc
geq SyntaxExpr GhcTc
subtract)
      = String -> SDoc -> ([Id], [Id])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"TODO: NPlusKPat" (SDoc -> ([Id], [Id])) -> SDoc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
GenLocated SrcSpanAnnN Id
n SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated (SrcAnn NoEpAnns) (HsOverLit GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr XRec GhcTc (HsOverLit GhcTc)
GenLocated (SrcAnn NoEpAnns) (HsOverLit GhcTc)
k SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SyntaxExprTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
SyntaxExprTc
geq SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SyntaxExprTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
SyntaxExprTc
subtract
    go1 Pat GhcTc
_                   = ([Id], [Id])
forall {a} {a}. ([a], [a])
empty

    goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
    goConDetails :: HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)]
_ [LPat GhcTc]
ps) = [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
    goConDetails (InfixCon LPat GhcTc
p1 LPat GhcTc
p2) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p1 ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
`merge` LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p2
    goConDetails (RecCon HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcTc (LPat GhcTc)]
flds })
      = [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LHsRecField GhcTc (LPat GhcTc)] -> [([Id], [Id])])
-> [LHsRecField GhcTc (LPat GhcTc)]
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
      (GenLocated SrcSpanAnnA (Pat GhcTc)))
 -> ([Id], [Id]))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
     (GenLocated SrcSpanAnnA (Pat GhcTc)))
-> ([Id], [Id])
goRecFd ([LHsRecField GhcTc (LPat GhcTc)] -> ([Id], [Id]))
-> [LHsRecField GhcTc (LPat GhcTc)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LHsRecField GhcTc (LPat GhcTc)]
flds

    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
goRecFd (L SrcSpanAnnA
_ HsFieldBind{ hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = GenLocated SrcSpanAnnA (Pat GhcTc)
p }) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
p

    merge :: ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge ([a]
vs1, [a]
evs1) ([a]
vs2, [a]
evs2) = ([a]
vs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
vs2, [a]
evs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
evs2)
    mergeMany :: [([a], [a])] -> ([a], [a])
mergeMany = (([a], [a]) -> ([a], [a]) -> ([a], [a]))
-> ([a], [a]) -> [([a], [a])] -> ([a], [a])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a], [a]) -> ([a], [a]) -> ([a], [a])
forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge ([a], [a])
forall {a} {a}. ([a], [a])
empty
    empty :: ([a], [a])
empty     = ([], [])