{-# 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.Zonk.Type
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Zonk.TcType
import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv
, addInlinePrags, addInlinePragArity )
import GHC.Tc.Solver
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build
import GHC.Core.Multiplicity
import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp )
import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Core.Predicate
import GHC.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.Utils.Misc
import GHC.Driver.DynFlags ( getDynFlags, xopt_FieldSelectors )
import qualified GHC.LanguageExtensions as LangExt
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
import Data.List( partition, mapAccumL )
import Data.List.NonEmpty (NonEmpty, nonEmpty)
tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)
-> TcSigFun
-> TcPragEnv
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)
-> TcSigFun -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl (L SrcSpanAnnA
loc psb :: PatSynBind GhcRn GhcRn
psb@(PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ Name
name })) TcSigFun
sig_fn TcPragEnv
prag_fn
= SrcSpanAnnA
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
SDoc
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the declaration for pattern synonym"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)) (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
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 TcPatSynSig
patsig) -> PatSynBind GhcRn GhcRn
-> TcPatSynSig -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl PatSynBind GhcRn GhcRn
psb TcPatSynSig
patsig TcPragEnv
prag_fn
Maybe TcSigInfo
_ -> String
-> TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], TcGblEnv)
forall a. HasCallStack => String -> a
panic String
"tcPatSynDecl"
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPragEnv
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = lname :: LIdP GhcRn
lname@(L SrcSpanAnnN
_ Name
name), psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details
, psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir })
TcPragEnv
prag_fn
= do { String -> SDoc -> TcRn ()
traceTc String
"tcInferPatSynDecl {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
; let ([Name]
arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
; (tclvl, wanted, ((lpat', args), pat_ty))
<- TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)
-> TcM
(TcLevel, WantedConstraints,
((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)
-> TcM
(TcLevel, WantedConstraints,
((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind)
-> TcM
(TcLevel, WantedConstraints,
((GenLocated SrcSpanAnnA (Pat GhcTc), [Id]), Kind))
forall a b. (a -> b) -> a -> b
$
FixedRuntimeRepContext
-> HsMatchContextRn
-> LPat GhcRn
-> TcM [Id]
-> TcM ((LPat GhcTc, [Id]), Kind)
forall a.
FixedRuntimeRepContext
-> HsMatchContextRn
-> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTc, a), Kind)
tcInferPat FixedRuntimeRepContext
FRRPatSynArg HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
PatSyn LPat GhcRn
lpat (TcM [Id] -> TcM ((LPat GhcTc, [Id]), Kind))
-> TcM [Id] -> TcM ((LPat GhcTc, [Id]), Kind)
forall a b. (a -> b) -> a -> b
$
(Name -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Name] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId [Name]
arg_names
; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
named_taus = (Name
name, Kind
pat_ty) (Name, Kind) -> [(Name, Kind)] -> [(Name, Kind)]
forall a. a -> [a] -> [a]
: (Id -> (Name, Kind)) -> [Id] -> [(Name, Kind)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> (Name, Kind)
mk_named_tau [Id]
args
mk_named_tau Id
arg
= (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
arg, [Id] -> Kind -> Kind
mkSpecForAllTys [Id]
ex_tvs (Id -> Kind
varType Id
arg))
; ((univ_tvs, req_dicts, ev_binds, _), residual)
<- captureConstraints $
simplifyInfer TopLevel tclvl NoRestrictions [] named_taus wanted
; top_ev_binds <- checkNoErrs (simplifyTop residual)
; addTopEvBinds top_ev_binds $
do { prov_dicts <- liftZonkM $ mapM zonkId prov_dicts
; let filtered_prov_dicts = (Id -> Kind) -> [Id] -> [Id]
forall a. (a -> Kind) -> [a] -> [a]
mkMinimalBySCs Id -> Kind
evVarPred [Id]
prov_dicts
(prov_theta, prov_evs)
= unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
req_theta = (Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
evVarPred [Id]
req_dicts
; args <- liftZonkM $ mapM zonkId args
; let bad_arg Id
arg = (NonEmpty Id -> (Id, NonEmpty Id))
-> Maybe (NonEmpty Id) -> Maybe (Id, NonEmpty Id)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NonEmpty Id
bad_cos -> (Id
arg, NonEmpty Id
bad_cos)) (Maybe (NonEmpty Id) -> Maybe (Id, NonEmpty Id))
-> Maybe (NonEmpty Id) -> Maybe (Id, NonEmpty Id)
forall a b. (a -> b) -> a -> b
$
[Id] -> Maybe (NonEmpty Id)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Id] -> Maybe (NonEmpty Id)) -> [Id] -> Maybe (NonEmpty Id)
forall a b. (a -> b) -> a -> b
$
DVarSet -> [Id]
dVarSetElems (DVarSet -> [Id]) -> DVarSet -> [Id]
forall a b. (a -> b) -> a -> b
$
(Id -> Bool) -> DVarSet -> DVarSet
filterDVarSet Id -> Bool
isId (Kind -> DVarSet
tyCoVarsOfTypeDSet (Id -> Kind
idType Id
arg))
bad_args = (Id -> Maybe (Id, NonEmpty Id)) -> [Id] -> [(Id, NonEmpty Id)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Id -> Maybe (Id, NonEmpty Id)
bad_arg ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
prov_dicts)
; mapM_ dependentArgErr bad_args
; dvs <- candidateQTyVarsOfTypes prov_theta
; let err_ctx TidyEnv
tidy_env
= do { (tidy_env2, theta) <- TidyEnv -> [Kind] -> ZonkM (TidyEnv, [Kind])
zonkTidyTcTypes TidyEnv
tidy_env [Kind]
prov_theta
; return ( tidy_env2, UninfTyCtx_ProvidedContext theta ) }
; doNotQuantifyTyVars dvs err_ctx
; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
; rec_fields <- lookupConstructorFields name
; tc_patsyn_finish lname dir is_infix lpat' prag_fn
(mkTyVarBinders InferredSpec univ_tvs
, req_theta, ev_binds, req_dicts)
(mkTyVarBinders InferredSpec ex_tvs
, mkTyVarTys ex_tvs, prov_theta, prov_evs)
(map nlHsVar args, map idType args)
pat_ty 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
Kind -> Kind
typeKind Kind
ty1
k2 :: Kind
k2 = HasDebugCallStack => Kind -> Kind
Kind -> Kind
typeKind Kind
ty2
is_homo :: Bool
is_homo = Kind
k1 HasDebugCallStack => Kind -> Kind -> Bool
Kind -> Kind -> Bool
`tcEqType` Kind
k2
homo_tys :: [Kind]
homo_tys = [Kind
k1, Kind
ty1, Kind
ty2]
hetero_tys :: [Kind]
hetero_tys = [Kind
k1, Kind
k2, Kind
ty1, Kind
ty2]
= case EqRel
r of
EqRel
ReprEq | Bool
is_homo
-> (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just ( Class -> [Kind] -> Kind
mkClassPred Class
coercibleClass [Kind]
homo_tys
, DataCon -> [Kind] -> [EvExpr] -> EvTerm
evDataConApp DataCon
coercibleDataCon [Kind]
homo_tys [EvExpr]
eq_con_args )
| Bool
otherwise -> Maybe (Kind, EvTerm)
forall a. Maybe a
Nothing
EqRel
NomEq | Bool
is_homo
-> (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just ( Class -> [Kind] -> Kind
mkClassPred Class
eqClass [Kind]
homo_tys
, DataCon -> [Kind] -> [EvExpr] -> EvTerm
evDataConApp DataCon
eqDataCon [Kind]
homo_tys [EvExpr]
eq_con_args )
| Bool
otherwise
-> (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just ( Class -> [Kind] -> Kind
mkClassPred Class
heqClass [Kind]
hetero_tys
, DataCon -> [Kind] -> [EvExpr] -> EvTerm
evDataConApp DataCon
heqDataCon [Kind]
hetero_tys [EvExpr]
eq_con_args )
| Bool
otherwise
= (Kind, EvTerm) -> Maybe (Kind, EvTerm)
forall a. a -> Maybe a
Just (Kind
pred, EvExpr -> EvTerm
EvExpr (Id -> EvExpr
evId Id
ev_id))
where
pred :: Kind
pred = Id -> Kind
evVarPred Id
ev_id
eq_con_args :: [EvExpr]
eq_con_args = [Id -> EvExpr
evId Id
ev_id]
dependentArgErr :: (Id, NonEmpty CoVar) -> TcM ()
dependentArgErr :: (Id, NonEmpty Id) -> TcRn ()
dependentArgErr (Id
arg, NonEmpty Id
bad_cos)
= TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Id -> NonEmpty Id -> TcRnMessage
TcRnPatSynEscapedCoercion Id
arg NonEmpty Id
bad_cos
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPatSynSig
-> TcPragEnv
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPatSynSig -> 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 }
PatSig{ patsig_implicit_bndrs :: TcPatSynSig -> [VarBndr Id Specificity]
patsig_implicit_bndrs = [VarBndr Id Specificity]
implicit_bndrs
, patsig_univ_bndrs :: TcPatSynSig -> [VarBndr Id Specificity]
patsig_univ_bndrs = [VarBndr Id Specificity]
explicit_univ_bndrs, patsig_req :: TcPatSynSig -> [Kind]
patsig_req = [Kind]
req_theta
, patsig_ex_bndrs :: TcPatSynSig -> [VarBndr Id Specificity]
patsig_ex_bndrs = [VarBndr Id Specificity]
explicit_ex_bndrs, patsig_prov :: TcPatSynSig -> [Kind]
patsig_prov = [Kind]
prov_theta
, patsig_body_ty :: TcPatSynSig -> Kind
patsig_body_ty = Kind
sig_body_ty }
TcPragEnv
prag_fn
= do { String -> SDoc -> TcRn ()
traceTc String
"tcCheckPatSynDecl" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [VarBndr Id Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
implicit_bndrs, [VarBndr Id Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
explicit_univ_bndrs, [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
req_theta
, [VarBndr Id Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr Id Specificity]
explicit_ex_bndrs, [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
prov_theta, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
sig_body_ty ]
; let decl_arity :: Int
decl_arity = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
arg_names
([Name]
arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
; (arg_tys, pat_ty) <- case Int -> Kind -> Either Int ([Scaled Kind], Kind)
tcSplitFunTysN Int
decl_arity Kind
sig_body_ty of
Right ([Scaled Kind], Kind)
stuff -> ([Scaled Kind], Kind)
-> IOEnv (Env TcGblEnv TcLclEnv) ([Scaled Kind], Kind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Scaled Kind], Kind)
stuff
Left Int
missing -> Name
-> Int
-> Int
-> IOEnv (Env TcGblEnv TcLclEnv) ([Scaled Kind], Kind)
forall a. Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
name Int
decl_arity Int
missing
; let bad_tvs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` Kind -> VarSet
tyCoVarsOfType Kind
pat_ty) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
explicit_ex_bndrs
; checkTc (null bad_tvs) $ TcRnPatSynExistentialInResult name pat_ty bad_tvs
; let univ_fvs = VarSet -> VarSet
closeOverKinds (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
([Kind] -> VarSet
tyCoVarsOfTypes (Kind
pat_ty Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [Kind]
req_theta) VarSet -> [Id] -> VarSet
`extendVarSetList` ([VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
explicit_univ_bndrs))
(extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_bndrs
univ_bndrs = [VarBndr Id Specificity]
extra_univ [VarBndr Id Specificity]
-> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr Id Specificity]
explicit_univ_bndrs
ex_bndrs = [VarBndr Id Specificity]
extra_ex [VarBndr Id Specificity]
-> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr Id Specificity]
explicit_ex_bndrs
univ_tvs = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
univ_bndrs
ex_tvs = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
ex_bndrs
; checkTc (all (isManyTy . scaledMult) arg_tys) $
TcRnLinearPatSyn sig_body_ty
; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty [])
; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptySubst univ_bndrs
; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_info skol_subst0 ex_bndrs
; let skol_univ_tvs = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
skol_univ_bndrs
skol_ex_tvs = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Id Specificity]
skol_ex_bndrs
skol_req_theta = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst0 [Kind]
req_theta
skol_prov_theta = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
skol_subst [Kind]
prov_theta
skol_arg_tys = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTys Subst
skol_subst ((Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing [Scaled Kind]
arg_tys)
skol_pat_ty = HasDebugCallStack => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
skol_subst Kind
pat_ty
univ_tv_prs = [ (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
orig_univ_tv, Id
skol_univ_tv)
| (Id
orig_univ_tv, Id
skol_univ_tv) <- [Id]
univ_tvs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
skol_univ_tvs ]
; req_dicts <- newEvVars skol_req_theta
; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $
pushLevelAndCaptureConstraints $
tcExtendNameTyVarEnv univ_tv_prs $
tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $
do { let in_scope = [Id] -> InScopeSet
mkInScopeSetList [Id]
skol_univ_tvs
empty_subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs
; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
; let prov_theta' = HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
inst_subst [Kind]
skol_prov_theta
; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
; args' <- zipWithM (tc_arg inst_subst) arg_names
skol_arg_tys
; return (ex_tvs', prov_dicts, args') }
; (implics, ev_binds) <- buildImplicationFor tclvl (getSkolemInfo skol_info) skol_univ_tvs
req_dicts wanted
; simplifyTopImplic implics
; traceTc "tcCheckPatSynDecl }" $ ppr name
; rec_fields <- lookupConstructorFields name
; tc_patsyn_finish lname dir is_infix lpat' prag_fn
(skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)
(skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)
(args', skol_arg_tys)
skol_pat_ty rec_fields }
where
tc_arg :: Subst -> Name -> Type -> TcM (LHsExpr GhcTc)
tc_arg :: Subst -> Name -> Kind -> TcM (LHsExpr GhcTc)
tc_arg Subst
subst Name
arg_name Kind
arg_ty
= SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
arg_name) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { arg_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId Name
arg_name
; wrap <- tcSubTypeSigma (OccurrenceOf (idName arg_id))
GenSigCtxt
(idType arg_id)
(substTy subst arg_ty)
; return (mkLHsWrap wrap $ nlHsVar 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 { tc_lvl <- TcM TcLevel
getTcLevel
; let pushed_lvl = TcLevel -> TcLevel
pushTcLevel TcLevel
tc_lvl
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 Subst
subst (Bndr Id
tv flag
flag)
= (Subst
subst', Id -> flag -> VarBndr Id flag
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
new_tv flag
flag)
where
new_kind :: Kind
new_kind = Subst -> Kind -> Kind
substTyUnchecked Subst
subst (Id -> Kind
tyVarKind Id
tv)
new_tv :: Id
new_tv = Name -> Kind -> TcTyVarDetails -> Id
mkTcTyVar (Id -> Name
tyVarName Id
tv) Kind
new_kind TcTyVarDetails
details
subst' :: Subst
subst' = Subst -> Id -> Id -> Subst
extendTvSubstWithClone Subst
subst Id
tv Id
new_tv
; return (mapAccumL mk_skol_tv_x orig_subst 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 -> ((GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
names, Bool
False)
InfixCon LIdP GhcRn
name1 LIdP GhcRn
name2 -> ((GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn
GenLocated SrcSpanAnnN Name
name1, LIdP GhcRn
GenLocated SrcSpanAnnN Name
name2], Bool
True)
RecCon [RecordPatSynField GhcRn]
names -> ((RecordPatSynField GhcRn -> Name)
-> [RecordPatSynField GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name)
-> RecordPatSynField GhcRn
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField GhcRn -> LIdP GhcRn
RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar) [RecordPatSynField GhcRn]
names, Bool
False)
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr :: forall a. Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
name Int
decl_arity Int
missing
= TcRnMessage -> TcM a
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM a) -> TcRnMessage -> TcM a
forall a b. (a -> b) -> a -> b
$ Name -> Int -> Int -> TcRnMessage
TcRnPatSynArityMismatch Name
name Int
decl_arity Int
missing
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 :: GenLocated SrcSpanAnnN Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> TcPragEnv
-> ([VarBndr Id Specificity], [Kind], TcEvBinds, [Id])
-> ([VarBndr Id Specificity], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish GenLocated SrcSpanAnnN Name
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
lpat' TcPragEnv
prag_fn
([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
([VarBndr Id Specificity]
ex_tvs, [Kind]
ex_tys, [Kind]
prov_theta, [EvTerm]
prov_dicts)
([LHsExpr GhcTc]
args, [Kind]
arg_tys)
Kind
pat_ty [FieldLabel]
field_labels
= do {
(univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <-
ZonkFlexi
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind)
forall (m :: * -> *) b. MonadIO m => ZonkFlexi -> ZonkT m b -> m b
initZonkEnv ZonkFlexi
NoFlexi (ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind)
forall a b. (a -> b) -> a -> b
$
ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Id Specificity]
-> forall r.
([VarBndr Id Specificity]
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([VarBndr Id Specificity]
-> ZonkBndrT
(IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Id Specificity]
forall vis. [VarBndr Id vis] -> ZonkBndrTcM [VarBndr Id vis]
zonkTyVarBindersX [VarBndr Id Specificity]
univ_tvs) (([VarBndr Id Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind))
-> ([VarBndr Id Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Kind], Kind)
forall a b. (a -> b) -> a -> b
$ \ [VarBndr Id Specificity]
univ_tvs' ->
do { req_theta' <- [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX [Kind]
req_theta
; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ [VarBndr Id Specificity]
ex_tvs' ->
do { prov_theta' <- [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX [Kind]
prov_theta
; pat_ty' <- zonkTcTypeToTypeX pat_ty
; arg_tys' <- zonkTcTypesToTypesX arg_tys
; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs'
(env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs'
req_theta = TidyEnv -> [Kind] -> [Kind]
tidyTypes TidyEnv
env2 [Kind]
req_theta'
prov_theta = TidyEnv -> [Kind] -> [Kind]
tidyTypes TidyEnv
env2 [Kind]
prov_theta'
arg_tys = TidyEnv -> [Kind] -> [Kind]
tidyTypes TidyEnv
env2 [Kind]
arg_tys'
pat_ty = TidyEnv -> Kind -> Kind
tidyType TidyEnv
env2 Kind
pat_ty'
; return (univ_tvs, req_theta,
ex_tvs, prov_theta, arg_tys, pat_ty) } }
; traceTc "tc_patsyn_finish {" $
ppr (unLoc lname) $$ ppr (unLoc lpat') $$
ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
ppr (ex_tvs, prov_theta, prov_dicts) $$
ppr args $$
ppr arg_tys $$
ppr pat_ty
; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn
(binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
(binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys)
pat_ty
; builder <- mkPatSynBuilder dir lname
univ_tvs req_theta
ex_tvs prov_theta
arg_tys pat_ty
; let patSyn = Name
-> Bool
-> ([VarBndr Id Specificity], [Kind])
-> ([VarBndr Id Specificity], [Kind])
-> [Kind]
-> Kind
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
lname) Bool
is_infix
([VarBndr Id Specificity]
univ_tvs, [Kind]
req_theta)
([VarBndr Id Specificity]
ex_tvs, [Kind]
prov_theta)
[Kind]
arg_tys
Kind
pat_ty
PatSynMatcher
matcher PatSynBuilder
builder
[FieldLabel]
field_labels
; has_sel <- xopt_FieldSelectors <$> getDynFlags
; let rn_rec_sel_binds = PatSyn -> [FieldLabel] -> FieldSelectors -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
patSyn (PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
patSyn) FieldSelectors
has_sel
tything = ConLike -> TyThing
AConLike (PatSyn -> ConLike
PatSynCon PatSyn
patSyn)
; tcg_env <- tcExtendGlobalEnv [tything] $
tcRecSelBinds rn_rec_sel_binds
; traceTc "tc_patsyn_finish }" empty
; return (matcher_bind, 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 :: GenLocated SrcSpanAnnN Name
-> LPat GhcTc
-> TcPragEnv
-> ([Id], [Kind], TcEvBinds, [Id])
-> ([Id], [Kind], [Kind], [EvTerm])
-> ([LHsExpr GhcTc], [Kind])
-> Kind
-> TcM (PatSynMatcher, LHsBinds GhcTc)
tcPatSynMatcher (L SrcSpanAnnN
loc Name
ps_name) LPat GhcTc
lpat TcPragEnv
prag_fn
([Id]
univ_tvs, [Kind]
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
([Id]
ex_tvs, [Kind]
ex_tys, [Kind]
prov_theta, [EvTerm]
prov_dicts)
([LHsExpr GhcTc]
args, [Kind]
arg_tys) Kind
pat_ty
= do { let loc' :: SrcSpan
loc' = SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc
; rr_name <- OccName -> SrcSpan -> TcM Name
newNameAt (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"rep")) SrcSpan
loc'
; tv_name <- newNameAt (mkTyVarOccFS (fsLit "r")) loc'
; let rr_tv = Name -> Kind -> Id
mkTyVar Name
rr_name Kind
runtimeRepTy
rr = Id -> Kind
mkTyVarTy Id
rr_tv
res_tv = Name -> Kind -> Id
mkTyVar Name
tv_name (Kind -> Kind
mkTYPEapp Kind
rr)
res_ty = Id -> Kind
mkTyVarTy Id
res_tv
is_unlifted = [LocatedA (HsExpr GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
args Bool -> Bool -> Bool
&& [EvTerm] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvTerm]
prov_dicts
(cont_args, cont_arg_tys)
| is_unlifted = ([nlHsDataCon unboxedUnitDataCon], [unboxedUnitTy])
| otherwise = (args, arg_tys)
cont_ty = [Id] -> [Kind] -> Kind -> Kind
HasDebugCallStack => [Id] -> [Kind] -> Kind -> Kind
mkInfSigmaTy [Id]
ex_tvs [Kind]
prov_theta (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkVisFunTysMany [Kind]
cont_arg_tys Kind
res_ty
fail_ty = HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
mkVisFunTyMany Kind
unboxedUnitTy Kind
res_ty
; matcher_name <- newImplicitBinder ps_name mkMatcherOcc
; scrutinee <- newSysLocalId (fsLit "scrut") ManyTy pat_ty
; cont <- newSysLocalId (fsLit "cont") ManyTy cont_ty
; fail <- newSysLocalId (fsLit "fail") ManyTy fail_ty
; is_strict <- xoptM LangExt.Strict
; comps <- getCompleteMatchesTcM
; let matcher_tau = [Kind] -> Kind -> Kind
mkVisFunTysMany [Kind
pat_ty, Kind
cont_ty, Kind
fail_ty] Kind
res_ty
matcher_sigma = [Id] -> [Kind] -> Kind -> Kind
HasDebugCallStack => [Id] -> [Kind] -> Kind -> Kind
mkInfSigmaTy (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs) [Kind]
req_theta Kind
matcher_tau
matcher_id = Name -> Kind -> Id
mkExportedVanillaId Name
matcher_name Kind
matcher_sigma
patsyn_id = Name -> Kind -> Id
mkExportedVanillaId Name
ps_name Kind
matcher_sigma
inst_wrap = [EvTerm] -> HsWrapper
mkWpEvApps [EvTerm]
prov_dicts HsWrapper -> HsWrapper -> HsWrapper
<.> [Kind] -> HsWrapper
mkWpTyApps [Kind]
ex_tys
cont' = (LocatedA (HsExpr GhcTc)
-> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> [LocatedA (HsExpr GhcTc)]
-> LocatedA (HsExpr GhcTc)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
-> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
inst_wrap (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Id
cont)) [LocatedA (HsExpr GhcTc)]
cont_args
fail' = IdP GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcTc
Id
fail [DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
unboxedUnitDataCon]
args = [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ([GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcTc)])
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> a -> b
$ (Id -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map IdP GhcTc -> LPat GhcTc
Id -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id
scrutinee, Id
cont, Id
fail]
lwpat = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcTc
Kind
pat_ty
cases = if Bool -> (ConLikeP GhcTc -> Bool) -> LPat GhcTc -> Bool
forall (p :: Pass).
IsPass p =>
Bool -> (ConLikeP (GhcPass p) -> Bool) -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat Bool
is_strict (CompleteMatches -> ConLike -> Bool
forall con.
NamedThing con =>
[CompleteMatchX con] -> ConLike -> Bool
irrefutableConLikeTc CompleteMatches
comps) LPat GhcTc
lpat
then [LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnnCO,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat LocatedA (HsExpr GhcTc)
cont']
else [LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnnCO,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat LocatedA (HsExpr GhcTc)
cont',
LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnnCO,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lwpat LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
fail']
gen = GenReason -> DoPmc -> Origin
Generated GenReason
OtherExpansion DoPmc
SkipPmc
body = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
req_ev_binds) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat) (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcTc
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
PatSyn (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Id
scrutinee) (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = SrcSpanAnnLW
-> [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnLW
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l (SrcSpanAnnA -> SrcSpanAnnLW) -> SrcSpanAnnA -> SrcSpanAnnLW
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat) [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))]
cases
, mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = [Scaled Kind] -> Kind -> Origin -> MatchGroupTc
MatchGroupTc [Kind -> Scaled Kind
forall a. a -> Scaled a
unrestricted Kind
pat_ty] Kind
res_ty Origin
gen
}
body' = HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
XLam GhcTc
-> HsLamVariant -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p.
XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
forall a. NoAnn a => a
noAnn HsLamVariant
LamSingle (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
-> GenLocated
(Anno
[GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))])
[LMatch GhcTc (LocatedA (HsExpr GhcTc))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [HsMatchContext (LIdP (NoGhcTc GhcTc))
-> LocatedE [LPat GhcTc]
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnnCO) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (HsLamVariant
-> HsMatchContext
(GenLocated
(Anno (IdGhcP (NoGhcTcPass 'Typechecked)))
(IdGhcP (NoGhcTcPass 'Typechecked)))
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
LamSingle)
LocatedE [LPat GhcTc]
GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcTc)]
args
LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
body]
, mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = [Scaled Kind] -> Kind -> Origin -> MatchGroupTc
MatchGroupTc ((Kind -> Scaled Kind) -> [Kind] -> [Scaled Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Scaled Kind
forall a. a -> Scaled a
unrestricted [Kind
pat_ty, Kind
cont_ty, Kind
fail_ty]) Kind
res_ty Origin
gen
}
match = HsMatchContext (LIdP (NoGhcTc GhcTc))
-> LocatedE [LPat GhcTc]
-> LHsExpr GhcTc
-> HsLocalBinds GhcTc
-> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass).
IsPass p =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (GenLocated SrcSpanAnnN Name
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (Id -> Name
idName Id
patsyn_id)) AnnFunRhs
forall a. NoAnn a => a
noAnn) ([GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [])
([Id] -> [Id] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs)
[Id]
req_dicts LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
body')
(XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
NoExtField
noExtField)
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg = MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = Anno
[GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
(Anno
[GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))])
[GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA
-> Anno
[GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))]
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l (SrcSpanAnnA
-> Anno
[GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))])
-> SrcSpanAnnA
-> Anno
[GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))]
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))
-> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LMatch GhcTc (LHsExpr GhcTc)
GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (HsExpr GhcTc)))
match) [LMatch GhcTc (LHsExpr GhcTc)
GenLocated
(Anno (Match GhcTc (LocatedA (HsExpr GhcTc))))
(Match GhcTc (LocatedA (HsExpr GhcTc)))
match]
, mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = [Scaled Kind] -> Kind -> Origin -> MatchGroupTc
MatchGroupTc [] Kind
res_ty Origin
gen
}
matcher_arity = [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
req_theta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
; matcher_prag_id <- addInlinePrags matcher_id $
map (addInlinePragArity matcher_arity) $
lookupPragEnv prag_fn ps_name
; let bind = FunBind{ fun_id :: LIdP GhcTc
fun_id = SrcSpanAnnN -> Id -> GenLocated SrcSpanAnnN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Id
matcher_prag_id
, fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
mg
, fun_ext :: XFunBind GhcTc GhcTc
fun_ext = (HsWrapper
idHsWrapper, [])
}
matcher_bind = [HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsBindLR GhcTc GhcTc
bind]
; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id))
; traceTc "tcPatSynMatcher" (ppr matcher_bind)
; return ((matcher_name, matcher_sigma, is_unlifted), 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
-> GenLocated SrcSpanAnnN Name
-> [VarBndr Id Specificity]
-> [Kind]
-> [VarBndr Id Specificity]
-> [Kind]
-> [Kind]
-> Kind
-> TcM PatSynBuilder
mkPatSynBuilder HsPatSynDir a
dir (L SrcSpanAnnN
_ Name
name)
[VarBndr Id Specificity]
univ_bndrs [Kind]
req_theta [VarBndr Id Specificity]
ex_bndrs [Kind]
prov_theta
[Kind]
arg_tys Kind
pat_ty
| HsPatSynDir a -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir a
dir
= PatSynBuilder -> TcM PatSynBuilder
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return PatSynBuilder
forall a. Maybe a
Nothing
| Bool
otherwise
= do { builder_name <- Name -> (OccName -> OccName) -> TcM Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkBuilderOcc
; let theta = [Kind]
req_theta [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
prov_theta
need_dummy_arg = HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
pat_ty Bool -> Bool -> Bool
&& [Kind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
arg_tys Bool -> Bool -> Bool
&& [Kind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
theta
builder_sigma = Bool -> Kind -> Kind
add_void Bool
need_dummy_arg (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[VarBndr Id Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr Id Specificity]
univ_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[VarBndr Id Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr Id Specificity]
ex_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
HasDebugCallStack => [Kind] -> Kind -> Kind
mkPhiTy [Kind]
theta (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkVisFunTysMany [Kind]
arg_tys (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
Kind
pat_ty
; return (Just (builder_name, builder_sigma, need_dummy_arg)) }
tcPatSynBuilderBind :: TcPragEnv
-> PatSynBind GhcRn GhcRn
-> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind TcPragEnv
prag_fn (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = ps_lname :: LIdP GhcRn
ps_lname@(L SrcSpanAnnN
loc Name
ps_name)
, psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat
, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir
, psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details })
| HsPatSynDir GhcRn -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir GhcRn
dir
= [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Left PatSynInvalidRhsReason
why <- Either
PatSynInvalidRhsReason
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= SrcSpan -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (Pat GhcRn) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
lpat) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcM (LHsBinds GhcTc)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (LHsBinds GhcTc))
-> TcRnMessage -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ Name
-> LPat GhcRn
-> [LIdP GhcRn]
-> PatSynInvalidRhsReason
-> TcRnMessage
TcRnPatSynInvalidRhs Name
ps_name LPat GhcRn
lpat [LIdP GhcRn]
args PatSynInvalidRhsReason
why
| Right MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group <- Either
PatSynInvalidRhsReason
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= do { patsyn <- Name -> TcM PatSyn
tcLookupPatSyn Name
ps_name
; case patSynBuilder patsyn of {
PatSynBuilder
Nothing -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [] ;
Just (Name
builder_name, Kind
builder_ty, Bool
need_dummy_arg) ->
do {
let builder_id :: Id
builder_id = Name -> Kind -> Id
mkExportedVanillaId Name
builder_name Kind
builder_ty
([VarBndr Id Specificity]
_, [Kind]
req_theta, [VarBndr Id Specificity]
_, [Kind]
prov_theta, [Scaled Kind]
arg_tys, Kind
_) = PatSyn
-> ([VarBndr Id Specificity], [Kind], [VarBndr Id Specificity],
[Kind], [Scaled Kind], Kind)
patSynSigBndr PatSyn
patsyn
builder_arity :: Int
builder_arity = [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
req_theta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
prov_theta
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Scaled Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Kind]
arg_tys
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
need_dummy_arg then Int
1 else Int
0)
; builder_id <- Id -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
addInlinePrags Id
builder_id ([LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a b. (a -> b) -> a -> b
$
(LSig GhcRn -> LSig GhcRn) -> [LSig GhcRn] -> [LSig GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Int
builder_arity) ([LSig GhcRn] -> [LSig GhcRn]) -> [LSig GhcRn] -> [LSig GhcRn]
forall a b. (a -> b) -> a -> b
$
TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
ps_name
; let match_group' | Bool
need_dummy_arg = MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group
| Bool
otherwise = MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group
bind = FunBind { fun_id :: LIdP GhcRn
fun_id = SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (Id -> Name
idName Id
builder_id)
, fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
match_group'
, fun_ext :: XFunBind GhcRn GhcRn
fun_ext = XFunBind GhcRn GhcRn
NameSet
emptyNameSet
}
sig = UserTypeCtxt -> Id -> TcCompleteSig
completeSigFromId (Name -> UserTypeCtxt
PatSynCtxt Name
ps_name) Id
builder_id
; traceTc "tcPatSynBuilderBind {" $
vcat [ ppr patsyn
, ppr builder_id <+> dcolon <+> ppr (idType builder_id) ]
; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind)
; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
; return builder_binds } } }
where
mb_match_group :: Either
PatSynInvalidRhsReason
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= case HsPatSynDir GhcRn
dir of
ExplicitBidirectional MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg -> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either
PatSynInvalidRhsReason
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b. b -> Either a b
Right MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
explicit_mg
HsPatSynDir GhcRn
ImplicitBidirectional -> (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either
PatSynInvalidRhsReason
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b.
(a -> b)
-> Either PatSynInvalidRhsReason a
-> Either PatSynInvalidRhsReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
mk_mg ([GenLocated SrcSpanAnnN Name]
-> LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
tcPatToExpr [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
args LPat GhcRn
lpat)
HsPatSynDir GhcRn
Unidirectional -> String
-> Either
PatSynInvalidRhsReason
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a. HasCallStack => String -> a
panic String
"tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg LHsExpr GhcRn
body = Origin
-> LocatedLW
[LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedLW
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup (GenReason -> DoPmc -> Origin
Generated GenReason
OtherExpansion DoPmc
SkipPmc) ([LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> LocatedLW
[LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LMatch GhcRn (LHsExpr GhcRn)
LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
builder_match])
where
builder_args :: GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcRn)]
builder_args = [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcRn)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [(SrcSpanAnnA -> Pat GhcRn -> GenLocated SrcSpanAnnA (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
loc) (XVarPat GhcRn -> LIdP GhcRn -> Pat GhcRn
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcRn
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n)))
| L SrcSpanAnnN
loc Name
n <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
args]
builder_match :: LMatch GhcRn (LHsExpr GhcRn)
builder_match = HsMatchContext (LIdP (NoGhcTc GhcRn))
-> LocatedE [LPat GhcRn]
-> LHsExpr GhcRn
-> HsLocalBinds GhcRn
-> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass).
IsPass p =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (GenLocated
(Anno (IdGhcP (NoGhcTcPass 'Renamed)))
(IdGhcP (NoGhcTcPass 'Renamed))
-> AnnFunRhs
-> HsMatchContext
(GenLocated
(Anno (IdGhcP (NoGhcTcPass 'Renamed)))
(IdGhcP (NoGhcTcPass 'Renamed)))
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs LIdP GhcRn
GenLocated
(Anno (IdGhcP (NoGhcTcPass 'Renamed)))
(IdGhcP (NoGhcTcPass 'Renamed))
ps_lname AnnFunRhs
forall a. NoAnn a => a
noAnn)
LocatedE [LPat GhcRn]
GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcRn)]
builder_args LHsExpr GhcRn
body
(XEmptyLocalBinds GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
NoExtField
noExtField)
args :: [LIdP GhcRn]
args = case HsPatSynDetails GhcRn
details of
PrefixCon [Void]
_ [LIdP GhcRn]
args -> [LIdP GhcRn]
args
InfixCon LIdP GhcRn
arg1 LIdP GhcRn
arg2 -> [LIdP GhcRn
arg1, LIdP GhcRn
arg2]
RecCon [RecordPatSynField GhcRn]
args -> (RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name)
-> [RecordPatSynField GhcRn] -> [GenLocated SrcSpanAnnN Name]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField GhcRn -> LIdP GhcRn
RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar [RecordPatSynField GhcRn]
args
add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg mg :: MatchGroup GhcRn (LHsExpr GhcRn)
mg@(MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts =
(L SrcSpanAnnLW
l [L SrcSpanAnnA
loc match :: Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match@(Match { m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
lp [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats })]) })
= MatchGroup GhcRn (LHsExpr GhcRn)
mg { mg_alts = L l [L loc (match { m_pats = L lp $ nlWildPatName : pats })] }
add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
other_mg = String -> SDoc -> MatchGroup GhcRn (LHsExpr GhcRn)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"add_dummy_arg" (SDoc -> MatchGroup GhcRn (LHsExpr GhcRn))
-> SDoc -> MatchGroup GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
other_mg
patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, Kind)
patSynBuilderOcc PatSyn
ps
| Just (Name
_, Kind
builder_ty, Bool
add_void_arg) <- PatSyn -> PatSynBuilder
patSynBuilder PatSyn
ps
, let builder_expr :: HsExpr GhcTc
builder_expr = ConLike -> HsExpr GhcTc
mkConLikeTc (PatSyn -> ConLike
PatSynCon PatSyn
ps)
= (HsExpr GhcTc, Kind) -> Maybe (HsExpr GhcTc, Kind)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, Kind) -> Maybe (HsExpr GhcTc, Kind))
-> (HsExpr GhcTc, Kind) -> Maybe (HsExpr GhcTc, Kind)
forall a b. (a -> b) -> a -> b
$
if Bool
add_void_arg
then ( HsExpr GhcTc
builder_expr
, Kind -> Kind
tcFunResultTy Kind
builder_ty )
else (HsExpr GhcTc
builder_expr, Kind
builder_ty)
| Bool
otherwise
= Maybe (HsExpr GhcTc, Kind)
forall a. Maybe a
Nothing
add_void :: Bool -> Type -> Type
add_void :: Bool -> Kind -> Kind
add_void Bool
need_dummy_arg Kind
ty
| Bool
need_dummy_arg = HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
mkVisFunTyMany Kind
unboxedUnitTy Kind
ty
| Bool
otherwise = Kind
ty
tcPatToExpr :: [LocatedN Name] -> LPat GhcRn
-> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
tcPatToExpr :: [GenLocated SrcSpanAnnN Name]
-> LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
tcPatToExpr [GenLocated SrcSpanAnnN Name]
args LPat GhcRn
pat = LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go LPat GhcRn
pat
where
lhsVars :: NameSet
lhsVars = [Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpanAnnN Name]
args)
mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr :: GenLocated SrcSpanAnnN Name
-> [LPat GhcRn] -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr lcon :: GenLocated SrcSpanAnnN Name
lcon@(L SrcSpanAnnN
loc Name
_) [LPat GhcRn]
pats
= do { exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either
PatSynInvalidRhsReason [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
; let con = SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
loc) (XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField LIdP GhcRn
GenLocated SrcSpanAnnN Name
lcon)
; return (unLoc $ mkHsApps con exprs)
}
mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkRecordConExpr :: GenLocated SrcSpanAnnN Name
-> HsRecFields GhcRn (LPat GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkRecordConExpr GenLocated SrcSpanAnnN Name
con (HsRecFields XHsRecFields GhcRn
x [LHsRecField GhcRn (LPat GhcRn)]
fields Maybe (XRec GhcRn RecFieldsDotDot)
dd)
= do { exprFields <- (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))
-> Either
PatSynInvalidRhsReason
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))]
-> Either
PatSynInvalidRhsReason
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsRecField GhcRn (LPat GhcRn)
-> Either
PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))
-> Either
PatSynInvalidRhsReason
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))))
go' [LHsRecField GhcRn (LPat GhcRn)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))]
fields
; return (RecordCon noExtField con (HsRecFields x exprFields dd)) }
go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
go' :: LHsRecField GhcRn (LPat GhcRn)
-> Either
PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
go' (L SrcSpanAnnA
l HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))
rf) = SrcSpanAnnA
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))))
-> Either
PatSynInvalidRhsReason
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Either
PatSynInvalidRhsReason
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))
-> Either
PatSynInvalidRhsReason
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcRn)) a
-> f (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcRn)) b)
traverse LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))
rf
go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go (L SrcSpanAnnA
loc Pat GhcRn
p) = SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 Pat GhcRn
p
go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (ConPat XConPat GhcRn
NoExtField
NoExtField XRec GhcRn (ConLikeP GhcRn)
con HsConPatDetails GhcRn
info)
= case HsConPatDetails GhcRn
info of
PrefixCon [HsConPatTyArg (NoGhcTc GhcRn)]
_ [LPat GhcRn]
ps -> GenLocated SrcSpanAnnN Name
-> [LPat GhcRn] -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
con [LPat GhcRn]
ps
InfixCon LPat GhcRn
l LPat GhcRn
r -> GenLocated SrcSpanAnnN Name
-> [LPat GhcRn] -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
con [LPat GhcRn
l,LPat GhcRn
r]
RecCon HsRecFields GhcRn (LPat GhcRn)
fields -> GenLocated SrcSpanAnnN Name
-> HsRecFields GhcRn (LPat GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkRecordConExpr XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
con HsRecFields GhcRn (LPat GhcRn)
fields
go1 (SigPat XSigPat GhcRn
_ LPat GhcRn
pat HsPatSigType (NoGhcTc GhcRn)
_) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)
go1 (VarPat XVarPat GhcRn
_ (L SrcSpanAnnN
l Name
var))
| Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
lhsVars
= HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
var)
| Bool
otherwise
= PatSynInvalidRhsReason
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. a -> Either a b
Left (Name -> PatSynInvalidRhsReason
PatSynUnboundVar Name
var)
go1 (ParPat XParPat GhcRn
_ LPat GhcRn
pat) = (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b.
(a -> b)
-> Either PatSynInvalidRhsReason a
-> Either PatSynInvalidRhsReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XPar GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
NoExtField
noExtField) (LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go LPat GhcRn
pat)
go1 (ListPat XListPat GhcRn
_ [LPat GhcRn]
pats)
= do { exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either
PatSynInvalidRhsReason [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
; return $ ExplicitList noExtField exprs }
go1 (TuplePat XTuplePat GhcRn
_ [LPat GhcRn]
pats Boxity
box) = do { exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either
PatSynInvalidRhsReason [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either
PatSynInvalidRhsReason (GenLocated SrcSpanAnnA (HsExpr GhcRn))
go [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats
; return $ ExplicitTuple noExtField
(map (Present noExtField) exprs) box }
go1 (SumPat XSumPat GhcRn
_ LPat GhcRn
pat Int
alt Int
arity) = do { expr <- Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)
; return $ ExplicitSum noExtField alt arity
(noLocA expr)
}
go1 (LitPat XLitPat GhcRn
_ HsLit GhcRn
lit) = HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
NoExtField
noExtField HsLit GhcRn
lit
go1 (NPat XNPat GhcRn
_ (L EpAnnCO
_ HsOverLit GhcRn
n) Maybe (SyntaxExpr GhcRn)
mb_neg SyntaxExpr GhcRn
_)
| Just (SyntaxExprRn HsExpr GhcRn
neg) <- Maybe (SyntaxExpr GhcRn)
mb_neg
= HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsExpr GhcRn
neg)
[HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
NoExtField
noExtField HsOverLit GhcRn
n)]
| Bool
otherwise = HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
NoExtField
noExtField HsOverLit GhcRn
n
go1 (SplicePat (HsUntypedSpliceTop ThModFinalizers
_ Pat GhcRn
pat) HsUntypedSplice GhcRn
_) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 Pat GhcRn
pat
go1 (SplicePat (HsUntypedSpliceNested Name
_) HsUntypedSplice GhcRn
_) = String -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. HasCallStack => String -> a
panic String
"tcPatToExpr: invalid nested splice"
go1 (EmbTyPat XEmbTyPat GhcRn
_ HsTyPat (NoGhcTc GhcRn)
tp) = HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. a -> Either PatSynInvalidRhsReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn))
-> HsExpr GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XEmbTy GhcRn -> LHsWcType (NoGhcTc GhcRn) -> HsExpr GhcRn
forall p. XEmbTy p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsEmbTy XEmbTy GhcRn
NoExtField
noExtField (HsTyPat GhcRn -> LHsWcType GhcRn
hstp_to_hswc HsTyPat (NoGhcTc GhcRn)
HsTyPat GhcRn
tp)
where hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn
hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn
hstp_to_hswc (HsTP { hstp_ext :: forall pass. HsTyPat pass -> XHsTP pass
hstp_ext = HsTPRn { hstp_nwcs :: HsTyPatRn -> [Name]
hstp_nwcs = [Name]
wcs }, hstp_body :: forall pass. HsTyPat pass -> LHsType pass
hstp_body = LHsType GhcRn
hs_ty })
= HsWC { hswc_ext :: XHsWC GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
hswc_ext = [Name]
XHsWC GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
wcs, hswc_body :: GenLocated SrcSpanAnnA (HsType GhcRn)
hswc_body = LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ty }
go1 (InvisPat XInvisPat GhcRn
_ HsTyPat (NoGhcTc GhcRn)
_tp) = String -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a. HasCallStack => String -> a
panic String
"tcPatToExpr: invalid invisible pattern"
go1 (XPat (HsPatExpanded Pat GhcRn
_ Pat GhcRn
pat))= Pat GhcRn -> Either PatSynInvalidRhsReason (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 PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
Just HsExpr GhcRn
inverse ->
(HsExpr GhcRn -> HsExpr GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
-> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall a b.
(a -> b)
-> Either PatSynInvalidRhsReason a
-> Either PatSynInvalidRhsReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\ HsExpr GhcRn
expr -> XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
wrapGenSpan HsExpr GhcRn
inverse) (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
wrapGenSpan HsExpr GhcRn
expr))
(Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat))
go1 p :: Pat GhcRn
p@(BangPat {}) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(LazyPat {}) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(WildPat {}) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(AsPat {}) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(NPlusKPat {}) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
go1 p :: Pat GhcRn
p@(OrPat {}) = Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
forall {b}. Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p
notInvertible :: Pat GhcRn -> Either PatSynInvalidRhsReason b
notInvertible Pat GhcRn
p = PatSynInvalidRhsReason -> Either PatSynInvalidRhsReason b
forall a b. a -> Either a b
Left (Pat GhcRn -> PatSynInvalidRhsReason
PatSynNotInvertible Pat GhcRn
p)
tcCollectEx
:: LPat GhcTc
-> ( [TyVar]
, [EvVar] )
tcCollectEx :: LPat GhcTc -> ([Id], [Id])
tcCollectEx LPat GhcTc
pat = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
pat
where
go :: LPat GhcTc -> ([TyVar], [EvVar])
go :: LPat GhcTc -> ([Id], [Id])
go = Pat GhcTc -> ([Id], [Id])
go1 (Pat GhcTc -> ([Id], [Id]))
-> (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc
go1 :: Pat GhcTc -> ([TyVar], [EvVar])
go1 :: Pat GhcTc -> ([Id], [Id])
go1 (LazyPat XLazyPat GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (AsPat XAsPat GhcTc
_ LIdP GhcTc
_ 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) = [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
go1 (TuplePat XTuplePat GhcTc
_ [LPat GhcTc]
ps Boxity
_) = [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
go1 (SumPat XSumPat GhcTc
_ LPat GhcTc
p Int
_ Int
_) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 con :: Pat GhcTc
con@ConPat{ pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = XConPat GhcTc
con' }
= ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge (ConPatTc -> [Id]
cpt_tvs XConPat GhcTc
ConPatTc
con', ConPatTc -> [Id]
cpt_dicts XConPat GhcTc
ConPatTc
con') (([Id], [Id]) -> ([Id], [Id])) -> ([Id], [Id]) -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (HsConPatDetails GhcTc -> ([Id], [Id]))
-> HsConPatDetails GhcTc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ Pat GhcTc -> HsConPatDetails GhcTc
forall p. Pat p -> HsConPatDetails p
pat_args Pat GhcTc
con
go1 (SigPat XSigPat GhcTc
_ LPat GhcTc
p HsPatSigType (NoGhcTc GhcTc)
_) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (XPat XXPat GhcTc
ext) = case XXPat GhcTc
ext of
CoPat HsWrapper
_ Pat GhcTc
p Kind
_ -> Pat GhcTc -> ([Id], [Id])
go1 Pat GhcTc
p
ExpansionPat Pat GhcRn
_ Pat GhcTc
p -> Pat GhcTc -> ([Id], [Id])
go1 Pat GhcTc
p
go1 (NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
n XRec GhcTc (HsOverLit GhcTc)
k HsOverLit GhcTc
_ SyntaxExpr GhcTc
geq SyntaxExpr GhcTc
subtract)
= String -> SDoc -> ([Id], [Id])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"TODO: NPlusKPat" (SDoc -> ([Id], [Id])) -> SDoc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
GenLocated SrcSpanAnnN Id
n SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated EpAnnCO (HsOverLit GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr XRec GhcTc (HsOverLit GhcTc)
GenLocated EpAnnCO (HsOverLit GhcTc)
k SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SyntaxExprTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
SyntaxExprTc
geq SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SyntaxExprTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
SyntaxExprTc
subtract
go1 Pat GhcTc
_ = ([Id], [Id])
forall {a} {a}. ([a], [a])
empty
goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
goConDetails :: HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)]
_ [LPat GhcTc]
ps) = [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
GenLocated SrcSpanAnnA (Pat GhcTc) -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
goConDetails (InfixCon LPat GhcTc
p1 LPat GhcTc
p2) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p1 ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
`merge` LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p2
goConDetails (RecCon HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcTc (LPat GhcTc)]
flds })
= [([Id], [Id])] -> ([Id], [Id])
forall {a} {a}. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LHsRecField GhcTc (LPat GhcTc)] -> [([Id], [Id])])
-> [LHsRecField GhcTc (LPat GhcTc)]
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))
-> ([Id], [Id]))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))
-> ([Id], [Id])
goRecFd ([LHsRecField GhcTc (LPat GhcTc)] -> ([Id], [Id]))
-> [LHsRecField GhcTc (LPat GhcTc)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LHsRecField GhcTc (LPat GhcTc)]
flds
goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
goRecFd (L SrcSpanAnnA
_ HsFieldBind{ hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = GenLocated SrcSpanAnnA (Pat GhcTc)
p }) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
p
merge :: ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge ([a]
vs1, [a]
evs1) ([a]
vs2, [a]
evs2) = ([a]
vs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
vs2, [a]
evs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
evs2)
mergeMany :: [([a], [a])] -> ([a], [a])
mergeMany = (([a], [a]) -> ([a], [a]) -> ([a], [a]))
-> ([a], [a]) -> [([a], [a])] -> ([a], [a])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a], [a]) -> ([a], [a]) -> ([a], [a])
forall {a} {a}. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge ([a], [a])
forall {a} {a}. ([a], [a])
empty
empty :: ([a], [a])
empty = ([], [])