{-# 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
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall doc. IsLine doc => String -> doc
text String
"In the declaration for pattern synonym"
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name)) forall a b. (a -> b) -> a -> b
$
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
recoverPSB PatSynBind GhcRn GhcRn
psb) 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
_ -> 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 <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkMatcherOcc
; let placeholder :: TyThing
placeholder = ConLike -> TyThing
AConLike forall a b. (a -> b) -> a -> b
$ PatSyn -> ConLike
PatSynCon forall a b. (a -> b) -> a -> b
$
Name -> PatSyn
mk_placeholder Name
matcher_name
; TcGblEnv
gbl_env <- forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
placeholder] forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (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
([forall vis. vis -> Id -> VarBndr Id vis
mkTyVarBinder Specificity
SpecifiedSpec Id
alphaTyVar], []) ([], [])
[]
Kind
alphaTy
(Name
matcher_name, Kind
matcher_ty, Bool
True) 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 {" forall a b. (a -> b) -> a -> b
$ 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))
<- forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints forall a b. (a -> b) -> a -> b
$
forall a.
FixedRuntimeRepContext
-> HsMatchContext GhcTc
-> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTc, a), Kind)
tcInferPat FixedRuntimeRepContext
FRRPatSynArg forall p. HsMatchContext p
PatSyn LPat GhcRn
lpat forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TcM Id
tcLookupId [Name]
arg_names
; let ([Id]
ex_tvs, [Id]
prov_dicts) = LPat GhcTc -> ([Id], [Id])
tcCollectEx GenLocated SrcSpanAnnA (Pat GhcTc)
lpat'
named_taus :: [(Name, Kind)]
named_taus = (Name
name, Kind
pat_ty) forall a. a -> [a] -> [a]
: 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
= (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)
<- forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints 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 <- forall r. TcM r -> TcM r
checkNoErrs (WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
residual)
; forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
top_ev_binds forall a b. (a -> b) -> a -> b
$
do { [Id]
prov_dicts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> TcM Id
zonkId [Id]
prov_dicts
; let filtered_prov_dicts :: [Id]
filtered_prov_dicts = forall a. (a -> Kind) -> [a] -> [a]
mkMinimalBySCs Id -> Kind
evVarPred [Id]
prov_dicts
([Kind]
prov_theta, [EvTerm]
prov_evs)
= forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Id -> Maybe (Kind, EvTerm)
mkProvEvidence [Id]
filtered_prov_dicts)
req_theta :: [Kind]
req_theta = forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
evVarPred [Id]
req_dicts
; [Id]
args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> TcM Id
zonkId [Id]
args
; let bad_args :: [(Id, DVarSet)]
bad_args = [ (Id
arg, DVarSet
bad_cos) | Id
arg <- [Id]
args forall a. [a] -> [a] -> [a]
++ [Id]
prov_dicts
, let bad_cos :: DVarSet
bad_cos = (Id -> Bool) -> DVarSet -> DVarSet
filterDVarSet Id -> Bool
isId forall a b. (a -> b) -> a -> b
$
(Kind -> DVarSet
tyCoVarsOfTypeDSet (Id -> Kind
idType Id
arg))
, Bool -> Bool
not (DVarSet -> Bool
isEmptyDVarSet DVarSet
bad_cos) ]
; 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
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, forall doc. IsLine doc => [doc] -> doc
sep [ 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 }" forall a b. (a -> b) -> a -> b
$ (forall a. Outputable a => a -> SDoc
ppr Name
name forall doc. IsDoc doc => doc -> doc -> doc
$$ 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
lname HsPatSynDir GhcRn
dir Bool
is_infix GenLocated SrcSpanAnnA (Pat GhcTc)
lpat' TcPragEnv
prag_fn
(forall vis. vis -> [Id] -> [VarBndr Id vis]
mkTyVarBinders Specificity
InferredSpec [Id]
univ_tvs
, [Kind]
req_theta, TcEvBinds
ev_binds, [Id]
req_dicts)
(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)
(forall a b. (a -> b) -> [a] -> [b]
map forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar [Id]
args, 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 = HasDebugCallStack => Kind -> Kind
typeKind Kind
ty1
k2 :: Kind
k2 = HasDebugCallStack => Kind -> Kind
typeKind Kind
ty2
is_homo :: Bool
is_homo = Kind
k1 HasDebugCallStack => 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
-> 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 -> forall a. Maybe a
Nothing
EqRel
NomEq | Bool
is_homo
-> 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
-> 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
= 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)
= forall a. TcRnMessage -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"Iceland Jack! Iceland Jack! Stop torturing me!"
, SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Pattern-bound variable")
Int
2 (forall a. Outputable a => a -> SDoc
ppr Id
arg forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
arg))
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"has a type that mentions pattern-bound coercion"
forall doc. IsLine doc => doc -> doc -> doc
<> forall a. [a] -> SDoc
plural [Id]
bad_co_list forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon)
Int
2 (forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [Id]
bad_co_list)
, forall doc. IsLine doc => String -> doc
text String
"Hint: use -fprint-explicit-coercions to see the coercions"
, 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" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
implicit_bndrs, forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
explicit_univ_bndrs, forall a. Outputable a => a -> SDoc
ppr [Kind]
req_theta
, forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
explicit_ex_bndrs, forall a. Outputable a => a -> SDoc
ppr [Kind]
prov_theta, forall a. Outputable a => a -> SDoc
ppr Kind
sig_body_ty ]
; let decl_arity :: Int
decl_arity = 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Scaled Kind], Kind)
stuff
Left Int
missing -> forall a. Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
name Int
decl_arity Int
missing
; let bad_tvs :: [Id]
bad_tvs = forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` Kind -> VarSet
tyCoVarsOfType Kind
pat_ty) forall a b. (a -> b) -> a -> b
$ forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
explicit_ex_bndrs
; Bool -> TcRnMessage -> TcRn ()
checkTc (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bad_tvs) forall a b. (a -> b) -> a -> b
$ forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => [doc] -> doc
sep [ forall doc. IsLine doc => String -> doc
text String
"The result type of the signature for" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma
, forall doc. IsLine doc => String -> doc
text String
"namely" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Kind
pat_ty) ])
Int
2 (forall doc. IsLine doc => String -> doc
text String
"mentions existential type variable" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. [a] -> SDoc
plural [Id]
bad_tvs
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => [a] -> SDoc
pprQuotedList [Id]
bad_tvs)
; let univ_fvs :: VarSet
univ_fvs = VarSet -> VarSet
closeOverKinds forall a b. (a -> b) -> a -> b
$
([Kind] -> VarSet
tyCoVarsOfTypes (Kind
pat_ty forall a. a -> [a] -> [a]
: [Kind]
req_theta) VarSet -> [Id] -> VarSet
`extendVarSetList` (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
explicit_univ_bndrs))
([VarBndr Id Specificity]
extra_univ, [VarBndr Id Specificity]
extra_ex) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Id -> VarSet -> Bool
`elemVarSet` VarSet
univ_fvs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. [a] -> [a] -> [a]
++ [VarBndr Id Specificity]
explicit_univ_bndrs
ex_bndrs :: [VarBndr Id Specificity]
ex_bndrs = [VarBndr Id Specificity]
extra_ex forall a. [a] -> [a] -> [a]
++ [VarBndr Id Specificity]
explicit_ex_bndrs
univ_tvs :: [Id]
univ_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
univ_bndrs
ex_tvs :: [Id]
ex_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
ex_bndrs
; Bool -> TcRnMessage -> TcRn ()
checkTc (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Kind -> Bool
isManyTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Scaled a -> Kind
scaledMult) [Scaled Kind]
arg_tys) forall a b. (a -> b) -> a -> b
$
Kind -> TcRnMessage
TcRnLinearPatSyn Kind
sig_body_ty
; SkolemInfo
skol_info <- 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) <- 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) <- 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 = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
skol_univ_bndrs
skol_ex_tvs :: [Id]
skol_ex_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
skol_ex_bndrs
skol_req_theta :: [Kind]
skol_req_theta = HasDebugCallStack => Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst0 [Kind]
req_theta
skol_prov_theta :: [Kind]
skol_prov_theta = HasDebugCallStack => Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst [Kind]
prov_theta
skol_arg_tys :: [Kind]
skol_arg_tys = HasDebugCallStack => Subst -> [Kind] -> [Kind]
substTys Subst
skol_subst (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Kind]
arg_tys)
skol_pat_ty :: Kind
skol_pat_ty = HasDebugCallStack => Subst -> Kind -> Kind
substTy Subst
skol_subst Kind
pat_ty
univ_tv_prs :: [(Name, Id)]
univ_tv_prs = [ (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 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'))) <-
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall a b. [a] -> [b] -> Bool
equalLength [Name]
arg_names [Scaled Kind]
arg_tys) (forall a. Outputable a => a -> SDoc
ppr Name
name forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [Name]
arg_names forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [Scaled Kind]
arg_tys) forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints forall a b. (a -> b) -> a -> b
$
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, Id)]
univ_tv_prs forall a b. (a -> b) -> a -> b
$
forall a.
HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Kind -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat forall p. HsMatchContext p
PatSyn LPat GhcRn
lpat (forall a. a -> Scaled a
unrestricted Kind
skol_pat_ty) 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') <- 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 -> TcM (Subst, Id)
newMetaTyVarX Subst
empty_subst [Id]
skol_ex_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn1" (forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr Id
v forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs])
; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn2" (forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr Id
v forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs'])
; let prov_theta' :: [Kind]
prov_theta' = HasDebugCallStack => Subst -> [Kind] -> [Kind]
substTheta Subst
inst_subst [Kind]
skol_prov_theta
; [EvTerm]
prov_dicts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CtOrigin -> Kind -> TcM EvTerm
emitWanted (PatSynBind GhcRn GhcRn -> CtOrigin
ProvCtxtOrigin PatSynBind GhcRn GhcRn
psb)) [Kind]
prov_theta'
; [LocatedA (HsExpr GhcTc)]
args' <- 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
; 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 }" forall a b. (a -> b) -> a -> b
$ 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
lname HsPatSynDir GhcRn
dir Bool
is_infix 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)
([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
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
arg_name) forall a b. (a -> b) -> a -> b
$
do { Id
arg_id <- Name -> TcM Id
tcLookupId Name
arg_name
; HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> Kind -> Kind -> TcM HsWrapper
tcSubTypeSigma (Name -> CtOrigin
OccurrenceOf (Id -> Name
idName Id
arg_id))
UserTypeCtxt
GenSigCtxt
(Id -> Kind
idType Id
arg_id)
(HasDebugCallStack => Subst -> Kind -> Kind
substTy Subst
subst Kind
arg_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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', 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
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL 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 -> (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
names, Bool
False)
InfixCon LIdP GhcRn
name1 LIdP GhcRn
name2 -> (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn
name1, LIdP GhcRn
name2], Bool
True)
RecCon [RecordPatSynField GhcRn]
names -> (forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
= forall a. TcRnMessage -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$ forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Pattern synonym" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"has"
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc -> SDoc
speakNOf Int
decl_arity (forall doc. IsLine doc => String -> doc
text String
"argument"))
Int
2 (forall doc. IsLine doc => String -> doc
text String
"but its type signature has" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Int -> doc
int Int
missing forall doc. IsLine doc => doc -> doc -> doc
<+> 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') <- 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') <- 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) = 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) = 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 {" forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr (forall l e. GenLocated l e -> e
unLoc LocatedN Name
lname) forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr (forall l e. GenLocated l e -> e
unLoc LPat GhcTc
lpat') forall doc. IsDoc doc => doc -> doc -> doc
$$
forall a. Outputable a => a -> SDoc
ppr ([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts) forall doc. IsDoc doc => doc -> doc -> doc
$$
forall a. Outputable a => a -> SDoc
ppr ([VarBndr Id Specificity]
ex_tvs, [Kind]
prov_theta, [EvTerm]
prov_dicts) forall doc. IsDoc doc => doc -> doc -> doc
$$
forall a. Outputable a => a -> SDoc
ppr [LHsExpr GhcTc]
args forall doc. IsDoc doc => doc -> doc -> doc
$$
forall a. Outputable a => a -> SDoc
ppr [Kind]
arg_tys forall doc. IsDoc doc => doc -> doc -> doc
$$
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
(forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
(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 <- 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 (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
tything] 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 }" forall doc. IsOutput doc => doc
empty
; 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' = forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc
; Name
rr_name <- OccName -> SrcSpan -> TcM Name
newNameAt (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"rep")) SrcSpan
loc'
; Name
tv_name <- OccName -> SrcSpan -> TcM 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 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsExpr GhcTc]
args Bool -> Bool -> 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]
args, [Kind]
arg_tys)
cont_ty :: Kind
cont_ty = HasDebugCallStack => [Id] -> [Kind] -> Kind -> Kind
mkInfSigmaTy [Id]
ex_tvs [Kind]
prov_theta forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkVisFunTysMany [Kind]
cont_arg_tys Kind
res_ty
fail_ty :: Kind
fail_ty = HasDebugCallStack => Kind -> Kind -> Kind
mkVisFunTyMany Kind
unboxedUnitTy Kind
res_ty
; Name
matcher_name <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
ps_name OccName -> OccName
mkMatcherOcc
; Id
scrutinee <- forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"scrut") Kind
ManyTy Kind
pat_ty
; Id
cont <- forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"cont") Kind
ManyTy Kind
cont_ty
; Id
fail <- forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"fail") Kind
ManyTy Kind
fail_ty
; DynFlags
dflags <- 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 = HasDebugCallStack => [Id] -> [Kind] -> Kind -> Kind
mkInfSigmaTy (Id
rr_tvforall a. a -> [a] -> [a]
:Id
res_tvforall 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' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
inst_wrap (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Id
cont)) [LocatedA (HsExpr GhcTc)]
cont_args
fail' :: LHsExpr GhcTc
fail' = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps Id
fail [DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
unboxedUnitDataCon]
args :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
args = forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XWildPat p -> Pat p
WildPat Kind
pat_ty
cases :: [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
cases = if forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat DynFlags
dflags LPat GhcTc
lpat
then [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 [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',
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 GenLocated SrcSpanAnnA (Pat GhcTc)
lwpat LHsExpr GhcTc
fail']
body :: LHsExpr GhcTc
body = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
req_ev_binds) forall a b. (a -> b) -> a -> b
$
forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc LPat GhcTc
lpat) forall a b. (a -> b) -> a -> b
$
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase NoExtField
noExtField (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Id
scrutinee) forall a b. (a -> b) -> a -> b
$
MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> l
getLoc LPat 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 [forall a. a -> Scaled a
unrestricted Kind
pat_ty] Kind
res_ty Origin
Generated
}
body' :: LocatedA (HsExpr GhcTc)
body' = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = forall a an. a -> LocatedAn an a
noLocA [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 forall p. HsMatchContext p
LambdaExpr
[GenLocated SrcSpanAnnA (Pat GhcTc)]
args LHsExpr GhcTc
body]
, mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = [Scaled Kind] -> Kind -> Origin -> MatchGroupTc
MatchGroupTc (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (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_tvforall a. a -> [a] -> [a]
:Id
res_tvforall a. a -> [a] -> [a]
:[Id]
univ_tvs)
[Id]
req_dicts LocatedA (HsExpr GhcTc)
body')
(forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds 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 = forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> l
getLoc LMatch GhcTc (LHsExpr GhcTc)
match) [LMatch GhcTc (LHsExpr 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
req_theta forall a. Num a => a -> a -> a
+ Int
3
; Id
matcher_prag_id <- Id -> [LSig GhcRn] -> TcM Id
addInlinePrags Id
matcher_id forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (Int -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Int
matcher_arity) 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 = 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 = forall a. a -> Bag a
unitBag (forall a an. a -> LocatedAn an a
noLocA HsBindLR GhcTc GhcTc
bind)
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynMatcher" (forall a. Outputable a => a -> SDoc
ppr Name
ps_name forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
matcher_id))
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynMatcher" (forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind)
; 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
| forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir a
dir
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
otherwise
= do { Name
builder_name <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkBuilderOcc
; let theta :: [Kind]
theta = [Kind]
req_theta forall a. [a] -> [a] -> [a]
++ [Kind]
prov_theta
need_dummy_arg :: Bool
need_dummy_arg = HasDebugCallStack => Kind -> Bool
isUnliftedType Kind
pat_ty Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
arg_tys Bool -> Bool -> 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 forall a b. (a -> b) -> a -> b
$
[VarBndr Id Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr Id Specificity]
univ_bndrs forall a b. (a -> b) -> a -> b
$
[VarBndr Id Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr Id Specificity]
ex_bndrs forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => [Kind] -> Kind -> Kind
mkPhiTy [Kind]
theta forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkVisFunTysMany [Kind]
arg_tys forall a b. (a -> b) -> a -> b
$
Kind
pat_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (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 })
| forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir GhcRn
dir
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Bag a
emptyBag
| Left SDoc
why <- Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LPat GhcRn
lpat) forall a b. (a -> b) -> a -> b
$ forall a. TcRnMessage -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$ forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Invalid right-hand side of bidirectional pattern synonym"
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
ps_name) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon)
Int
2 SDoc
why
, forall doc. IsLine doc => String -> doc
text String
"RHS pattern:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LPat 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
req_theta forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
prov_theta
forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Kind]
arg_tys
forall a. Num a => a -> a -> a
+ (if Bool
need_dummy_arg then Int
1 else Int
0)
; Id
builder_id <- Id -> [LSig GhcRn] -> TcM Id
addInlinePrags Id
builder_id forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (Int -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Int
builder_arity) 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 (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group
| Bool
otherwise = MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group
bind :: HsBindLR GhcRn GhcRn
bind = FunBind { fun_id :: LIdP GhcRn
fun_id = 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 = NameSet
emptyNameSet
}
sig :: TcIdSigInfo
sig = UserTypeCtxt -> Id -> TcIdSigInfo
completeSigFromId (Name -> UserTypeCtxt
PatSynCtxt Name
ps_name) Id
builder_id
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind {" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr PatSyn
patsyn
, forall a. Outputable a => a -> SDoc
ppr Id
builder_id forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> 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 (forall a an. a -> LocatedAn an a
noLocA HsBindLR GhcRn GhcRn
bind)
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind }" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder_binds
; 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 -> forall a b. b -> Either a b
Right MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg
HsPatSynDir GhcRn
ImplicitBidirectional -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg (Name
-> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
ps_name [LIdP GhcRn]
args LPat GhcRn
lpat)
HsPatSynDir GhcRn
Unidirectional -> 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 = 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 (forall a an. a -> LocatedAn an a
noLocA [LMatch GhcRn (LHsExpr GhcRn)
builder_match])
where
builder_args :: [GenLocated SrcSpanAnnA (Pat GhcRn)]
builder_args = [forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnnN
loc) (forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n))
| L SrcSpanAnnN
loc Name
n <- [LIdP GhcRn]
args]
builder_match :: LMatch GhcRn (LHsExpr GhcRn)
builder_match = forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LIdP GhcRn
ps_lname)
[GenLocated SrcSpanAnnA (Pat GhcRn)]
builder_args LHsExpr GhcRn
body
(forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds 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 -> forall a b. (a -> b) -> [a] -> [b]
map 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 :: XRec GhcRn [LMatch GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
mg_alts = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match { m_pats :: [LPat GhcRn]
m_pats = LPat GhcRn
nlWildPatName forall a. a -> [a] -> [a]
: [LPat GhcRn]
pats })] }
add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
other_mg = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"add_dummy_arg" forall a b. (a -> b) -> a -> b
$
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr 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)
= forall a. a -> Maybe a
Just 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
= forall a. Maybe a
Nothing
add_void :: Bool -> Type -> Type
add_void :: Bool -> Kind -> Kind
add_void Bool
need_dummy_arg Kind
ty
| Bool
need_dummy_arg = HasDebugCallStack => Kind -> Kind -> Kind
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 (forall a b. (a -> b) -> [a] -> [b]
map 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [LPat GhcRn]
pats
; let con :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
con = forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
loc) (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField LocatedN Name
lcon)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps GenLocated SrcSpanAnnA (HsExpr GhcRn)
con [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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcRn (LPat GhcRn)
-> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
go' [LHsRecField GhcRn (LPat GhcRn)]
fields
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XRecordCon p -> XRec p (ConLikeP p) -> HsRecordBinds p -> HsExpr p
RecordCon NoExtField
noExtField LocatedN Name
con (forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields [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) = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LPat GhcRn -> Either SDoc (LHsExpr 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) = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc 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 NoExtField
XConPat GhcRn
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)
con [LPat GhcRn]
ps
InfixCon LPat GhcRn
l LPat GhcRn
r -> LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr XRec GhcRn (ConLikeP GhcRn)
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)
con HsRecFields GhcRn (LPat GhcRn)
fields
go1 (SigPat XSigPat GhcRn
_ LPat GhcRn
pat HsPatSigType (NoGhcTc GhcRn)
_) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 (forall l e. GenLocated l e -> e
unLoc LPat GhcRn
pat)
go1 (VarPat XVarPat GhcRn
_ (L SrcSpanAnnN
l Name
var))
| Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
lhsVars
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
var)
| Bool
otherwise
= forall a b. a -> Either a b
Left (SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
var) forall doc. IsLine doc => doc -> doc -> doc
<+> 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) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\LHsExpr GhcRn
e -> forall p.
XPar p -> LHsToken "(" p -> LHsExpr p -> LHsToken ")" p -> HsExpr p
HsPar forall a. EpAnn a
noAnn LHsToken "(" GhcRn
lpar LHsExpr GhcRn
e LHsToken ")" GhcRn
rpar) 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [LPat GhcRn]
pats
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList NoExtField
noExtField [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs }
go1 (TuplePat XTuplePat GhcRn
_ [LPat GhcRn]
pats Boxity
box) = do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [LPat GhcRn]
pats
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
noExtField
(forall a b. (a -> b) -> [a] -> [b]
map (forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present 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 (forall l e. GenLocated l e -> e
unLoc LPat GhcRn
pat)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum NoExtField
noExtField Int
alt Int
arity
(forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
expr)
}
go1 (LitPat XLitPat GhcRn
_ HsLit GhcRn
lit) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XLitE p -> HsLit p -> HsExpr p
HsLit 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
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
neg)
[forall a an. a -> LocatedAn an a
noLocA (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit forall a. EpAnn a
noAnn HsOverLit GhcRn
n)]
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit 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
_) = 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 ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\ HsExpr GhcRn
expr -> forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn (forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
inverse) (forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
expr))
(Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 (forall l e. GenLocated l e -> e
unLoc LPat 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 = 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
= forall doc. IsLine doc => String -> doc
text String
"Pattern" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
p) forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"is not invertible"
SDoc -> SDoc -> SDoc
$+$ SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Suggestion: instead use an explicitly bidirectional"
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"pattern synonym, e.g.")
Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"pattern" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_name forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_args forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
larrow
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
pat forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"where")
Int
2 (SDoc
pp_name forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_args forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc
equals forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"..."))
where
pp_name :: SDoc
pp_name = forall a. Outputable a => a -> SDoc
ppr Name
name
pp_args :: SDoc
pp_args = forall doc. IsLine doc => [doc] -> doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
go forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
go1 (TuplePat XTuplePat GhcTc
_ [LPat GhcTc]
ps Boxity
_) = forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
go 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' }
= forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge (ConPatTc -> [Id]
cpt_tvs XConPat GhcTc
con', ConPatTc -> [Id]
cpt_dicts XConPat GhcTc
con') forall a b. (a -> b) -> a -> b
$
HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails forall a b. (a -> b) -> a -> b
$ 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)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"TODO: NPlusKPat" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
n forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr XRec GhcTc (HsOverLit GhcTc)
k forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
geq forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
subtract
go1 Pat GhcTc
_ = forall {a} {a}. ([a], [a])
empty
goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
goConDetails :: HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)]
_ [LPat GhcTc]
ps) = forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
go 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 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 })
= forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
goRecFd 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 GenLocated SrcSpanAnnA (Pat GhcTc)
p
merge :: ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge ([a]
vs1, [a]
evs1) ([a]
vs2, [a]
evs2) = ([a]
vs1 forall a. [a] -> [a] -> [a]
++ [a]
vs2, [a]
evs1 forall a. [a] -> [a] -> [a]
++ [a]
evs2)
mergeMany :: [([a], [a])] -> ([a], [a])
mergeMany = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge forall {a} {a}. ([a], [a])
empty
empty :: ([a], [a])
empty = ([], [])