{-# 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 )
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 "GhclibHsVersions.h"
tcPatSynDecl :: PatSynBind GhcRn GhcRn
-> Maybe TcSigInfo
-> TcPragEnv
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl :: PatSynBind GhcRn GhcRn
-> Maybe TcSigInfo -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl PatSynBind GhcRn GhcRn
psb Maybe TcSigInfo
mb_sig TcPragEnv
prag_fn
= TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
recoverPSB PatSynBind GhcRn GhcRn
psb) (TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$
case Maybe TcSigInfo
mb_sig of
Maybe TcSigInfo
Nothing -> PatSynBind GhcRn GhcRn
-> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl PatSynBind GhcRn GhcRn
psb TcPragEnv
prag_fn
Just (TcPatSynSig TcPatSynInfo
tpsi) -> PatSynBind GhcRn GhcRn
-> TcPatSynInfo -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl PatSynBind GhcRn GhcRn
psb TcPatSynInfo
tpsi TcPragEnv
prag_fn
Maybe TcSigInfo
_ -> String
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. 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 _ name
, psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details })
= do { Name
matcher_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkMatcherOcc
; let placeholder :: TyThing
placeholder = ConLike -> TyThing
AConLike (ConLike -> TyThing) -> ConLike -> TyThing
forall a b. (a -> b) -> a -> b
$ PatSyn -> ConLike
PatSynCon (PatSyn -> ConLike) -> PatSyn -> ConLike
forall a b. (a -> b) -> a -> b
$
Name -> PatSyn
mk_placeholder Name
matcher_name
; TcGblEnv
gbl_env <- [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
placeholder] TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, TcGblEnv
gbl_env) }
where
([Name]
_arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
mk_placeholder :: Name -> PatSyn
mk_placeholder Name
matcher_name
= Name
-> Bool
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> ThetaType
-> Type
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
name Bool
is_infix
([Specificity -> TyVar -> InvisTVBinder
forall vis. vis -> TyVar -> VarBndr TyVar vis
mkTyVarBinder Specificity
SpecifiedSpec TyVar
alphaTyVar], []) ([], [])
[]
Type
alphaTy
(Name
matcher_name, Type
matcher_ty, Bool
True) PatSynBuilder
forall a. Maybe a
Nothing
[]
where
matcher_ty :: Type
matcher_ty = [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar
alphaTyVar] Type
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 _ 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
= LocatedN Name
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. LocatedN Name -> TcM a -> TcM a
addPatSynCtxt LocatedN Name
LIdP GhcRn
lname (TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcInferPatSynDecl {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
; let ([Name]
arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
; (TcLevel
tclvl, WantedConstraints
wanted, ((GenLocated SrcSpanAnnA (Pat GhcTc)
lpat', [TyVar]
args), Type
pat_ty))
<- TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [TyVar]), Type)
-> TcM
(TcLevel, WantedConstraints,
((GenLocated SrcSpanAnnA (Pat GhcTc), [TyVar]), Type))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [TyVar]), Type)
-> TcM
(TcLevel, WantedConstraints,
((GenLocated SrcSpanAnnA (Pat GhcTc), [TyVar]), Type)))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [TyVar]), Type)
-> TcM
(TcLevel, WantedConstraints,
((GenLocated SrcSpanAnnA (Pat GhcTc), [TyVar]), Type))
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcRn
-> LPat GhcRn -> TcM [TyVar] -> TcM ((LPat GhcTc, [TyVar]), Type)
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcM a -> TcM ((LPat GhcTc, a), Type)
tcInferPat HsMatchContext GhcRn
forall p. HsMatchContext p
PatSyn LPat GhcRn
lpat (TcM [TyVar] -> TcM ((LPat GhcTc, [TyVar]), Type))
-> TcM [TyVar] -> TcM ((LPat GhcTc, [TyVar]), Type)
forall a b. (a -> b) -> a -> b
$
(Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [Name] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
tcLookupId [Name]
arg_names
; let ([TyVar]
ex_tvs, [TyVar]
prov_dicts) = LPat GhcTc -> ([TyVar], [TyVar])
tcCollectEx GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
lpat'
named_taus :: [(Name, Type)]
named_taus = (Name
name, Type
pat_ty) (Name, Type) -> [(Name, Type)] -> [(Name, Type)]
forall a. a -> [a] -> [a]
: (TyVar -> (Name, Type)) -> [TyVar] -> [(Name, Type)]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> (Name, Type)
mk_named_tau [TyVar]
args
mk_named_tau :: TyVar -> (Name, Type)
mk_named_tau TyVar
arg
= (TyVar -> Name
forall a. NamedThing a => a -> Name
getName TyVar
arg, [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
ex_tvs (TyVar -> Type
varType TyVar
arg))
; (([TyVar]
univ_tvs, [TyVar]
req_dicts, TcEvBinds
ev_binds, Bool
_), WantedConstraints
residual)
<- TcM ([TyVar], [TyVar], TcEvBinds, Bool)
-> TcM (([TyVar], [TyVar], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([TyVar], [TyVar], TcEvBinds, Bool)
-> TcM (([TyVar], [TyVar], TcEvBinds, Bool), WantedConstraints))
-> TcM ([TyVar], [TyVar], TcEvBinds, Bool)
-> TcM (([TyVar], [TyVar], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM ([TyVar], [TyVar], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
NoRestrictions [] [(Name, Type)]
named_taus WantedConstraints
wanted
; Bag EvBind
top_ev_binds <- TcM (Bag EvBind) -> TcM (Bag EvBind)
forall r. TcM r -> TcM r
checkNoErrs (WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
residual)
; Bag EvBind
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
top_ev_binds (TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$
do { [TyVar]
prov_dicts <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkId [TyVar]
prov_dicts
; let filtered_prov_dicts :: [TyVar]
filtered_prov_dicts = (TyVar -> Type) -> [TyVar] -> [TyVar]
forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs TyVar -> Type
evVarPred [TyVar]
prov_dicts
(ThetaType
prov_theta, [EvTerm]
prov_evs)
= [(Type, EvTerm)] -> (ThetaType, [EvTerm])
forall a b. [(a, b)] -> ([a], [b])
unzip ((TyVar -> Maybe (Type, EvTerm)) -> [TyVar] -> [(Type, EvTerm)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyVar -> Maybe (Type, EvTerm)
mkProvEvidence [TyVar]
filtered_prov_dicts)
req_theta :: ThetaType
req_theta = (TyVar -> Type) -> [TyVar] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
evVarPred [TyVar]
req_dicts
; [TyVar]
args <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkId [TyVar]
args
; let bad_args :: [(TyVar, DVarSet)]
bad_args = [ (TyVar
arg, DVarSet
bad_cos) | TyVar
arg <- [TyVar]
args [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
prov_dicts
, let bad_cos :: DVarSet
bad_cos = (TyVar -> Bool) -> DVarSet -> DVarSet
filterDVarSet TyVar -> Bool
isId (DVarSet -> DVarSet) -> DVarSet -> DVarSet
forall a b. (a -> b) -> a -> b
$
(Type -> DVarSet
tyCoVarsOfTypeDSet (TyVar -> Type
idType TyVar
arg))
, Bool -> Bool
not (DVarSet -> Bool
isEmptyDVarSet DVarSet
bad_cos) ]
; ((TyVar, DVarSet) -> TcRn ()) -> [(TyVar, DVarSet)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyVar, DVarSet) -> TcRn ()
dependentArgErr [(TyVar, DVarSet)]
bad_args
; String -> SDoc -> TcRn ()
traceTc String
"tcInferPatSynDecl }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
ex_tvs)
; [FieldLabel]
rec_fields <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; LocatedN Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> TcPragEnv
-> ([InvisTVBinder], ThetaType, TcEvBinds, [TyVar])
-> ([InvisTVBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish LocatedN Name
LIdP GhcRn
lname HsPatSynDir GhcRn
dir Bool
is_infix GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
lpat' TcPragEnv
prag_fn
(Specificity -> [TyVar] -> [InvisTVBinder]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkTyVarBinders Specificity
InferredSpec [TyVar]
univ_tvs
, ThetaType
req_theta, TcEvBinds
ev_binds, [TyVar]
req_dicts)
(Specificity -> [TyVar] -> [InvisTVBinder]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkTyVarBinders Specificity
InferredSpec [TyVar]
ex_tvs
, [TyVar] -> ThetaType
mkTyVarTys [TyVar]
ex_tvs, ThetaType
prov_theta, [EvTerm]
prov_evs)
((TyVar -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [TyVar] -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar [TyVar]
args, (TyVar -> Type) -> [TyVar] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
idType [TyVar]
args)
Type
pat_ty [FieldLabel]
rec_fields } }
mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
mkProvEvidence :: TyVar -> Maybe (Type, EvTerm)
mkProvEvidence TyVar
ev_id
| EqPred EqRel
r Type
ty1 Type
ty2 <- Type -> Pred
classifyPredType Type
pred
, let k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty1
k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty2
is_homo :: Bool
is_homo = Type
k1 HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
k2
homo_tys :: ThetaType
homo_tys = [Type
k1, Type
ty1, Type
ty2]
hetero_tys :: ThetaType
hetero_tys = [Type
k1, Type
k2, Type
ty1, Type
ty2]
= case EqRel
r of
EqRel
ReprEq | Bool
is_homo
-> (Type, EvTerm) -> Maybe (Type, EvTerm)
forall a. a -> Maybe a
Just ( Class -> ThetaType -> Type
mkClassPred Class
coercibleClass ThetaType
homo_tys
, DataCon -> ThetaType -> [EvExpr] -> EvTerm
evDataConApp DataCon
coercibleDataCon ThetaType
homo_tys [EvExpr]
eq_con_args )
| Bool
otherwise -> Maybe (Type, EvTerm)
forall a. Maybe a
Nothing
EqRel
NomEq | Bool
is_homo
-> (Type, EvTerm) -> Maybe (Type, EvTerm)
forall a. a -> Maybe a
Just ( Class -> ThetaType -> Type
mkClassPred Class
eqClass ThetaType
homo_tys
, DataCon -> ThetaType -> [EvExpr] -> EvTerm
evDataConApp DataCon
eqDataCon ThetaType
homo_tys [EvExpr]
eq_con_args )
| Bool
otherwise
-> (Type, EvTerm) -> Maybe (Type, EvTerm)
forall a. a -> Maybe a
Just ( Class -> ThetaType -> Type
mkClassPred Class
heqClass ThetaType
hetero_tys
, DataCon -> ThetaType -> [EvExpr] -> EvTerm
evDataConApp DataCon
heqDataCon ThetaType
hetero_tys [EvExpr]
eq_con_args )
| Bool
otherwise
= (Type, EvTerm) -> Maybe (Type, EvTerm)
forall a. a -> Maybe a
Just (Type
pred, EvExpr -> EvTerm
EvExpr (TyVar -> EvExpr
evId TyVar
ev_id))
where
pred :: Type
pred = TyVar -> Type
evVarPred TyVar
ev_id
eq_con_args :: [EvExpr]
eq_con_args = [TyVar -> EvExpr
evId TyVar
ev_id]
dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
dependentArgErr :: (TyVar, DVarSet) -> TcRn ()
dependentArgErr (TyVar
arg, DVarSet
bad_cos)
= SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
arg SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyVar -> Type
idType TyVar
arg))
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"has a type that mentions pattern-bound coercion"
SDoc -> SDoc -> SDoc
<> [TyVar] -> SDoc
forall a. [a] -> SDoc
plural [TyVar]
bad_co_list SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 ((TyVar -> SDoc) -> [TyVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
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 :: [TyVar]
bad_co_list = DVarSet -> [TyVar]
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 _ 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 -> [InvisTVBinder]
patsig_implicit_bndrs = [InvisTVBinder]
implicit_bndrs
, patsig_univ_bndrs :: TcPatSynInfo -> [InvisTVBinder]
patsig_univ_bndrs = [InvisTVBinder]
explicit_univ_bndrs, patsig_req :: TcPatSynInfo -> ThetaType
patsig_req = ThetaType
req_theta
, patsig_ex_bndrs :: TcPatSynInfo -> [InvisTVBinder]
patsig_ex_bndrs = [InvisTVBinder]
explicit_ex_bndrs, patsig_prov :: TcPatSynInfo -> ThetaType
patsig_prov = ThetaType
prov_theta
, patsig_body_ty :: TcPatSynInfo -> Type
patsig_body_ty = Type
sig_body_ty }
TcPragEnv
prag_fn
= LocatedN Name
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. LocatedN Name -> TcM a -> TcM a
addPatSynCtxt LocatedN Name
LIdP GhcRn
lname (TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcCheckPatSynDecl" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ [InvisTVBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InvisTVBinder]
implicit_bndrs, [InvisTVBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InvisTVBinder]
explicit_univ_bndrs, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
req_theta
, [InvisTVBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InvisTVBinder]
explicit_ex_bndrs, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
prov_theta, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sig_body_ty ]
; let decl_arity :: Int
decl_arity = [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
arg_names
([Name]
arg_names, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
; ([Scaled Type]
arg_tys, Type
pat_ty) <- case Int -> Type -> Either Int ([Scaled Type], Type)
tcSplitFunTysN Int
decl_arity Type
sig_body_ty of
Right ([Scaled Type], Type)
stuff -> ([Scaled Type], Type)
-> IOEnv (Env TcGblEnv TcLclEnv) ([Scaled Type], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Scaled Type], Type)
stuff
Left Int
missing -> Name
-> Int
-> Int
-> IOEnv (Env TcGblEnv TcLclEnv) ([Scaled Type], Type)
forall a. Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
name Int
decl_arity Int
missing
; let bad_tvs :: [TyVar]
bad_tvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
pat_ty) ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
explicit_ex_bndrs
; Bool -> SDoc -> TcRn ()
checkTc ([TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
bad_tvs) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 (Name -> SDoc
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 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pat_ty) ])
Int
2 (String -> SDoc
text String
"mentions existential type variable" SDoc -> SDoc -> SDoc
<> [TyVar] -> SDoc
forall a. [a] -> SDoc
plural [TyVar]
bad_tvs
SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyVar]
bad_tvs)
; let univ_fvs :: VarSet
univ_fvs = VarSet -> VarSet
closeOverKinds (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
(ThetaType -> VarSet
tyCoVarsOfTypes (Type
pat_ty Type -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
: ThetaType
req_theta) VarSet -> [TyVar] -> VarSet
`extendVarSetList` ([InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
explicit_univ_bndrs))
([InvisTVBinder]
extra_univ, [InvisTVBinder]
extra_ex) = (InvisTVBinder -> Bool)
-> [InvisTVBinder] -> ([InvisTVBinder], [InvisTVBinder])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((TyVar -> VarSet -> Bool
`elemVarSet` VarSet
univ_fvs) (TyVar -> Bool)
-> (InvisTVBinder -> TyVar) -> InvisTVBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvisTVBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar) [InvisTVBinder]
implicit_bndrs
univ_bndrs :: [InvisTVBinder]
univ_bndrs = [InvisTVBinder]
extra_univ [InvisTVBinder] -> [InvisTVBinder] -> [InvisTVBinder]
forall a. [a] -> [a] -> [a]
++ [InvisTVBinder]
explicit_univ_bndrs
ex_bndrs :: [InvisTVBinder]
ex_bndrs = [InvisTVBinder]
extra_ex [InvisTVBinder] -> [InvisTVBinder] -> [InvisTVBinder]
forall a. [a] -> [a] -> [a]
++ [InvisTVBinder]
explicit_ex_bndrs
univ_tvs :: [TyVar]
univ_tvs = [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
univ_bndrs
ex_tvs :: [TyVar]
ex_tvs = [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
ex_bndrs
; (TCvSubst
skol_subst0, [InvisTVBinder]
skol_univ_bndrs) <- TCvSubst -> [InvisTVBinder] -> TcM (TCvSubst, [InvisTVBinder])
forall flag.
TCvSubst
-> [VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TyVar flag])
skolemiseTvBndrsX TCvSubst
emptyTCvSubst [InvisTVBinder]
univ_bndrs
; (TCvSubst
skol_subst, [InvisTVBinder]
skol_ex_bndrs) <- TCvSubst -> [InvisTVBinder] -> TcM (TCvSubst, [InvisTVBinder])
forall flag.
TCvSubst
-> [VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TyVar flag])
skolemiseTvBndrsX TCvSubst
skol_subst0 [InvisTVBinder]
ex_bndrs
; let skol_univ_tvs :: [TyVar]
skol_univ_tvs = [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
skol_univ_bndrs
skol_ex_tvs :: [TyVar]
skol_ex_tvs = [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
skol_ex_bndrs
skol_req_theta :: ThetaType
skol_req_theta = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
skol_subst0 ThetaType
req_theta
skol_prov_theta :: ThetaType
skol_prov_theta = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
skol_subst ThetaType
prov_theta
skol_arg_tys :: ThetaType
skol_arg_tys = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
skol_subst ((Scaled Type -> Type) -> [Scaled Type] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys)
skol_pat_ty :: Type
skol_pat_ty = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
skol_subst Type
pat_ty
univ_tv_prs :: [(Name, TyVar)]
univ_tv_prs = [ (TyVar -> Name
forall a. NamedThing a => a -> Name
getName TyVar
orig_univ_tv, TyVar
skol_univ_tv)
| (TyVar
orig_univ_tv, TyVar
skol_univ_tv) <- [TyVar]
univ_tvs [TyVar] -> [TyVar] -> [(TyVar, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
skol_univ_tvs ]
; [TyVar]
req_dicts <- ThetaType -> TcM [TyVar]
newEvVars ThetaType
skol_req_theta
; (TcLevel
tclvl, WantedConstraints
wanted, (GenLocated SrcSpanAnnA (Pat GhcTc)
lpat', ([TyVar]
ex_tvs', [EvTerm]
prov_dicts, [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
args'))) <-
ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))))
-> TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])))
forall a b. (a -> b) -> a -> b
$
[(Name, TyVar)]
-> TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
-> TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
univ_tv_prs (TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
-> TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])))
-> TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
-> TcM
(GenLocated SrcSpanAnnA (Pat GhcTc),
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcRn
-> LPat GhcRn
-> Scaled Type
-> TcM ([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])
-> TcM
(LPat GhcTc,
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> Scaled Type -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat HsMatchContext GhcRn
forall p. HsMatchContext p
PatSyn LPat GhcRn
lpat (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
skol_pat_ty) (TcM ([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])
-> TcM
(LPat GhcTc,
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])))
-> TcM ([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])
-> TcM
(LPat GhcTc,
([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)]))
forall a b. (a -> b) -> a -> b
$
do { let in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([TyVar] -> VarSet
mkVarSet [TyVar]
skol_univ_tvs)
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
; (TCvSubst
inst_subst, [TyVar]
ex_tvs') <- (TCvSubst
-> TyVar -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, TyVar))
-> TCvSubst
-> [TyVar]
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, [TyVar])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst
-> TyVar -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, TyVar)
newMetaTyVarX TCvSubst
empty_subst [TyVar]
skol_ex_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn1" ([SDoc] -> SDoc
vcat [ TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyVar -> Type
tyVarKind TyVar
v) | TyVar
v <- [TyVar]
ex_tvs])
; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn2" ([SDoc] -> SDoc
vcat [ TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyVar -> Type
tyVarKind TyVar
v) | TyVar
v <- [TyVar]
ex_tvs'])
; let prov_theta' :: ThetaType
prov_theta' = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
inst_subst ThetaType
skol_prov_theta
; [EvTerm]
prov_dicts <- (Type -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm)
-> ThetaType -> IOEnv (Env TcGblEnv TcLclEnv) [EvTerm]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CtOrigin -> Type -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
emitWanted (PatSynBind GhcRn GhcRn -> CtOrigin
ProvCtxtOrigin PatSynBind GhcRn GhcRn
psb)) ThetaType
prov_theta'
; [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
args' <- (Name
-> Type
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [Name]
-> ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
tc_arg TCvSubst
inst_subst) [Name]
arg_names
ThetaType
skol_arg_tys
; ([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])
-> TcM ([TyVar], [EvTerm], [GenLocated SrcSpanAnnA (HsExpr GhcTc)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
ex_tvs', [EvTerm]
prov_dicts, [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
args') }
; let skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> Type -> [(Name, TyVar)] -> SkolemInfo
SigSkol (Name -> UserTypeCtxt
PatSynCtxt Name
name) Type
pat_ty []
; (Bag Implication
implics, TcEvBinds
ev_binds) <- TcLevel
-> SkolemInfo
-> [TyVar]
-> [TyVar]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tclvl SkolemInfo
skol_info [TyVar]
skol_univ_tvs
[TyVar]
req_dicts WantedConstraints
wanted
; Bag Implication -> TcRn ()
simplifyTopImplic Bag Implication
implics
; String -> SDoc -> TcRn ()
traceTc String
"tcCheckPatSynDecl }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
; [FieldLabel]
rec_fields <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; LocatedN Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> TcPragEnv
-> ([InvisTVBinder], ThetaType, TcEvBinds, [TyVar])
-> ([InvisTVBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish LocatedN Name
LIdP GhcRn
lname HsPatSynDir GhcRn
dir Bool
is_infix GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
lpat' TcPragEnv
prag_fn
([InvisTVBinder]
skol_univ_bndrs, ThetaType
skol_req_theta, TcEvBinds
ev_binds, [TyVar]
req_dicts)
([InvisTVBinder]
skol_ex_bndrs, [TyVar] -> ThetaType
mkTyVarTys [TyVar]
ex_tvs', ThetaType
skol_prov_theta, [EvTerm]
prov_dicts)
([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
[LHsExpr GhcTc]
args', ThetaType
skol_arg_tys)
Type
skol_pat_ty [FieldLabel]
rec_fields }
where
tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
tc_arg TCvSubst
subst Name
arg_name Type
arg_ty
= SrcSpan
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
arg_name) (IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do { TyVar
arg_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
tcLookupId Name
arg_name
; HsWrapper
wrap <- UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma UserTypeCtxt
GenSigCtxt
(TyVar -> Type
idType TyVar
arg_id)
(HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
arg_ty)
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar TyVar
IdP GhcTc
arg_id) }
skolemiseTvBndrsX :: TCvSubst -> [VarBndr TyVar flag]
-> TcM (TCvSubst, [VarBndr TcTyVar flag])
skolemiseTvBndrsX :: TCvSubst
-> [VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TyVar flag])
skolemiseTvBndrsX TCvSubst
orig_subst [VarBndr TyVar 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 :: TCvSubst -> VarBndr TyVar flag -> (TCvSubst, VarBndr TyVar flag)
mk_skol_tv_x TCvSubst
subst (Bndr TyVar
tv flag
flag)
= (TCvSubst
subst', TyVar -> flag -> VarBndr TyVar flag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
new_tv flag
flag)
where
new_kind :: Type
new_kind = TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst (TyVar -> Type
tyVarKind TyVar
tv)
new_tv :: TyVar
new_tv = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar (TyVar -> Name
tyVarName TyVar
tv) Type
new_kind TcTyVarDetails
details
subst' :: TCvSubst
subst' = TCvSubst -> TyVar -> TyVar -> TCvSubst
extendTvSubstWithClone TCvSubst
subst TyVar
tv TyVar
new_tv
; (TCvSubst, [VarBndr TyVar flag])
-> TcM (TCvSubst, [VarBndr TyVar flag])
forall (m :: * -> *) a. Monad m => a -> m a
return ((TCvSubst -> VarBndr TyVar flag -> (TCvSubst, VarBndr TyVar flag))
-> TCvSubst
-> [VarBndr TyVar flag]
-> (TCvSubst, [VarBndr TyVar flag])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TCvSubst -> VarBndr TyVar flag -> (TCvSubst, VarBndr TyVar flag)
forall flag.
TCvSubst -> VarBndr TyVar flag -> (TCvSubst, VarBndr TyVar flag)
mk_skol_tv_x TCvSubst
orig_subst [VarBndr TyVar flag]
tvs) }
collectPatSynArgInfo :: HsPatSynDetails GhcRn
-> ([Name], Bool)
collectPatSynArgInfo :: HsPatSynDetails GhcRn -> ([Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details =
case HsPatSynDetails GhcRn
details of
PrefixCon [Void]
_ [LIdP GhcRn]
names -> ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LocatedN Name]
[LIdP GhcRn]
names, Bool
False)
InfixCon LIdP GhcRn
name1 LIdP GhcRn
name2 -> ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LocatedN Name
LIdP GhcRn
name1, LocatedN Name
LIdP GhcRn
name2], Bool
True)
RecCon [RecordPatSynField GhcRn]
names -> ((RecordPatSynField GhcRn -> Name)
-> [RecordPatSynField GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc (LocatedN Name -> Name)
-> (RecordPatSynField GhcRn -> LocatedN Name)
-> RecordPatSynField GhcRn
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField GhcRn -> LocatedN Name
forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar) [RecordPatSynField GhcRn]
names, Bool
False)
addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a
addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a
addPatSynCtxt (L SrcSpanAnnN
loc Name
name) TcM a
thing_inside
= SrcSpanAnnN -> TcM a -> TcM a
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnN
loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text String
"In the declaration for pattern synonym"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr :: Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
name Int
decl_arity Int
missing
= SDoc -> TcM a
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM a) -> SDoc -> TcM a
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
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
-> ([InvisTVBinder], ThetaType, TcEvBinds, [TyVar])
-> ([InvisTVBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [FieldLabel]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish LocatedN Name
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
lpat' TcPragEnv
prag_fn
([InvisTVBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [TyVar]
req_dicts)
([InvisTVBinder]
ex_tvs, ThetaType
ex_tys, ThetaType
prov_theta, [EvTerm]
prov_dicts)
([LHsExpr GhcTc]
args, ThetaType
arg_tys)
Type
pat_ty [FieldLabel]
field_labels
= do {
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [InvisTVBinder]
univ_tvs') <- ZonkEnv -> [InvisTVBinder] -> TcM (ZonkEnv, [InvisTVBinder])
forall vis.
ZonkEnv
-> [VarBndr TyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX ZonkEnv
ze [InvisTVBinder]
univ_tvs
; ThetaType
req_theta' <- ZonkEnv -> ThetaType -> TcM ThetaType
zonkTcTypesToTypesX ZonkEnv
ze ThetaType
req_theta
; (ZonkEnv
ze, [InvisTVBinder]
ex_tvs') <- ZonkEnv -> [InvisTVBinder] -> TcM (ZonkEnv, [InvisTVBinder])
forall vis.
ZonkEnv
-> [VarBndr TyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX ZonkEnv
ze [InvisTVBinder]
ex_tvs
; ThetaType
prov_theta' <- ZonkEnv -> ThetaType -> TcM ThetaType
zonkTcTypesToTypesX ZonkEnv
ze ThetaType
prov_theta
; Type
pat_ty' <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
pat_ty
; ThetaType
arg_tys' <- ZonkEnv -> ThetaType -> TcM ThetaType
zonkTcTypesToTypesX ZonkEnv
ze ThetaType
arg_tys
; let (TidyEnv
env1, [InvisTVBinder]
univ_tvs) = TidyEnv -> [InvisTVBinder] -> (TidyEnv, [InvisTVBinder])
forall vis.
TidyEnv -> [VarBndr TyVar vis] -> (TidyEnv, [VarBndr TyVar vis])
tidyTyCoVarBinders TidyEnv
emptyTidyEnv [InvisTVBinder]
univ_tvs'
(TidyEnv
env2, [InvisTVBinder]
ex_tvs) = TidyEnv -> [InvisTVBinder] -> (TidyEnv, [InvisTVBinder])
forall vis.
TidyEnv -> [VarBndr TyVar vis] -> (TidyEnv, [VarBndr TyVar vis])
tidyTyCoVarBinders TidyEnv
env1 [InvisTVBinder]
ex_tvs'
req_theta :: ThetaType
req_theta = TidyEnv -> ThetaType -> ThetaType
tidyTypes TidyEnv
env2 ThetaType
req_theta'
prov_theta :: ThetaType
prov_theta = TidyEnv -> ThetaType -> ThetaType
tidyTypes TidyEnv
env2 ThetaType
prov_theta'
arg_tys :: ThetaType
arg_tys = TidyEnv -> ThetaType -> ThetaType
tidyTypes TidyEnv
env2 ThetaType
arg_tys'
pat_ty :: Type
pat_ty = TidyEnv -> Type -> Type
tidyType TidyEnv
env2 Type
pat_ty'
; String -> SDoc -> TcRn ()
traceTc String
"tc_patsyn_finish {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc LocatedN Name
lname) SDoc -> SDoc -> SDoc
$$ Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
lpat') SDoc -> SDoc -> SDoc
$$
([InvisTVBinder], ThetaType, TcEvBinds, [TyVar]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([InvisTVBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [TyVar]
req_dicts) SDoc -> SDoc -> SDoc
$$
([InvisTVBinder], ThetaType, [EvTerm]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([InvisTVBinder]
ex_tvs, ThetaType
prov_theta, [EvTerm]
prov_dicts) SDoc -> SDoc -> SDoc
$$
[GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
[LHsExpr GhcTc]
args SDoc -> SDoc -> SDoc
$$
ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
arg_tys SDoc -> SDoc -> SDoc
$$
Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pat_ty
; (PatSynMatcher
matcher, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind) <- LocatedN Name
-> LPat GhcTc
-> TcPragEnv
-> ([TyVar], ThetaType, TcEvBinds, [TyVar])
-> ([TyVar], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> TcM (PatSynMatcher, LHsBinds GhcTc)
tcPatSynMatcher LocatedN Name
lname LPat GhcTc
lpat' TcPragEnv
prag_fn
([InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [TyVar]
req_dicts)
([InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
ex_tvs, ThetaType
ex_tys, ThetaType
prov_theta, [EvTerm]
prov_dicts)
([LHsExpr GhcTc]
args, ThetaType
arg_tys)
Type
pat_ty
; PatSynBuilder
builder <- HsPatSynDir GhcRn
-> LocatedN Name
-> [InvisTVBinder]
-> ThetaType
-> [InvisTVBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM PatSynBuilder
forall a.
HsPatSynDir a
-> LocatedN Name
-> [InvisTVBinder]
-> ThetaType
-> [InvisTVBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM PatSynBuilder
mkPatSynBuilder HsPatSynDir GhcRn
dir LocatedN Name
lname
[InvisTVBinder]
univ_tvs ThetaType
req_theta
[InvisTVBinder]
ex_tvs ThetaType
prov_theta
ThetaType
arg_tys Type
pat_ty
; let patSyn :: PatSyn
patSyn = Name
-> Bool
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> ThetaType
-> Type
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc LocatedN Name
lname) Bool
is_infix
([InvisTVBinder]
univ_tvs, ThetaType
req_theta)
([InvisTVBinder]
ex_tvs, ThetaType
prov_theta)
ThetaType
arg_tys
Type
pat_ty
PatSynMatcher
matcher PatSynBuilder
builder
[FieldLabel]
field_labels
; FieldSelectors
has_sel <- DynFlags -> FieldSelectors
xopt_FieldSelectors (DynFlags -> FieldSelectors)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) FieldSelectors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let rn_rec_sel_binds :: [(TyVar, LHsBind GhcRn)]
rn_rec_sel_binds = PatSyn
-> [FieldLabel] -> FieldSelectors -> [(TyVar, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
patSyn (PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
patSyn) FieldSelectors
has_sel
tything :: TyThing
tything = ConLike -> TyThing
AConLike (PatSyn -> ConLike
PatSynCon PatSyn
patSyn)
; TcGblEnv
tcg_env <- [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
tything] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
[(TyVar, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds [(TyVar, LHsBind GhcRn)]
rn_rec_sel_binds
; String -> SDoc -> TcRn ()
traceTc String
"tc_patsyn_finish }" SDoc
empty
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), TcGblEnv)
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
-> ([TyVar], ThetaType, TcEvBinds, [TyVar])
-> ([TyVar], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> TcM (PatSynMatcher, LHsBinds GhcTc)
tcPatSynMatcher (L SrcSpanAnnN
loc Name
name) LPat GhcTc
lpat TcPragEnv
prag_fn
([TyVar]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [TyVar]
req_dicts)
([TyVar]
ex_tvs, ThetaType
ex_tys, ThetaType
prov_theta, [EvTerm]
prov_dicts)
([LHsExpr GhcTc]
args, ThetaType
arg_tys) Type
pat_ty
= do { let loc' :: SrcSpan
loc' = SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc
; Name
rr_name <- OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
newNameAt (String -> OccName
mkTyVarOcc String
"rep") SrcSpan
loc'
; Name
tv_name <- OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
newNameAt (String -> OccName
mkTyVarOcc String
"r") SrcSpan
loc'
; let rr_tv :: TyVar
rr_tv = Name -> Type -> TyVar
mkTyVar Name
rr_name Type
runtimeRepTy
rr :: Type
rr = TyVar -> Type
mkTyVarTy TyVar
rr_tv
res_tv :: TyVar
res_tv = Name -> Type -> TyVar
mkTyVar Name
tv_name (Type -> Type
tYPE Type
rr)
res_ty :: Type
res_ty = TyVar -> Type
mkTyVarTy TyVar
res_tv
is_unlifted :: Bool
is_unlifted = [GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
[LHsExpr GhcTc]
args Bool -> Bool -> Bool
&& [EvTerm] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvTerm]
prov_dicts
([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
cont_args, ThetaType
cont_arg_tys)
| Bool
is_unlifted = ([IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar TyVar
IdP GhcTc
voidPrimId], [Type
unboxedUnitTy])
| Bool
otherwise = ([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
[LHsExpr GhcTc]
args, ThetaType
arg_tys)
cont_ty :: Type
cont_ty = [TyVar] -> ThetaType -> Type -> Type
mkInfSigmaTy [TyVar]
ex_tvs ThetaType
prov_theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
ThetaType -> Type -> Type
mkVisFunTysMany ThetaType
cont_arg_tys Type
res_ty
fail_ty :: Type
fail_ty = Type -> Type -> Type
mkVisFunTyMany Type
unboxedUnitTy Type
res_ty
; Name
matcher_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkMatcherOcc
; TyVar
scrutinee <- FastString -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl TyVar
newSysLocalId (String -> FastString
fsLit String
"scrut") Type
Many Type
pat_ty
; TyVar
cont <- FastString -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl TyVar
newSysLocalId (String -> FastString
fsLit String
"cont") Type
Many Type
cont_ty
; TyVar
fail <- FastString -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl TyVar
newSysLocalId (String -> FastString
fsLit String
"fail") Type
Many Type
fail_ty
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let matcher_tau :: Type
matcher_tau = ThetaType -> Type -> Type
mkVisFunTysMany [Type
pat_ty, Type
cont_ty, Type
fail_ty] Type
res_ty
matcher_sigma :: Type
matcher_sigma = [TyVar] -> ThetaType -> Type -> Type
mkInfSigmaTy (TyVar
rr_tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:TyVar
res_tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
univ_tvs) ThetaType
req_theta Type
matcher_tau
matcher_id :: TyVar
matcher_id = Name -> Type -> TyVar
mkExportedVanillaId Name
matcher_name Type
matcher_sigma
inst_wrap :: HsWrapper
inst_wrap = [EvTerm] -> HsWrapper
mkWpEvApps [EvTerm]
prov_dicts HsWrapper -> HsWrapper -> HsWrapper
<.> ThetaType -> HsWrapper
mkWpTyApps ThetaType
ex_tys
cont' :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
cont' = (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (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 TyVar
IdP GhcTc
cont)) [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
cont_args
fail' :: LHsExpr GhcTc
fail' = IdP GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps TyVar
IdP GhcTc
fail [IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar TyVar
IdP GhcTc
voidPrimId]
args :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
args = (TyVar -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [TyVar] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [TyVar
scrutinee, TyVar
cont, TyVar
fail]
lwpat :: GenLocated SrcSpanAnnA (Pat GhcTc)
lwpat = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat Type
XWildPat GhcTc
pat_ty
cases :: [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
cases = if DynFlags -> LPat GhcTc -> Bool
forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat DynFlags
dflags LPat GhcTc
lpat
then [LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
cont']
else [LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
cont',
LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
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)
LPat GhcTc
lwpat GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
fail']
body :: LHsExpr GhcTc
body = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
req_ev_binds) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
lpat) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (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 NoExtField
XCase GhcTc
noExtField (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar TyVar
IdP GhcTc
scrutinee) (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
MG :: forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = SrcAnn AnnList
-> [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
(SrcAnn AnnList)
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcAnn AnnList
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l (SrcSpanAnnA -> SrcAnn AnnList) -> SrcSpanAnnA -> SrcAnn AnnList
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
lpat) [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
cases
, mg_ext :: XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc [Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
pat_ty] Type
res_ty
, mg_origin :: Origin
mg_origin = Origin
Generated
}
body' :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
body' = HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
XLam GhcTc
noExtField (MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
MG :: forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
(SrcAnn AnnList)
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA [HsMatchContext (NoGhcTc GhcTc)
-> [LPat GhcTc]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
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 HsMatchContext (NoGhcTc GhcTc)
forall p. HsMatchContext p
LambdaExpr
[GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat GhcTc]
args GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
body]
, mg_ext :: XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc ((Type -> Scaled Type) -> ThetaType -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted [Type
pat_ty, Type
cont_ty, Type
fail_ty]) Type
res_ty
, mg_origin :: Origin
mg_origin = Origin
Generated
}
match :: LMatch GhcTc (LHsExpr GhcTc)
match = HsMatchContext (NoGhcTc GhcTc)
-> [LPat GhcTc]
-> LHsExpr GhcTc
-> HsLocalBinds GhcTc
-> LMatch GhcTc (LHsExpr GhcTc)
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 (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
name)) []
([TyVar] -> [TyVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams (TyVar
rr_tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:TyVar
res_tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
univ_tvs)
[TyVar]
req_dicts GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
body')
(XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcTc GhcTc
noExtField)
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg = MG :: forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG{ mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = SrcAnn AnnList
-> [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
(SrcAnn AnnList)
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcAnn AnnList
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l (SrcSpanAnnA -> SrcAnn AnnList) -> SrcSpanAnnA -> SrcAnn AnnList
forall a b. (a -> b) -> a -> b
$ GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
LMatch GhcTc (LHsExpr GhcTc)
match) [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
LMatch GhcTc (LHsExpr GhcTc)
match]
, mg_ext :: XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc [] Type
res_ty
, mg_origin :: Origin
mg_origin = Origin
Generated
}
prags :: [LSig GhcRn]
prags = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name
; TyVar
matcher_prag_id <- TyVar -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
addInlinePrags TyVar
matcher_id [LSig GhcRn]
prags
; let bind :: HsBindLR GhcTc GhcTc
bind = FunBind :: forall idL idR.
XFunBind idL idR
-> LIdP idL
-> MatchGroup idR (LHsExpr idR)
-> [CoreTickish]
-> HsBindLR idL idR
FunBind{ fun_id :: LIdP GhcTc
fun_id = SrcSpanAnnN -> TyVar -> GenLocated SrcSpanAnnN TyVar
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TyVar
matcher_prag_id
, fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
mg
, fun_ext :: XFunBind GhcTc GhcTc
fun_ext = HsWrapper
XFunBind GhcTc GhcTc
idHsWrapper
, fun_tick :: [CoreTickish]
fun_tick = [] }
matcher_bind :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind = GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsBindLR GhcTc GhcTc
bind)
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynMatcher" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyVar -> Type
idType TyVar
matcher_id))
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynMatcher" (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind)
; (PatSynMatcher,
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(PatSynMatcher,
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
matcher_name, Type
matcher_sigma, Bool
is_unlifted), Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
matcher_bind) }
mkPatSynRecSelBinds :: PatSyn
-> [FieldLabel]
-> FieldSelectors
-> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds :: PatSyn
-> [FieldLabel] -> FieldSelectors -> [(TyVar, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
ps [FieldLabel]
fields FieldSelectors
has_sel
= [ [ConLike]
-> RecSelParent
-> FieldLabel
-> FieldSelectors
-> (TyVar, 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 :: 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 :: HsPatSynDir a
-> LocatedN Name
-> [InvisTVBinder]
-> ThetaType
-> [InvisTVBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM PatSynBuilder
mkPatSynBuilder HsPatSynDir a
dir (L SrcSpanAnnN
_ Name
name)
[InvisTVBinder]
univ_bndrs ThetaType
req_theta [InvisTVBinder]
ex_bndrs ThetaType
prov_theta
ThetaType
arg_tys Type
pat_ty
| HsPatSynDir a -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir a
dir
= PatSynBuilder -> TcM PatSynBuilder
forall (m :: * -> *) a. Monad m => a -> m a
return PatSynBuilder
forall a. Maybe a
Nothing
| Bool
otherwise
= do { Name
builder_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
name OccName -> OccName
mkBuilderOcc
; let theta :: ThetaType
theta = ThetaType
req_theta ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
prov_theta
need_dummy_arg :: Bool
need_dummy_arg = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
pat_ty Bool -> Bool -> Bool
&& ThetaType -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
arg_tys Bool -> Bool -> Bool
&& ThetaType -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta
builder_sigma :: Type
builder_sigma = Bool -> Type -> Type
add_void Bool
need_dummy_arg (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
univ_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
ex_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
ThetaType -> Type -> Type
mkPhiTy ThetaType
theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
ThetaType -> Type -> Type
mkVisFunTysMany ThetaType
arg_tys (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type
pat_ty
; PatSynBuilder -> TcM PatSynBuilder
forall (m :: * -> *) a. Monad m => a -> m a
return (PatSynMatcher -> PatSynBuilder
forall a. a -> Maybe a
Just (Name
builder_name, Type
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 loc ps_name)
, psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat
, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir
, psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcRn
details })
| HsPatSynDir GhcRn -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir GhcRn
dir
= Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag
| Left SDoc
why <- Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= SrcSpan
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (Pat GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (Pat GhcRn)
LPat GhcRn
lpat) (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$ SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. SDoc -> TcM a
failWithTc (SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
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 (Name -> SDoc
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
<+> GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (Pat GhcRn)
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 -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag ;
Just (Name
builder_name, Type
builder_ty, Bool
need_dummy_arg) ->
do {
let pat_ty :: Type
pat_ty = PatSyn -> Type
patSynResultType PatSyn
patsyn
builder_id :: TyVar
builder_id = HasDebugCallStack => (IdInfo -> IdInfo) -> TyVar -> TyVar
(IdInfo -> IdInfo) -> TyVar -> TyVar
modifyIdInfo (IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
pat_ty) (TyVar -> TyVar) -> TyVar -> TyVar
forall a b. (a -> b) -> a -> b
$
Name -> Type -> TyVar
mkExportedVanillaId Name
builder_name Type
builder_ty
prags :: [LSig GhcRn]
prags = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
ps_name
; TyVar
builder_id <- TyVar -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
addInlinePrags TyVar
builder_id [LSig GhcRn]
prags
; let match_group' :: MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group' | Bool
need_dummy_arg = MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
match_group
| Bool
otherwise = MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match_group
bind :: HsBindLR GhcRn GhcRn
bind = FunBind :: forall idL idR.
XFunBind idL idR
-> LIdP idL
-> MatchGroup idR (LHsExpr idR)
-> [CoreTickish]
-> HsBindLR idL idR
FunBind { fun_id :: LIdP GhcRn
fun_id = SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (TyVar -> Name
idName TyVar
builder_id)
, fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches = MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
match_group'
, fun_ext :: XFunBind GhcRn GhcRn
fun_ext = NameSet
XFunBind GhcRn GhcRn
emptyNameSet
, fun_tick :: [CoreTickish]
fun_tick = [] }
sig :: TcIdSigInfo
sig = UserTypeCtxt -> TyVar -> TcIdSigInfo
completeSigFromId (Name -> UserTypeCtxt
PatSynCtxt Name
ps_name) TyVar
builder_id
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
patsyn
, TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
builder_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyVar -> Type
idType TyVar
builder_id)
, [GenLocated SrcSpanAnnA (Sig GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
prags ]
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder_binds, [TyVar]
_) <- TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [TyVar])
tcPolyCheck TcPragEnv
emptyPragEnv TcIdSigInfo
sig (HsBindLR GhcRn GhcRn
-> LocatedAn AnnListItem (HsBindLR GhcRn GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsBindLR GhcRn GhcRn
bind)
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder_binds
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder_binds } } }
#if __GLASGOW_HASKELL__ <= 810
| Bool
otherwise = String
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. String -> a
panic String
"tcPatSynBuilderBind"
#endif
where
mb_match_group :: Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
mb_match_group
= case HsPatSynDir GhcRn
dir of
ExplicitBidirectional MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg -> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b. b -> Either a b
Right MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg
HsPatSynDir GhcRn
ImplicitBidirectional -> (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg (Name
-> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
ps_name [LocatedN Name]
args LPat GhcRn
lpat)
HsPatSynDir GhcRn
Unidirectional -> String
-> Either
SDoc (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
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 = Origin
-> LocatedL
[LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
Generated ([LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> LocatedL
[LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a an. a -> LocatedAn an a
noLocA [LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
LMatch GhcRn (LHsExpr GhcRn)
builder_match])
where
builder_args :: [GenLocated SrcSpanAnnA (Pat GhcRn)]
builder_args = [SrcSpanAnnA -> Pat GhcRn -> GenLocated SrcSpanAnnA (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnnN
loc) (XVarPat GhcRn -> LIdP GhcRn -> Pat GhcRn
forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
XVarPat GhcRn
noExtField (SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n))
| L SrcSpanAnnN
loc Name
n <- [LocatedN Name]
args]
builder_match :: LMatch GhcRn (LHsExpr GhcRn)
builder_match = HsMatchContext (NoGhcTc GhcRn)
-> [LPat GhcRn]
-> LHsExpr GhcRn
-> HsLocalBinds GhcRn
-> LMatch GhcRn (LHsExpr GhcRn)
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 (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcRn
ps_lname)
[GenLocated SrcSpanAnnA (Pat GhcRn)]
[LPat GhcRn]
builder_args LHsExpr GhcRn
body
(XEmptyLocalBinds GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcRn GhcRn
noExtField)
args :: [LocatedN Name]
args = case HsPatSynDetails GhcRn
details of
PrefixCon [Void]
_ [LIdP GhcRn]
args -> [LocatedN Name]
[LIdP GhcRn]
args
InfixCon LIdP GhcRn
arg1 LIdP GhcRn
arg2 -> [LocatedN Name
LIdP GhcRn
arg1, LocatedN Name
LIdP GhcRn
arg2]
RecCon [RecordPatSynField GhcRn]
args -> (RecordPatSynField GhcRn -> LocatedN Name)
-> [RecordPatSynField GhcRn] -> [LocatedN Name]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField GhcRn -> LocatedN Name
forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar [RecordPatSynField GhcRn]
args
add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg mg :: MatchGroup GhcRn (LHsExpr GhcRn)
mg@(MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts =
(L l [L loc match@(Match { m_pats = pats })]) })
= MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
mg { mg_alts :: XRec GhcRn [LMatch GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
mg_alts = SrcAnn AnnList
-> [LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> LocatedL
[LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall l e. l -> e -> GenLocated l e
L SrcAnn AnnList
l [SrcSpanAnnA
-> Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match { m_pats :: [LPat GhcRn]
m_pats = GenLocated SrcSpanAnnA (Pat GhcRn)
LPat GhcRn
nlWildPatName GenLocated SrcSpanAnnA (Pat GhcRn)
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (Pat GhcRn)]
[LPat GhcRn]
pats })] }
add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
other_mg = String
-> SDoc -> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"add_dummy_arg" (SDoc -> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> SDoc -> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
other_mg
patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, Type)
patSynBuilderOcc PatSyn
ps
| Just (Name
_, Type
builder_ty, Bool
add_void_arg) <- PatSyn -> PatSynBuilder
patSynBuilder PatSyn
ps
, let builder_expr :: HsExpr GhcTc
builder_expr = XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (PatSyn -> ConLike
PatSynCon PatSyn
ps)
= (HsExpr GhcTc, Type) -> Maybe (HsExpr GhcTc, Type)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, Type) -> Maybe (HsExpr GhcTc, Type))
-> (HsExpr GhcTc, Type) -> Maybe (HsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
if Bool
add_void_arg
then ( HsExpr GhcTc
builder_expr
, Type -> Type
tcFunResultTy Type
builder_ty )
else (HsExpr GhcTc
builder_expr, Type
builder_ty)
| Bool
otherwise
= Maybe (HsExpr GhcTc, Type)
forall a. Maybe a
Nothing
add_void :: Bool -> Type -> Type
add_void :: Bool -> Type -> Type
add_void Bool
need_dummy_arg Type
ty
| Bool
need_dummy_arg = Type -> Type -> Type
mkVisFunTyMany Type
unboxedUnitTy Type
ty
| Bool
otherwise = Type
ty
tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
-> Either SDoc (LHsExpr GhcRn)
tcPatToExpr :: Name
-> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
name [LocatedN Name]
args LPat GhcRn
pat = LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go LPat GhcRn
pat
where
lhsVars :: NameSet
lhsVars = [Name] -> NameSet
mkNameSet ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LocatedN Name]
args)
mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
-> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr lcon :: LocatedN Name
lcon@(L SrcSpanAnnN
loc Name
_) [LPat GhcRn]
pats
= do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either SDoc [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [GenLocated SrcSpanAnnA (Pat GhcRn)]
[LPat GhcRn]
pats
; let con :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
con = SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
loc) (XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField LocatedN Name
LIdP GhcRn
lcon)
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
con [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
[LHsExpr 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 <- (GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (Pat GhcRn)))
-> Either
SDoc
(GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))))
-> [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (Pat GhcRn)))]
-> Either
SDoc
[GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (Pat GhcRn)))
-> Either
SDoc
(GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
LHsRecField GhcRn (LPat GhcRn)
-> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
go' [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (Pat GhcRn)))]
[LHsRecField GhcRn (LPat GhcRn)]
fields
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRecordCon GhcRn
-> XRec GhcRn (ConLikeP GhcRn)
-> HsRecordBinds GhcRn
-> HsExpr GhcRn
forall p.
XRecordCon p -> XRec p (ConLikeP p) -> HsRecordBinds p -> HsExpr p
RecordCon NoExtField
XRecordCon GhcRn
noExtField LocatedN Name
XRec GhcRn (ConLikeP GhcRn)
con ([LHsRecField GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> Maybe (Located Int)
-> HsRecFields GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecField 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 l rf) = SrcSpanAnnA
-> HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
-> Either
SDoc
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Either
SDoc
(GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (Pat GhcRn))
-> Either
SDoc
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
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 loc p) = SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either SDoc (HsExpr GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 Pat GhcRn
p
go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 (ConPat XConPat GhcRn
NoExtField 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 LocatedN Name
XRec GhcRn (ConLikeP GhcRn)
con [LPat GhcRn]
ps
InfixCon LPat GhcRn
l LPat GhcRn
r -> LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr LocatedN Name
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 LocatedN Name
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 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcRn)
LPat GhcRn
pat)
go1 (VarPat XVarPat GhcRn
_ (L l var))
| Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
lhsVars
= HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
var)
| Bool
otherwise
= SDoc -> Either SDoc (HsExpr GhcRn)
forall a b. a -> Either a b
Left (SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
var) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not bound by the LHS of the pattern synonym")
go1 (ParPat XParPat GhcRn
_ LPat GhcRn
pat) = (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either SDoc (HsExpr GhcRn)
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
forall a. EpAnn' a
noAnn) (Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either SDoc (HsExpr GhcRn))
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Either SDoc (HsExpr GhcRn)
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)
| XListPat GhcRn
Nothing <- XListPat GhcRn
reb = do { [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either SDoc [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [GenLocated SrcSpanAnnA (Pat GhcRn)]
[LPat GhcRn]
pats
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcRn -> [LHsExpr GhcRn] -> HsExpr GhcRn
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList NoExtField
XExplicitList GhcRn
noExtField [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
[LHsExpr 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 <- (GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> Either SDoc [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (Pat GhcRn)
-> Either SDoc (GenLocated SrcSpanAnnA (HsExpr GhcRn))
LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [GenLocated SrcSpanAnnA (Pat GhcRn)]
[LPat GhcRn]
pats
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcRn -> [HsTupArg GhcRn] -> Boxity -> HsExpr GhcRn
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
XExplicitTuple GhcRn
noExtField
((GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsTupArg GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)] -> [HsTupArg GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (XPresent GhcRn -> LHsExpr GhcRn -> HsTupArg GhcRn
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
forall a. EpAnn' a
noAnn) [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs) Boxity
box }
go1 (SumPat XSumPat GhcRn
_ LPat GhcRn
pat Int
alt Int
arity) = do { HsExpr GhcRn
expr <- Pat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcRn)
LPat GhcRn
pat)
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitSum GhcRn -> Int -> Int -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum NoExtField
XExplicitSum GhcRn
noExtField Int
alt Int
arity
(HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
expr)
}
go1 (LitPat XLitPat GhcRn
_ HsLit GhcRn
lit) = HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
XLitE GhcRn
noComments HsLit GhcRn
lit
go1 (NPat XNPat GhcRn
_ (L _ n) Maybe (SyntaxExpr GhcRn)
mb_neg SyntaxExpr GhcRn
_)
| Just (SyntaxExprRn neg) <- Maybe (SyntaxExpr GhcRn)
mb_neg
= HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
neg)
[HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
forall a. EpAnn' a
noAnn HsOverLit GhcRn
n)]
| Bool
otherwise = HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
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{})) = String -> Either SDoc (HsExpr GhcRn)
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 = SDoc -> Either SDoc (HsExpr GhcRn)
forall a b. a -> Either a b
Left (Pat GhcRn -> SDoc
not_invertible_msg Pat GhcRn
p)
not_invertible_msg :: Pat GhcRn -> SDoc
not_invertible_msg Pat GhcRn
p
= String -> SDoc
text String
"Pattern" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Pat GhcRn -> SDoc
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
<+> GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (Pat GhcRn)
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 = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
pp_args :: SDoc
pp_args = [SDoc] -> SDoc
hsep ((LocatedN Name -> SDoc) -> [LocatedN Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocatedN Name]
args)
notInvertibleListPat :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertibleListPat Pat GhcRn
p
= SDoc -> Either SDoc (HsExpr GhcRn)
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 -> ([TyVar], [TyVar])
tcCollectEx LPat GhcTc
pat = LPat GhcTc -> ([TyVar], [TyVar])
go LPat GhcTc
pat
where
go :: LPat GhcTc -> ([TyVar], [EvVar])
go :: LPat GhcTc -> ([TyVar], [TyVar])
go = Pat GhcTc -> ([TyVar], [TyVar])
go1 (Pat GhcTc -> ([TyVar], [TyVar]))
-> (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> ([TyVar], [TyVar])
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 -> ([TyVar], [TyVar])
go1 (LazyPat XLazyPat GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([TyVar], [TyVar])
go LPat GhcTc
p
go1 (AsPat XAsPat GhcTc
_ LIdP GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([TyVar], [TyVar])
go LPat GhcTc
p
go1 (ParPat XParPat GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([TyVar], [TyVar])
go LPat GhcTc
p
go1 (BangPat XBangPat GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([TyVar], [TyVar])
go LPat GhcTc
p
go1 (ListPat XListPat GhcTc
_ [LPat GhcTc]
ps) = [([TyVar], [TyVar])] -> ([TyVar], [TyVar])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([TyVar], [TyVar])] -> ([TyVar], [TyVar]))
-> ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([TyVar], [TyVar])])
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> ([TyVar], [TyVar])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([TyVar], [TyVar]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([TyVar], [TyVar])]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcTc) -> ([TyVar], [TyVar])
LPat GhcTc -> ([TyVar], [TyVar])
go ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> ([TyVar], [TyVar]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> ([TyVar], [TyVar])
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat GhcTc]
ps
go1 (TuplePat XTuplePat GhcTc
_ [LPat GhcTc]
ps Boxity
_) = [([TyVar], [TyVar])] -> ([TyVar], [TyVar])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([TyVar], [TyVar])] -> ([TyVar], [TyVar]))
-> ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([TyVar], [TyVar])])
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> ([TyVar], [TyVar])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([TyVar], [TyVar]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([TyVar], [TyVar])]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcTc) -> ([TyVar], [TyVar])
LPat GhcTc -> ([TyVar], [TyVar])
go ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> ([TyVar], [TyVar]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> ([TyVar], [TyVar])
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat GhcTc]
ps
go1 (SumPat XSumPat GhcTc
_ LPat GhcTc
p Int
_ Int
_) = LPat GhcTc -> ([TyVar], [TyVar])
go LPat GhcTc
p
go1 (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([TyVar], [TyVar])
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' }
= ([TyVar], [TyVar]) -> ([TyVar], [TyVar]) -> ([TyVar], [TyVar])
forall a a. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge (ConPatTc -> [TyVar]
cpt_tvs ConPatTc
XConPat GhcTc
con', ConPatTc -> [TyVar]
cpt_dicts ConPatTc
XConPat GhcTc
con') (([TyVar], [TyVar]) -> ([TyVar], [TyVar]))
-> ([TyVar], [TyVar]) -> ([TyVar], [TyVar])
forall a b. (a -> b) -> a -> b
$
HsConPatDetails GhcTc -> ([TyVar], [TyVar])
goConDetails (HsConPatDetails GhcTc -> ([TyVar], [TyVar]))
-> HsConPatDetails GhcTc -> ([TyVar], [TyVar])
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 -> ([TyVar], [TyVar])
go LPat GhcTc
p
go1 (XPat (CoPat _ p _)) = Pat GhcTc -> ([TyVar], [TyVar])
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 -> ([TyVar], [TyVar])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"TODO: NPlusKPat" (SDoc -> ([TyVar], [TyVar])) -> SDoc -> ([TyVar], [TyVar])
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnN TyVar
LIdP GhcTc
n SDoc -> SDoc -> SDoc
$$ GenLocated SrcSpan (HsOverLit GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (HsOverLit GhcTc)
XRec GhcTc (HsOverLit GhcTc)
k SDoc -> SDoc -> SDoc
$$ SyntaxExprTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExprTc
SyntaxExpr GhcTc
geq SDoc -> SDoc -> SDoc
$$ SyntaxExprTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExprTc
SyntaxExpr GhcTc
subtract
go1 Pat GhcTc
_ = ([TyVar], [TyVar])
forall a a. ([a], [a])
empty
goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [TyVar])
goConDetails (PrefixCon [HsPatSigType (NoGhcTc GhcTc)]
_ [LPat GhcTc]
ps) = [([TyVar], [TyVar])] -> ([TyVar], [TyVar])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([TyVar], [TyVar])] -> ([TyVar], [TyVar]))
-> ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([TyVar], [TyVar])])
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> ([TyVar], [TyVar])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcTc) -> ([TyVar], [TyVar]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [([TyVar], [TyVar])]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcTc) -> ([TyVar], [TyVar])
LPat GhcTc -> ([TyVar], [TyVar])
go ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> ([TyVar], [TyVar]))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> ([TyVar], [TyVar])
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat GhcTc]
ps
goConDetails (InfixCon LPat GhcTc
p1 LPat GhcTc
p2) = LPat GhcTc -> ([TyVar], [TyVar])
go LPat GhcTc
p1 ([TyVar], [TyVar]) -> ([TyVar], [TyVar]) -> ([TyVar], [TyVar])
forall a a. ([a], [a]) -> ([a], [a]) -> ([a], [a])
`merge` LPat GhcTc -> ([TyVar], [TyVar])
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 })
= [([TyVar], [TyVar])] -> ([TyVar], [TyVar])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([TyVar], [TyVar])] -> ([TyVar], [TyVar]))
-> ([GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [([TyVar], [TyVar])])
-> [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> ([TyVar], [TyVar])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))
-> ([TyVar], [TyVar]))
-> [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [([TyVar], [TyVar])]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))
-> ([TyVar], [TyVar])
LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [TyVar])
goRecFd ([GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> ([TyVar], [TyVar]))
-> [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> ([TyVar], [TyVar])
forall a b. (a -> b) -> a -> b
$ [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
[LHsRecField GhcTc (LPat GhcTc)]
flds
goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [TyVar])
goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = LPat GhcTc -> ([TyVar], [TyVar])
go GenLocated SrcSpanAnnA (Pat GhcTc)
LPat 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 (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 = ([], [])