{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
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.Utils.Zonk
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
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.Error
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)
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
import Data.List( partition, mapAccumL )
tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)
-> TcSigFun
-> TcPragEnv
-> 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)
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], []) ([], [])
[]
Kind
alphaTy
(Name
matcher_name, Kind
matcher_ty, Bool
True) PatSynBuilder
forall a. Maybe a
Nothing
[]
where
matcher_ty :: Kind
matcher_ty = [Id] -> Kind -> Kind
mkSpecForAllTys [Id
alphaTyVar] Kind
alphaTy
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))
; (([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 <- (Id -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Id] -> 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 Id -> IOEnv (Env TcGblEnv TcLclEnv) 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
([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
; [Id]
args <- (Id -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Id] -> 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 Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
zonkId [Id]
args
; let bad_args :: [(Id, DVarSet)]
bad_args = [ (Id
arg, DVarSet
bad_cos) | Id
arg <- [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
prov_dicts
, let bad_cos :: DVarSet
bad_cos = (Id -> Bool) -> DVarSet -> DVarSet
filterDVarSet Id -> Bool
isId (DVarSet -> DVarSet) -> DVarSet -> DVarSet
forall a b. (a -> b) -> a -> b
$
(Kind -> DVarSet
tyCoVarsOfTypeDSet (Id -> Kind
idType Id
arg))
, Bool -> Bool
not (DVarSet -> Bool
isEmptyDVarSet DVarSet
bad_cos) ]
; ((Id, DVarSet) -> TcRn ()) -> [(Id, DVarSet)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Id, DVarSet) -> TcRn ()
dependentArgErr [(Id, DVarSet)]
bad_args
; CandidatesQTvs
dvs <- [Kind] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Kind]
prov_theta
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env
= do { (TidyEnv
tidy_env2, [Kind]
theta) <- TidyEnv -> [Kind] -> TcM (TidyEnv, [Kind])
zonkTidyTcTypes TidyEnv
tidy_env [Kind]
prov_theta
; (TidyEnv, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the provided context:"
, [Kind] -> SDoc
pprTheta [Kind]
theta ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; 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 <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; LocatedN 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
LocatedN 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)
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 = (() :: Constraint) => Kind -> Kind
Kind -> Kind
typeKind Kind
ty1
k2 :: Kind
k2 = (() :: Constraint) => Kind -> Kind
Kind -> Kind
typeKind Kind
ty2
is_homo :: Bool
is_homo = Kind
k1 (() :: Constraint) => 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, DTyCoVarSet) -> TcM ()
dependentArgErr :: (Id, DVarSet) -> TcRn ()
dependentArgErr (Id
arg, DVarSet
bad_cos)
= TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Iceland Jack! Iceland Jack! Stop torturing me!"
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Pattern-bound variable")
Int
2 (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg 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
arg))
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has a type that mentions pattern-bound coercion"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Id] -> SDoc
forall a. [a] -> SDoc
plural [Id]
bad_co_list SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
Int
2 ((Id -> SDoc) -> [Id] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bad_co_list)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hint: use -fprint-explicit-coercions to see the coercions"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Probable fix: add a pattern signature" ]
where
bad_co_list :: [Id]
bad_co_list = DVarSet -> [Id]
dVarSetElems DVarSet
bad_cos
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
; 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
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The result type of the signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"namely" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
pat_ty) ])
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mentions existential type variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Id] -> SDoc
forall a. [a] -> SDoc
plural [Id]
bad_tvs
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Id] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Id]
bad_tvs)
; 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
; 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 [])
; (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 = (() :: Constraint) => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst0 [Kind]
req_theta
skol_prov_theta :: [Kind]
skol_prov_theta = (() :: Constraint) => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst [Kind]
prov_theta
skol_arg_tys :: [Kind]
skol_arg_tys = (() :: Constraint) => 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 = (() :: Constraint) => 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 ]
; [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
; 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' = (() :: Constraint) => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
inst_subst [Kind]
skol_prov_theta
; [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
; Bag Implication -> TcRn ()
simplifyTopImplic Bag Implication
implics
; 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 <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; LocatedN 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
LocatedN 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)
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
$
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)
((() :: Constraint) => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
subst Kind
arg_ty)
; 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])
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) }
collectPatSynArgInfo :: HsPatSynDetails GhcRn
-> ([Name], Bool)
collectPatSynArgInfo :: HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details =
case HsPatSynDetails GhcRn
details of
PrefixCon [Void]
_ [LIdP GhcRn]
names -> ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[LocatedN Name]
names, Bool
False)
InfixCon LIdP GhcRn
name1 LIdP GhcRn
name2 -> ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn
LocatedN Name
name1, LIdP GhcRn
LocatedN Name
name2], Bool
True)
RecCon [RecordPatSynField GhcRn]
names -> ((RecordPatSynField GhcRn -> Name)
-> [RecordPatSynField GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc (LocatedN Name -> Name)
-> (RecordPatSynField GhcRn -> LocatedN Name)
-> RecordPatSynField GhcRn
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField GhcRn -> LIdP GhcRn
RecordPatSynField GhcRn -> LocatedN 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
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc -> SDoc
speakNOf Int
decl_arity (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"argument"))
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"but its type signature has" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
missing SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fewer arrows")
tc_patsyn_finish :: LocatedN Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> TcPragEnv
-> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])
-> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
-> ([LHsExpr GhcTc], [TcTypeFRR])
-> TcType
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish :: LocatedN 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 LocatedN 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 {
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [VarBndr Id Specificity]
univ_tvs') <- ZonkEnv
-> [VarBndr Id Specificity]
-> TcM (ZonkEnv, [VarBndr Id Specificity])
forall vis.
ZonkEnv -> [VarBndr Id vis] -> TcM (ZonkEnv, [VarBndr Id vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr Id Specificity]
univ_tvs
; [Kind]
req_theta' <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
req_theta
; (ZonkEnv
ze, [VarBndr Id Specificity]
ex_tvs') <- ZonkEnv
-> [VarBndr Id Specificity]
-> TcM (ZonkEnv, [VarBndr Id Specificity])
forall vis.
ZonkEnv -> [VarBndr Id vis] -> TcM (ZonkEnv, [VarBndr Id vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr Id Specificity]
ex_tvs
; [Kind]
prov_theta' <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
prov_theta
; Kind
pat_ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
pat_ty
; [Kind]
arg_tys' <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [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'
; 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 (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc LocatedN 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
; (PatSynMatcher
matcher, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind) <- LocatedN Name
-> LPat GhcTc
-> TcPragEnv
-> ([Id], [Kind], TcEvBinds, [Id])
-> ([Id], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> TcM (PatSynMatcher, LHsBinds GhcTc)
tcPatSynMatcher LocatedN 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
; PatSynBuilder
builder <- HsPatSynDir GhcRn
-> LocatedN Name
-> [VarBndr Id Specificity]
-> [Kind]
-> [VarBndr Id Specificity]
-> [Kind]
-> [Kind]
-> Kind
-> TcM PatSynBuilder
forall a.
HsPatSynDir a
-> LocatedN Name
-> [VarBndr Id Specificity]
-> [Kind]
-> [VarBndr Id Specificity]
-> [Kind]
-> [Kind]
-> Kind
-> TcM PatSynBuilder
mkPatSynBuilder HsPatSynDir GhcRn
dir LocatedN Name
lname
[VarBndr Id Specificity]
univ_tvs [Kind]
req_theta
[VarBndr Id Specificity]
ex_tvs [Kind]
prov_theta
[Kind]
arg_tys Kind
pat_ty
; let patSyn :: PatSyn
patSyn = Name
-> Bool
-> ([VarBndr Id Specificity], [Kind])
-> ([VarBndr Id Specificity], [Kind])
-> [Kind]
-> Kind
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc LocatedN 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
; 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) }
tcPatSynMatcher :: LocatedN Name
-> LPat GhcTc
-> TcPragEnv
-> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
-> ([TcTyVar], [TcType], ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], [TcType])
-> TcType
-> TcM (PatSynMatcher, LHsBinds GhcTc)
tcPatSynMatcher :: LocatedN 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
(() :: Constraint) => [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 = (() :: Constraint) => 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
(() :: Constraint) => [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
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
isIrrefutableHsPat 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']
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
NoExtField
noExtField (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
Generated
}
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
Generated
}
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 -> LocatedN 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
Generated
}
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
; 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]
-> 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
mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name
-> [InvisTVBinder] -> ThetaType
-> [InvisTVBinder] -> ThetaType
-> [Type] -> Type
-> TcM PatSynBuilder
mkPatSynBuilder :: forall a.
HsPatSynDir a
-> LocatedN 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 = (() :: Constraint) => 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
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
(() :: Constraint) => [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)
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 SDoc
why <- Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= 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
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Invalid right-hand side of bidirectional 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
ps_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
Int
2 SDoc
why
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RHS pattern:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
lpat ]
| Right MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group <- Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= 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 ;
Just (Name
builder_name, Kind
builder_ty, Bool
need_dummy_arg) ->
do {
let builder_id :: Id
builder_id = Name -> Kind -> Id
mkExportedVanillaId Name
builder_name Kind
builder_ty
([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)
; 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 -> LocatedN 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"
#endif
where
mb_match_group :: Either
SDoc (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
SDoc (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 SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b. (a -> b) -> Either SDoc a -> Either SDoc 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 (Name
-> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
ps_name [LIdP GhcRn]
[LocatedN Name]
args LPat GhcRn
lpat)
HsPatSynDir GhcRn
Unidirectional -> String
-> Either
SDoc (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 Origin
Generated ([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 -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n))
| L SrcSpanAnnN
loc Name
n <- [LIdP GhcRn]
[LocatedN 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 -> LocatedN Name)
-> [RecordPatSynField GhcRn] -> [LocatedN Name]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField GhcRn -> LIdP GhcRn
RecordPatSynField GhcRn -> LocatedN 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
, Kind -> Kind
tcFunResultTy Kind
builder_ty )
else (HsExpr GhcTc
builder_expr, Kind
builder_ty)
| Bool
otherwise
= 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 = (() :: Constraint) => Kind -> Kind -> Kind
Kind -> Kind -> Kind
mkVisFunTyMany Kind
unboxedUnitTy Kind
ty
| Bool
otherwise = Kind
ty
tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
-> Either SDoc (LHsExpr GhcRn)
tcPatToExpr :: Name
-> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
name [LocatedN Name]
args LPat GhcRn
pat = LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go LPat GhcRn
pat
where
lhsVars :: NameSet
lhsVars = [Name] -> NameSet
mkNameSet ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LocatedN Name]
args)
mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
-> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr lcon :: LocatedN Name
lcon@(L SrcSpanAnnN
loc Name
_) [LPat GhcRn]
pats
= do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either SDoc [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 SDoc (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (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
LocatedN Name
lcon)
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc 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 SDoc (HsExpr GhcRn)
mkRecordConExpr :: LocatedN Name
-> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn)
mkRecordConExpr LocatedN 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
SDoc
(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
SDoc
[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 SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))
-> Either
SDoc
(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 SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc 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)
LocatedN 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 SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
go' :: LHsRecField GhcRn (LPat GhcRn)
-> Either SDoc (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
SDoc
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Either
SDoc
(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 SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))
-> Either
SDoc
(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 SDoc (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))
rf
go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go :: LPat GhcRn -> Either SDoc (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 SDoc (HsExpr GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 Pat GhcRn
p
go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 :: Pat GhcRn -> Either SDoc (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 -> LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr XRec GhcRn (ConLikeP GhcRn)
LocatedN Name
con [LPat GhcRn]
ps
InfixCon LPat GhcRn
l LPat GhcRn
r -> LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr XRec GhcRn (ConLikeP GhcRn)
LocatedN Name
con [LPat GhcRn
l,LPat GhcRn
r]
RecCon HsRecFields GhcRn (LPat GhcRn)
fields -> LocatedN Name
-> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn)
mkRecordConExpr XRec GhcRn (ConLikeP GhcRn)
LocatedN Name
con HsRecFields GhcRn (LPat GhcRn)
fields
go1 (SigPat XSigPat GhcRn
_ LPat GhcRn
pat HsPatSigType (NoGhcTc GhcRn)
_) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)
go1 (VarPat XVarPat GhcRn
_ (L SrcSpanAnnN
l Name
var))
| Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
lhsVars
= HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (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 -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
var)
| Bool
otherwise
= SDoc -> Either SDoc (HsExpr GhcRn)
forall a b. a -> Either a b
Left (SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
var) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is not bound by the LHS of the pattern synonym")
go1 (ParPat XParPat GhcRn
_ LHsToken "(" GhcRn
lpar LPat GhcRn
pat LHsToken ")" GhcRn
rpar) = (LHsExpr GhcRn -> HsExpr GhcRn)
-> Either SDoc (LHsExpr GhcRn) -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> Either SDoc a -> Either SDoc 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 SDoc (LHsExpr GhcRn) -> Either SDoc (HsExpr GhcRn))
-> Either SDoc (LHsExpr GhcRn) -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go LPat GhcRn
pat
go1 (ListPat XListPat GhcRn
_ [LPat GhcRn]
pats)
= do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either SDoc [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 SDoc (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (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 SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either SDoc [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 SDoc (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (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 SDoc (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 SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (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 SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (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 SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (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 SDoc (HsExpr GhcRn)
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (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 SDoc (HsExpr GhcRn)
go1 Pat GhcRn
pat
go1 (SplicePat (HsUntypedSpliceNested Name
_) HsUntypedSplice GhcRn
_) = String -> Either SDoc (HsExpr GhcRn)
forall a. HasCallStack => String -> a
panic String
"tcPatToExpr: invalid nested splice"
go1 (XPat (HsPatExpanded Pat GhcRn
_ Pat GhcRn
pat))= Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 Pat GhcRn
pat
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 SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
Just HsExpr GhcRn
inverse ->
(HsExpr GhcRn -> HsExpr GhcRn)
-> Either SDoc (HsExpr GhcRn) -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> Either SDoc a -> Either SDoc 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 SDoc (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat))
go1 p :: Pat GhcRn
p@(BangPat {}) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(LazyPat {}) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(WildPat {}) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(AsPat {}) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(NPlusKPat {}) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
notInvertible :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p = SDoc -> Either SDoc (HsExpr GhcRn)
forall a b. a -> Either a b
Left (Pat GhcRn -> SDoc
not_invertible_msg Pat GhcRn
p)
not_invertible_msg :: Pat GhcRn -> SDoc
not_invertible_msg Pat GhcRn
p
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Pattern" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Pat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
p) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is not invertible"
SDoc -> SDoc -> SDoc
$+$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Suggestion: instead use an explicitly bidirectional"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pattern synonym, e.g.")
Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pattern" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
larrow
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"where")
Int
2 (SDoc
pp_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"..."))
where
pp_name :: SDoc
pp_name = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
pp_args :: SDoc
pp_args = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((LocatedN Name -> SDoc) -> [LocatedN Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocatedN Name]
args)
tcCollectEx
:: LPat GhcTc
-> ( [TyVar]
, [EvVar] )
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 = ([], [])