{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.TyCl.PatSyn
( tcPatSynDecl
, tcPatSynBuilderBind
, patSynBuilderOcc
)
where
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Gen.Pat
import GHC.Core.Multiplicity
import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )
import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv
, addInlinePrags, addInlinePragArity )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Zonk
import GHC.Builtin.Types.Prim
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Core.PatSyn
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Var
import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet )
import GHC.Types.Id
import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType )
import GHC.Tc.Gen.Bind
import GHC.Types.Basic
import GHC.Tc.Solver
import GHC.Tc.Utils.Unify
import GHC.Core.Predicate
import GHC.Builtin.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build
import GHC.Types.Var.Set
import GHC.Types.Id.Make
import GHC.Tc.TyCl.Utils
import GHC.Core.ConLike
import GHC.Types.FieldLabel
import GHC.Rename.Env
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 )
#include "HsVersions.h"
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 (String -> SDoc
text String
"In the declaration for pattern synonym"
SDoc -> SDoc -> SDoc
<+> 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. 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.
HsMatchContext GhcRn
-> LPat GhcRn -> TcM a -> TcM ((LPat GhcTc, a), Kind)
tcInferPat 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
, [SDoc] -> SDoc
sep [ String -> SDoc
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 SDoc -> SDoc -> 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
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
tcTypeKind Kind
ty1
k2 :: Kind
k2 = HasDebugCallStack => Kind -> Kind
tcTypeKind 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. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Iceland Jack! Iceland Jack! Stop torturing me!"
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern-bound variable")
Int
2 (forall a. Outputable a => a -> SDoc
ppr Id
arg SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> 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 (String -> SDoc
text String
"has a type that mentions pattern-bound coercion"
SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [Id]
bad_co_list SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 (forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [Id]
bad_co_list)
, String -> SDoc
text String
"Hint: use -fprint-explicit-coercions to see the coercions"
, String -> SDoc
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
$
[SDoc] -> SDoc
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 -> SDoc -> TcRn ()
checkTc (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bad_tvs) forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"The result type of the signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<> SDoc
comma
, String -> SDoc
text String
"namely" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Kind
pat_ty) ])
Int
2 (String -> SDoc
text String
"mentions existential type variable" SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [Id]
bad_tvs
SDoc -> SDoc -> SDoc
<+> 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
; (TCvSubst
skol_subst0, [VarBndr Id Specificity]
skol_univ_bndrs) <- forall flag.
TCvSubst -> [VarBndr Id flag] -> TcM (TCvSubst, [VarBndr Id flag])
skolemiseTvBndrsX TCvSubst
emptyTCvSubst [VarBndr Id Specificity]
univ_bndrs
; (TCvSubst
skol_subst, [VarBndr Id Specificity]
skol_ex_bndrs) <- forall flag.
TCvSubst -> [VarBndr Id flag] -> TcM (TCvSubst, [VarBndr Id flag])
skolemiseTvBndrsX TCvSubst
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 = HasCallStack => TCvSubst -> [Kind] -> [Kind]
substTheta TCvSubst
skol_subst0 [Kind]
req_theta
skol_prov_theta :: [Kind]
skol_prov_theta = HasCallStack => TCvSubst -> [Kind] -> [Kind]
substTheta TCvSubst
skol_subst [Kind]
prov_theta
skol_arg_tys :: [Kind]
skol_arg_tys = HasCallStack => TCvSubst -> [Kind] -> [Kind]
substTys TCvSubst
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 = HasCallStack => TCvSubst -> Kind -> Kind
substTy TCvSubst
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'))) <-
ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
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 GhcRn
-> 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 = VarSet -> InScopeSet
mkInScopeSet ([Id] -> VarSet
mkVarSet [Id]
skol_univ_tvs)
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
; (TCvSubst
inst_subst, [Id]
ex_tvs') <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> Id -> TcM (TCvSubst, Id)
newMetaTyVarX TCvSubst
empty_subst [Id]
skol_ex_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn1" ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> 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
vcat [ forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs'])
; let prov_theta' :: [Kind]
prov_theta' = HasCallStack => TCvSubst -> [Kind] -> [Kind]
substTheta TCvSubst
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 (TCvSubst -> Name -> Kind -> TcM (LHsExpr GhcTc)
tc_arg TCvSubst
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') }
; let skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> Kind -> [(Name, Id)] -> SkolemInfo
SigSkol (Name -> UserTypeCtxt
PatSynCtxt Name
name) Kind
pat_ty []
; (Bag Implication
implics, TcEvBinds
ev_binds) <- TcLevel
-> SkolemInfo
-> [Id]
-> [Id]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tclvl 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 :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
tc_arg :: TCvSubst -> Name -> Kind -> TcM (LHsExpr GhcTc)
tc_arg TCvSubst
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)
(HasCallStack => TCvSubst -> Kind -> Kind
substTy TCvSubst
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 :: TCvSubst -> [VarBndr TyVar flag]
-> TcM (TCvSubst, [VarBndr TcTyVar flag])
skolemiseTvBndrsX :: forall flag.
TCvSubst -> [VarBndr Id flag] -> TcM (TCvSubst, [VarBndr Id flag])
skolemiseTvBndrsX TCvSubst
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 = TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
pushed_lvl Bool
False
mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag
-> (TCvSubst, VarBndr TcTyVar flag)
mk_skol_tv_x :: forall flag.
TCvSubst -> VarBndr Id flag -> (TCvSubst, VarBndr Id flag)
mk_skol_tv_x TCvSubst
subst (Bndr Id
tv flag
flag)
= (TCvSubst
subst', forall var argf. var -> argf -> VarBndr var argf
Bndr Id
new_tv flag
flag)
where
new_kind :: Kind
new_kind = TCvSubst -> Kind -> Kind
substTyUnchecked TCvSubst
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' :: TCvSubst
subst' = TCvSubst -> Id -> Id -> TCvSubst
extendTvSubstWithClone TCvSubst
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.
TCvSubst -> VarBndr Id flag -> (TCvSubst, VarBndr Id flag)
mk_skol_tv_x TCvSubst
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. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"has")
SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
speakNOf Int
decl_arity (String -> SDoc
text String
"argument"))
Int
2 (String -> SDoc
text String
"but its type signature has" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
missing SDoc -> SDoc -> SDoc
<+> String -> SDoc
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], [TcType])
-> 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])
tidyTyCoVarBinders TidyEnv
emptyTidyEnv [VarBndr Id Specificity]
univ_tvs'
(TidyEnv
env2, [VarBndr Id Specificity]
ex_tvs) = forall vis.
TidyEnv -> [VarBndr Id vis] -> (TidyEnv, [VarBndr Id vis])
tidyTyCoVarBinders 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) SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (forall l e. GenLocated l e -> e
unLoc LPat GhcTc
lpat') SDoc -> SDoc -> 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 a. Outputable a => a -> SDoc
ppr ([VarBndr Id Specificity]
ex_tvs, [Kind]
prov_theta, [EvTerm]
prov_dicts) SDoc -> SDoc -> SDoc
$$
forall a. Outputable a => a -> SDoc
ppr [LHsExpr GhcTc]
args SDoc -> SDoc -> SDoc
$$
forall a. Outputable a => a -> SDoc
ppr [Kind]
arg_tys SDoc -> SDoc -> 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
(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 }" SDoc
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 (String -> OccName
mkTyVarOcc String
"rep") SrcSpan
loc'
; Name
tv_name <- OccName -> SrcSpan -> TcM Name
newNameAt (String -> OccName
mkTyVarOcc 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
tYPE 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 = ([forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Id
voidPrimId], [Kind
unboxedUnitTy])
| Bool
otherwise = ([LHsExpr GhcTc]
args, [Kind]
arg_tys)
cont_ty :: Kind
cont_ty = [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 = 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
Many Kind
pat_ty
; Id
cont <- forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"cont") Kind
Many Kind
cont_ty
; Id
fail <- forall gbl lcl. FastString -> Kind -> Kind -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"fail") Kind
Many 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 = [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
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 [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Id
voidPrimId]
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)))) ~ SrcSpan,
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)))) ~ SrcSpan,
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)))) ~ SrcSpan,
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 -> MatchGroupTc
MatchGroupTc [forall a. a -> Scaled a
unrestricted Kind
pat_ty] Kind
res_ty
, mg_origin :: Origin
mg_origin = 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)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (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 -> 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
, mg_origin :: Origin
mg_origin = Origin
Generated
}
match :: LMatch GhcTc (LHsExpr GhcTc)
match = forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
ps_name)) []
([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 -> MatchGroupTc
MatchGroupTc [] Kind
res_ty
, mg_origin :: Origin
mg_origin = 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
, fun_tick :: [CoreTickish]
fun_tick = [] }
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 SDoc -> SDoc -> SDoc
$$ 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
$
[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. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Invalid right-hand side of bidirectional pattern synonym"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
ps_name) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 SDoc
why
, String -> SDoc
text String
"RHS pattern:" SDoc -> SDoc -> SDoc
<+> 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 pat_ty :: Kind
pat_ty = PatSyn -> Kind
patSynResultType PatSyn
patsyn
builder_id :: Id
builder_id = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> Kind -> IdInfo
`setLevityInfoWithType` Kind
pat_ty) forall a b. (a -> b) -> a -> b
$
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
, fun_tick :: [CoreTickish]
fun_tick = [] }
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
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr PatSyn
patsyn
, forall a. Outputable a => a -> SDoc
ppr Id
builder_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> 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 (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. 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 (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP 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 = forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
noExtField (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 = 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 (Located Int)
dd)
= do { [GenLocated
SrcSpanAnnA
(HsRecField'
(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 (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
exprFields Maybe (Located Int)
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 HsRecField' (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 HsRecField' (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 [HsPatSigType (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) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not bound by the LHS of the pattern synonym")
go1 (ParPat XParPat GhcRn
_ LPat GhcRn
pat) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn) forall a b. (a -> b) -> a -> b
$ LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go LPat GhcRn
pat
go1 p :: Pat GhcRn
p@(ListPat XListPat GhcRn
reb [LPat GhcRn]
pats)
| Maybe SyntaxExprRn
XListPat GhcRn
Nothing <- XListPat GhcRn
reb = 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 }
| Bool
otherwise = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertibleListPat Pat GhcRn
p
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 EpAnnCO
noComments HsLit GhcRn
lit
go1 (NPat XNPat GhcRn
_ (L SrcSpan
_ 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 XSplicePat GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
_ (HsSplicedPat Pat GhcRn
pat)))
= Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 Pat GhcRn
pat
go1 (SplicePat XSplicePat GhcRn
_ (HsSpliced{})) = forall a. String -> a
panic String
"Invalid splice variety"
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@(ViewPat {}) = 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
go1 p :: Pat GhcRn
p@(SplicePat XSplicePat GhcRn
_ (HsTypedSplice {})) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(SplicePat XSplicePat GhcRn
_ (HsUntypedSplice {})) = Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(SplicePat XSplicePat GhcRn
_ (HsQuasiQuote {})) = 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
= String -> SDoc
text String
"Pattern" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
p) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not invertible"
SDoc -> SDoc -> SDoc
$+$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Suggestion: instead use an explicitly bidirectional"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"pattern synonym, e.g.")
Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"pattern" SDoc -> SDoc -> SDoc
<+> SDoc
pp_name SDoc -> SDoc -> SDoc
<+> SDoc
pp_args SDoc -> SDoc -> SDoc
<+> SDoc
larrow
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
pat SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"where")
Int
2 (SDoc
pp_name SDoc -> SDoc -> SDoc
<+> SDoc
pp_args SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"..."))
where
pp_name :: SDoc
pp_name = forall a. Outputable a => a -> SDoc
ppr Name
name
pp_args :: SDoc
pp_args = [SDoc] -> SDoc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LocatedN Name]
args)
notInvertibleListPat :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertibleListPat Pat GhcRn
p
= forall a b. a -> Either a b
Left ([SDoc] -> SDoc
vcat [ Pat GhcRn -> SDoc
not_invertible_msg Pat GhcRn
p
, String -> SDoc
text String
"Reason: rebindable syntax is on."
, String -> SDoc
text String
"This is fixable: add use-case to #14380" ])
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
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (ParPat XParPat GhcTc
_ LPat GhcTc
p) = 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 (CoPat HsWrapper
_ Pat GhcTc
p Kind
_)) = 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 SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr XRec GhcTc (HsOverLit GhcTc)
k SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
geq SDoc -> SDoc -> SDoc
$$ 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 [HsPatSigType (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
_ HsRecField{ hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = 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 = ([], [])