{-# 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.Tc.Utils.Monad
import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId )
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.Data.Bag
import GHC.Utils.Misc
import GHC.Utils.Error
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
import Data.List( partition )
#include "GhclibHsVersions.h"
tcPatSynDecl :: PatSynBind GhcRn GhcRn
-> Maybe TcSigInfo
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl :: PatSynBind GhcRn GhcRn
-> Maybe TcSigInfo -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl PatSynBind GhcRn GhcRn
psb Maybe TcSigInfo
mb_sig
= TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (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 (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$
case Maybe TcSigInfo
mb_sig of
Maybe TcSigInfo
Nothing -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl PatSynBind GhcRn GhcRn
psb
Just (TcPatSynSig TcPatSynInfo
tpsi) -> PatSynBind GhcRn GhcRn
-> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl PatSynBind GhcRn GhcRn
psb TcPatSynInfo
tpsi
Maybe TcSigInfo
_ -> String -> TcRn (Bag (Located (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 (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (Located (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, TcGblEnv
gbl_env) }
where
([Name]
_arg_names, [Name]
_rec_fields, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], [Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
mk_placeholder :: Name -> PatSyn
mk_placeholder Name
matcher_name
= Name
-> Bool
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> ThetaType
-> Type
-> (Id, Bool)
-> Maybe (Id, Bool)
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
name Bool
is_infix
([Specificity -> Id -> InvisTVBinder
forall vis. vis -> Id -> VarBndr Id vis
mkTyVarBinder Specificity
SpecifiedSpec Id
alphaTyVar], []) ([], [])
[]
Type
alphaTy
(Id
matcher_id, Bool
True) Maybe (Id, Bool)
forall a. Maybe a
Nothing
[]
where
matcher_id :: Id
matcher_id = HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
matcher_name Type
Many (Type -> Id) -> Type -> Id
forall a b. (a -> b) -> a -> b
$
[Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] Type
alphaTy
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> 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 })
= Located Name
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. Located Name -> TcM a -> TcM a
addPatSynCtxt Located Name
LIdP GhcRn
lname (TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (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, [Name]
rec_fields, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], [Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
; (TcLevel
tclvl, WantedConstraints
wanted, ((Located (Pat GhcTc)
lpat', [Id]
args), Type
pat_ty))
<- TcM ((Located (Pat GhcTc), [Id]), Type)
-> TcM
(TcLevel, WantedConstraints, ((Located (Pat GhcTc), [Id]), Type))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM ((Located (Pat GhcTc), [Id]), Type)
-> TcM
(TcLevel, WantedConstraints, ((Located (Pat GhcTc), [Id]), Type)))
-> TcM ((Located (Pat GhcTc), [Id]), Type)
-> TcM
(TcLevel, WantedConstraints, ((Located (Pat GhcTc), [Id]), Type))
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcRn
-> LPat GhcRn -> TcM [Id] -> TcM ((LPat GhcTc, [Id]), 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 [Id] -> TcM ((LPat GhcTc, [Id]), Type))
-> TcM [Id] -> TcM ((LPat GhcTc, [Id]), Type)
forall a b. (a -> b) -> a -> b
$
(Name -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Name] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId [Name]
arg_names
; let ([Id]
ex_tvs, [Id]
prov_dicts) = LPat GhcTc -> ([Id], [Id])
tcCollectEx Located (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]
: (Id -> (Name, Type)) -> [Id] -> [(Name, Type)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> (Name, Type)
mk_named_tau [Id]
args
mk_named_tau :: Id -> (Name, Type)
mk_named_tau Id
arg
= (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
arg, [Id] -> Type -> Type
mkSpecForAllTys [Id]
ex_tvs (Id -> Type
varType Id
arg))
; ([Id]
univ_tvs, [Id]
req_dicts, TcEvBinds
ev_binds, WantedConstraints
residual, Bool
_)
<- TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM ([Id], [Id], TcEvBinds, WantedConstraints, 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 (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
top_ev_binds (TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$
do { [Id]
prov_dicts <- (Id -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Id] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
zonkId [Id]
prov_dicts
; let filtered_prov_dicts :: [Id]
filtered_prov_dicts = (Id -> Type) -> [Id] -> [Id]
forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs Id -> Type
evVarPred [Id]
prov_dicts
(ThetaType
prov_theta, [EvTerm]
prov_evs)
= [(Type, EvTerm)] -> (ThetaType, [EvTerm])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Id -> Maybe (Type, EvTerm)) -> [Id] -> [(Type, EvTerm)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Id -> Maybe (Type, EvTerm)
mkProvEvidence [Id]
filtered_prov_dicts)
req_theta :: ThetaType
req_theta = (Id -> Type) -> [Id] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
evVarPred [Id]
req_dicts
; [Id]
args <- (Id -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Id] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
zonkId [Id]
args
; let bad_args :: [(Id, DVarSet)]
bad_args = [ (Id
arg, DVarSet
bad_cos) | Id
arg <- [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
prov_dicts
, let bad_cos :: DVarSet
bad_cos = (Id -> Bool) -> DVarSet -> DVarSet
filterDVarSet Id -> Bool
isId (DVarSet -> DVarSet) -> DVarSet -> DVarSet
forall a b. (a -> b) -> a -> b
$
(Type -> DVarSet
tyCoVarsOfTypeDSet (Id -> Type
idType Id
arg))
, Bool -> Bool
not (DVarSet -> Bool
isEmptyDVarSet DVarSet
bad_cos) ]
; ((Id, DVarSet) -> TcRn ()) -> [(Id, DVarSet)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Id, DVarSet) -> TcRn ()
dependentArgErr [(Id, DVarSet)]
bad_args
; 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
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
ex_tvs)
; Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([InvisTVBinder], ThetaType, TcEvBinds, [Id])
-> ([InvisTVBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish Located Name
LIdP GhcRn
lname HsPatSynDir GhcRn
dir Bool
is_infix Located (Pat GhcTc)
LPat GhcTc
lpat'
(Specificity -> [Id] -> [InvisTVBinder]
forall vis. vis -> [Id] -> [VarBndr Id vis]
mkTyVarBinders Specificity
InferredSpec [Id]
univ_tvs
, ThetaType
req_theta, TcEvBinds
ev_binds, [Id]
req_dicts)
(Specificity -> [Id] -> [InvisTVBinder]
forall vis. vis -> [Id] -> [VarBndr Id vis]
mkTyVarBinders Specificity
InferredSpec [Id]
ex_tvs
, [Id] -> ThetaType
mkTyVarTys [Id]
ex_tvs, ThetaType
prov_theta, [EvTerm]
prov_evs)
((Id -> Located (HsExpr GhcTc)) -> [Id] -> [Located (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Located (HsExpr GhcTc)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [Id]
args, (Id -> Type) -> [Id] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
args)
Type
pat_ty [Name]
rec_fields } }
mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
mkProvEvidence :: Id -> Maybe (Type, EvTerm)
mkProvEvidence Id
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 (Id -> EvExpr
evId Id
ev_id))
where
pred :: Type
pred = Id -> Type
evVarPred Id
ev_id
eq_con_args :: [EvExpr]
eq_con_args = [Id -> EvExpr
evId Id
ev_id]
dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
dependentArgErr :: (Id, DVarSet) -> TcRn ()
dependentArgErr (Id
arg, DVarSet
bad_cos)
= SDoc -> TcRn ()
addErrTc (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 (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
arg))
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"has a type that mentions pattern-bound coercion"
SDoc -> SDoc -> SDoc
<> [Id] -> SDoc
forall a. [a] -> SDoc
plural [Id]
bad_co_list SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 ((Id -> SDoc) -> [Id] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bad_co_list)
, String -> SDoc
text String
"Hint: use -fprint-explicit-coercions to see the coercions"
, String -> SDoc
text String
"Probable fix: add a pattern signature" ]
where
bad_co_list :: [Id]
bad_co_list = DVarSet -> [Id]
dVarSetElems DVarSet
bad_cos
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPatSynInfo
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPatSynInfo -> 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_prov :: TcPatSynInfo -> ThetaType
patsig_prov = ThetaType
prov_theta
, patsig_ex_bndrs :: TcPatSynInfo -> [InvisTVBinder]
patsig_ex_bndrs = [InvisTVBinder]
explicit_ex_bndrs, patsig_req :: TcPatSynInfo -> ThetaType
patsig_req = ThetaType
req_theta
, patsig_body_ty :: TcPatSynInfo -> Type
patsig_body_ty = Type
sig_body_ty }
= Located Name
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a. Located Name -> TcM a -> TcM a
addPatSynCtxt Located Name
LIdP GhcRn
lname (TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv))
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall a b. (a -> b) -> a -> b
$
do { let decl_arity :: Int
decl_arity = [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
arg_names
([Name]
arg_names, [Name]
rec_fields, Bool
is_infix) = HsPatSynDetails GhcRn -> ([Name], [Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details
; 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 ]
; ([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 :: [Id]
bad_tvs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
pat_ty) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ [InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
explicit_ex_bndrs
; Bool -> SDoc -> TcRn ()
checkTc ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
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
<> [Id] -> SDoc
forall a. [a] -> SDoc
plural [Id]
bad_tvs
SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Id]
bad_tvs)
; let univ_fvs :: VarSet
univ_fvs = VarSet -> VarSet
closeOverKinds (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
(ThetaType -> VarSet
tyCoVarsOfTypes (Type
pat_ty Type -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
: ThetaType
req_theta) VarSet -> [Id] -> VarSet
`extendVarSetList` ([InvisTVBinder] -> [Id]
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 ((Id -> VarSet -> Bool
`elemVarSet` VarSet
univ_fvs) (Id -> Bool) -> (InvisTVBinder -> Id) -> InvisTVBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvisTVBinder -> Id
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 :: [Id]
univ_tvs = [InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
univ_bndrs
ex_tvs :: [Id]
ex_tvs = [InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
ex_bndrs
; [Id]
req_dicts <- ThetaType -> TcM [Id]
newEvVars ThetaType
req_theta
; (TcLevel
tclvl, WantedConstraints
wanted, (Located (Pat GhcTc)
lpat', ([Id]
ex_tvs', [EvTerm]
prov_dicts, [Located (HsExpr GhcTc)]
args'))) <-
ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcLevel, WantedConstraints,
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)])))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcLevel, WantedConstraints,
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))))
-> TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcLevel, WantedConstraints,
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)])))
forall a b. (a -> b) -> a -> b
$
[Id]
-> TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
-> TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
forall r. [Id] -> TcM r -> TcM r
tcExtendTyVarEnv [Id]
univ_tvs (TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
-> TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)])))
-> TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
-> TcM
(Located (Pat GhcTc), ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcRn
-> LPat GhcRn
-> Scaled Type
-> TcM ([Id], [EvTerm], [Located (HsExpr GhcTc)])
-> TcM (LPat GhcTc, ([Id], [EvTerm], [Located (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
pat_ty) (TcM ([Id], [EvTerm], [Located (HsExpr GhcTc)])
-> TcM (LPat GhcTc, ([Id], [EvTerm], [Located (HsExpr GhcTc)])))
-> TcM ([Id], [EvTerm], [Located (HsExpr GhcTc)])
-> TcM (LPat GhcTc, ([Id], [EvTerm], [Located (HsExpr GhcTc)]))
forall a b. (a -> b) -> a -> b
$
do { let in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([Id] -> VarSet
mkVarSet [Id]
univ_tvs)
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
; (TCvSubst
subst, [Id]
ex_tvs') <- (TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id))
-> TCvSubst
-> [Id]
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, [Id])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
newMetaTyVarX TCvSubst
empty_subst [Id]
ex_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn1" ([SDoc] -> SDoc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs])
; String -> SDoc -> TcRn ()
traceTc String
"tcpatsyn2" ([SDoc] -> SDoc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs'])
; let prov_theta' :: ThetaType
prov_theta' = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
subst ThetaType
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'
; [Located (HsExpr GhcTc)]
args' <- (Name
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc)))
-> [Name]
-> ThetaType
-> IOEnv (Env TcGblEnv TcLclEnv) [Located (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
subst) [Name]
arg_names ((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)
; ([Id], [EvTerm], [Located (HsExpr GhcTc)])
-> TcM ([Id], [EvTerm], [Located (HsExpr GhcTc)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ex_tvs', [EvTerm]
prov_dicts, [Located (HsExpr GhcTc)]
args') }
; let skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> Type -> [(Name, Id)] -> SkolemInfo
SigSkol (Name -> UserTypeCtxt
PatSynCtxt Name
name) Type
pat_ty []
; (Bag Implication
implics, TcEvBinds
ev_binds) <- TcLevel
-> SkolemInfo
-> [Id]
-> [Id]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tclvl SkolemInfo
skol_info [Id]
univ_tvs [Id]
req_dicts WantedConstraints
wanted
; Bag Implication -> TcRn ()
simplifyTopImplic Bag Implication
implics
; String -> SDoc -> TcRn ()
traceTc String
"tcCheckPatSynDecl }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
; Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([InvisTVBinder], ThetaType, TcEvBinds, [Id])
-> ([InvisTVBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish Located Name
LIdP GhcRn
lname HsPatSynDir GhcRn
dir Bool
is_infix Located (Pat GhcTc)
LPat GhcTc
lpat'
([InvisTVBinder]
univ_bndrs, ThetaType
req_theta, TcEvBinds
ev_binds, [Id]
req_dicts)
([InvisTVBinder]
ex_bndrs, [Id] -> ThetaType
mkTyVarTys [Id]
ex_tvs', ThetaType
prov_theta, [EvTerm]
prov_dicts)
([Located (HsExpr GhcTc)]
[LHsExpr GhcTc]
args', (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)
Type
pat_ty [Name]
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) (Located (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
arg_name) (IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc)))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do { Id
arg_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId Name
arg_name
; HsWrapper
wrap <- UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma UserTypeCtxt
GenSigCtxt
(Id -> Type
idType Id
arg_id)
(TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst Type
arg_ty)
; Located (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
arg_id) }
collectPatSynArgInfo :: HsPatSynDetails GhcRn
-> ([Name], [Name], Bool)
collectPatSynArgInfo :: HsPatSynDetails GhcRn -> ([Name], [Name], Bool)
collectPatSynArgInfo HsPatSynDetails GhcRn
details =
case HsPatSynDetails GhcRn
details of
PrefixCon [LIdP GhcRn]
names -> ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall l e. GenLocated l e -> e
unLoc [Located Name]
[LIdP GhcRn]
names, [], Bool
False)
InfixCon LIdP GhcRn
name1 LIdP GhcRn
name2 -> ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall l e. GenLocated l e -> e
unLoc [Located Name
LIdP GhcRn
name1, Located Name
LIdP GhcRn
name2], [], Bool
True)
RecCon [RecordPatSynField (LIdP GhcRn)]
names -> ([Name]
vars, [Name]
sels, Bool
False)
where
([Name]
vars, [Name]
sels) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip ((RecordPatSynField (Located Name) -> (Name, Name))
-> [RecordPatSynField (Located Name)] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField (Located Name) -> (Name, Name)
splitRecordPatSyn [RecordPatSynField (Located Name)]
[RecordPatSynField (LIdP GhcRn)]
names)
where
splitRecordPatSyn :: RecordPatSynField (Located Name)
-> (Name, Name)
splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
splitRecordPatSyn (RecordPatSynField
{ recordPatSynPatVar :: forall fld. RecordPatSynField fld -> fld
recordPatSynPatVar = L SrcSpan
_ Name
patVar
, recordPatSynSelectorId :: forall fld. RecordPatSynField fld -> fld
recordPatSynSelectorId = L SrcSpan
_ Name
selId })
= (Name
patVar, Name
selId)
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L SrcSpan
loc Name
name) TcM a
thing_inside
= SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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 :: Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])
-> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
-> ([LHsExpr GhcTc], [TcType])
-> TcType
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish :: Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([InvisTVBinder], ThetaType, TcEvBinds, [Id])
-> ([InvisTVBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish Located Name
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
lpat'
([InvisTVBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
([InvisTVBinder]
ex_tvs, ThetaType
ex_tys, ThetaType
prov_theta, [EvTerm]
prov_dicts)
([LHsExpr GhcTc]
args, ThetaType
arg_tys)
Type
pat_ty [Name]
field_labels
= do {
(ZonkEnv
ze, [InvisTVBinder]
univ_tvs') <- [InvisTVBinder] -> TcM (ZonkEnv, [InvisTVBinder])
forall vis. [VarBndr Id vis] -> TcM (ZonkEnv, [VarBndr Id vis])
zonkTyVarBinders [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 Id vis] -> TcM (ZonkEnv, [VarBndr Id 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 Id vis] -> (TidyEnv, [VarBndr Id vis])
tidyTyCoVarBinders TidyEnv
emptyTidyEnv [InvisTVBinder]
univ_tvs'
(TidyEnv
env2, [InvisTVBinder]
ex_tvs) = TidyEnv -> [InvisTVBinder] -> (TidyEnv, [InvisTVBinder])
forall vis.
TidyEnv -> [VarBndr Id vis] -> (TidyEnv, [VarBndr Id 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 (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
lname) SDoc -> SDoc -> SDoc
$$ Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Located (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc Located (Pat GhcTc)
LPat GhcTc
lpat') SDoc -> SDoc -> SDoc
$$
([InvisTVBinder], ThetaType, TcEvBinds, [Id]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([InvisTVBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [Id]
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
$$
[Located (HsExpr GhcTc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located (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
; ((Id, Bool)
matcher_id, Bag (Located (HsBindLR GhcTc GhcTc))
matcher_bind) <- Located Name
-> LPat GhcTc
-> ([Id], ThetaType, TcEvBinds, [Id])
-> ([Id], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> TcM ((Id, Bool), LHsBinds GhcTc)
tcPatSynMatcher Located Name
lname LPat GhcTc
lpat'
([InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
([InvisTVBinder] -> [Id]
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
; Maybe (Id, Bool)
builder_id <- HsPatSynDir GhcRn
-> Located Name
-> [InvisTVBinder]
-> ThetaType
-> [InvisTVBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM (Maybe (Id, Bool))
forall a.
HsPatSynDir a
-> Located Name
-> [InvisTVBinder]
-> ThetaType
-> [InvisTVBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM (Maybe (Id, Bool))
mkPatSynBuilderId HsPatSynDir GhcRn
dir Located Name
lname
[InvisTVBinder]
univ_tvs ThetaType
req_theta
[InvisTVBinder]
ex_tvs ThetaType
prov_theta
ThetaType
arg_tys Type
pat_ty
; let mkFieldLabel :: Name -> FieldLabel
mkFieldLabel Name
name = FieldLabel :: forall a. FieldLabelString -> Bool -> a -> FieldLbl a
FieldLabel { flLabel :: FieldLabelString
flLabel = OccName -> FieldLabelString
occNameFS (Name -> OccName
nameOccName Name
name)
, flIsOverloaded :: Bool
flIsOverloaded = Bool
False
, flSelector :: Name
flSelector = Name
name }
field_labels' :: [FieldLabel]
field_labels' = (Name -> FieldLabel) -> [Name] -> [FieldLabel]
forall a b. (a -> b) -> [a] -> [b]
map Name -> FieldLabel
mkFieldLabel [Name]
field_labels
; let patSyn :: PatSyn
patSyn = Name
-> Bool
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> ThetaType
-> Type
-> (Id, Bool)
-> Maybe (Id, Bool)
-> [FieldLabel]
-> PatSyn
mkPatSyn (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
lname) Bool
is_infix
([InvisTVBinder]
univ_tvs, ThetaType
req_theta)
([InvisTVBinder]
ex_tvs, ThetaType
prov_theta)
ThetaType
arg_tys
Type
pat_ty
(Id, Bool)
matcher_id Maybe (Id, Bool)
builder_id
[FieldLabel]
field_labels'
; let rn_rec_sel_binds :: [(Id, LHsBind GhcRn)]
rn_rec_sel_binds = PatSyn -> [FieldLabel] -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
patSyn (PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
patSyn)
tything :: TyThing
tything = ConLike -> TyThing
AConLike (PatSyn -> ConLike
PatSynCon PatSyn
patSyn)
; TcGblEnv
tcg_env <- [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
tything] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
[(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds [(Id, LHsBind GhcRn)]
rn_rec_sel_binds
; String -> SDoc -> TcRn ()
traceTc String
"tc_patsyn_finish }" SDoc
empty
; (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
-> TcRn (Bag (Located (HsBindLR GhcTc GhcTc)), TcGblEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (Located (HsBindLR GhcTc GhcTc))
matcher_bind, TcGblEnv
tcg_env) }
tcPatSynMatcher :: Located Name
-> LPat GhcTc
-> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
-> ([TcTyVar], [TcType], ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], [TcType])
-> TcType
-> TcM ((Id, Bool), LHsBinds GhcTc)
tcPatSynMatcher :: Located Name
-> LPat GhcTc
-> ([Id], ThetaType, TcEvBinds, [Id])
-> ([Id], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> TcM ((Id, Bool), LHsBinds GhcTc)
tcPatSynMatcher (L SrcSpan
loc Name
name) LPat GhcTc
lpat
([Id]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
([Id]
ex_tvs, ThetaType
ex_tys, ThetaType
prov_theta, [EvTerm]
prov_dicts)
([LHsExpr GhcTc]
args, ThetaType
arg_tys) Type
pat_ty
= do { 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 :: Id
rr_tv = Name -> Type -> Id
mkTyVar Name
rr_name Type
runtimeRepTy
rr :: Type
rr = Id -> Type
mkTyVarTy Id
rr_tv
res_tv :: Id
res_tv = Name -> Type -> Id
mkTyVar Name
tv_name (Type -> Type
tYPE Type
rr)
res_ty :: Type
res_ty = Id -> Type
mkTyVarTy Id
res_tv
is_unlifted :: Bool
is_unlifted = [Located (HsExpr GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (HsExpr GhcTc)]
[LHsExpr GhcTc]
args Bool -> Bool -> Bool
&& [EvTerm] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvTerm]
prov_dicts
([Located (HsExpr GhcTc)]
cont_args, ThetaType
cont_arg_tys)
| Bool
is_unlifted = ([IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
voidPrimId], [Type
unboxedUnitTy])
| Bool
otherwise = ([Located (HsExpr GhcTc)]
[LHsExpr GhcTc]
args, ThetaType
arg_tys)
cont_ty :: Type
cont_ty = [Id] -> ThetaType -> Type -> Type
mkInfSigmaTy [Id]
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
; Id
scrutinee <- FieldLabelString
-> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl.
FieldLabelString -> Type -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FieldLabelString
fsLit String
"scrut") Type
Many Type
pat_ty
; Id
cont <- FieldLabelString
-> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl.
FieldLabelString -> Type -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FieldLabelString
fsLit String
"cont") Type
Many Type
cont_ty
; Id
fail <- FieldLabelString
-> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl.
FieldLabelString -> Type -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FieldLabelString
fsLit String
"fail") Type
Many Type
fail_ty
; 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 = [Id] -> ThetaType -> Type -> Type
mkInfSigmaTy (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs) ThetaType
req_theta Type
matcher_tau
matcher_id :: Id
matcher_id = Name -> Type -> Id
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' :: Located (HsExpr GhcTc)
cont' = (Located (HsExpr GhcTc)
-> Located (HsExpr GhcTc) -> Located (HsExpr GhcTc))
-> Located (HsExpr GhcTc)
-> [Located (HsExpr GhcTc)]
-> Located (HsExpr GhcTc)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Located (HsExpr GhcTc)
-> Located (HsExpr GhcTc) -> Located (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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
cont)) [Located (HsExpr GhcTc)]
cont_args
fail' :: LHsExpr GhcTc
fail' = IdP GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps Id
IdP GhcTc
fail [IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
voidPrimId]
args :: [Located (Pat GhcTc)]
args = (Id -> Located (Pat GhcTc)) -> [Id] -> [Located (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Located (Pat GhcTc)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [Id
scrutinee, Id
cont, Id
fail]
lwpat :: Located (Pat GhcTc)
lwpat = Pat GhcTc -> Located (Pat GhcTc)
forall e. e -> Located e
noLoc (Pat GhcTc -> Located (Pat GhcTc))
-> Pat GhcTc -> Located (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 :: [Located (Match GhcTc (Located (HsExpr GhcTc)))]
cases = if LPat GhcTc -> Bool
forall (p :: Pass). OutputableBndrId p => LPat (GhcPass p) -> Bool
isIrrefutableHsPat LPat GhcTc
lpat
then [LPat GhcTc
-> Located (HsExpr GhcTc) -> LMatch GhcTc (Located (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat Located (HsExpr GhcTc)
cont']
else [LPat GhcTc
-> Located (HsExpr GhcTc) -> LMatch GhcTc (Located (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat Located (HsExpr GhcTc)
cont',
LPat GhcTc
-> Located (HsExpr GhcTc) -> LMatch GhcTc (Located (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt Located (Pat GhcTc)
LPat GhcTc
lwpat Located (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
$
SrcSpan -> HsExpr GhcTc -> Located (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (Located (Pat GhcTc) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (Pat GhcTc)
LPat GhcTc
lpat) (HsExpr GhcTc -> Located (HsExpr GhcTc))
-> HsExpr GhcTc -> Located (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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
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 (Located (HsExpr GhcTc))]
mg_alts = SrcSpan
-> [Located (Match GhcTc (Located (HsExpr GhcTc)))]
-> GenLocated
SrcSpan [Located (Match GhcTc (Located (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (Located (Pat GhcTc) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (Pat GhcTc)
LPat GhcTc
lpat) [Located (Match GhcTc (Located (HsExpr GhcTc)))]
cases
, mg_ext :: XMG GhcTc (Located (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' :: Located (HsExpr GhcTc)
body' = HsExpr GhcTc -> Located (HsExpr GhcTc)
forall e. e -> Located e
noLoc (HsExpr GhcTc -> Located (HsExpr GhcTc))
-> HsExpr GhcTc -> Located (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 (Located (HsExpr GhcTc))]
mg_alts = [Located (Match GhcTc (Located (HsExpr GhcTc)))]
-> GenLocated
SrcSpan [Located (Match GhcTc (Located (HsExpr GhcTc)))]
forall e. e -> Located e
noLoc [HsMatchContext (NoGhcTc GhcTc)
-> [LPat GhcTc]
-> Located (HsExpr GhcTc)
-> LMatch GhcTc (Located (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NoGhcTc GhcTc)
forall p. HsMatchContext p
LambdaExpr
[Located (Pat GhcTc)]
[LPat GhcTc]
args Located (HsExpr GhcTc)
LHsExpr GhcTc
body]
, mg_ext :: XMG GhcTc (Located (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
-> Located (HsLocalBinds GhcTc)
-> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
name)) []
([Id] -> [Id] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs)
[Id]
req_dicts Located (HsExpr GhcTc)
LHsExpr GhcTc
body')
(HsLocalBinds GhcTc -> Located (HsLocalBinds GhcTc)
forall e. e -> Located e
noLoc (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 (Located (HsExpr GhcTc))]
mg_alts = SrcSpan
-> [Located (Match GhcTc (Located (HsExpr GhcTc)))]
-> GenLocated
SrcSpan [Located (Match GhcTc (Located (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L (Located (Match GhcTc (Located (HsExpr GhcTc))) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (Match GhcTc (Located (HsExpr GhcTc)))
LMatch GhcTc (LHsExpr GhcTc)
match) [Located (Match GhcTc (Located (HsExpr GhcTc)))
LMatch GhcTc (LHsExpr GhcTc)
match]
, mg_ext :: XMG GhcTc (Located (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc [] Type
res_ty
, mg_origin :: Origin
mg_origin = Origin
Generated
}
; let bind :: HsBindLR GhcTc GhcTc
bind = FunBind :: forall idL idR.
XFunBind idL idR
-> LIdP idL
-> MatchGroup idR (LHsExpr idR)
-> [Tickish Id]
-> HsBindLR idL idR
FunBind{ fun_id :: LIdP GhcTc
fun_id = SrcSpan -> Id -> GenLocated SrcSpan Id
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Id
matcher_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 :: [Tickish Id]
fun_tick = [] }
matcher_bind :: Bag (Located (HsBindLR GhcTc GhcTc))
matcher_bind = Located (HsBindLR GhcTc GhcTc)
-> Bag (Located (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (HsBindLR GhcTc GhcTc -> Located (HsBindLR GhcTc GhcTc)
forall e. e -> Located e
noLoc 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 (Id -> Type
idType Id
matcher_id))
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynMatcher" (Bag (Located (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (Located (HsBindLR GhcTc GhcTc))
matcher_bind)
; ((Id, Bool), Bag (Located (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((Id, Bool), Bag (Located (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id
matcher_id, Bool
is_unlifted), Bag (Located (HsBindLR GhcTc GhcTc))
matcher_bind) }
mkPatSynRecSelBinds :: PatSyn
-> [FieldLabel]
-> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
ps [FieldLabel]
fields
= [ [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn)
mkOneRecordSelector [PatSyn -> ConLike
PatSynCon PatSyn
ps] (PatSyn -> RecSelParent
RecSelPatSyn PatSyn
ps) FieldLabel
fld_lbl
| 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
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
-> [InvisTVBinder] -> ThetaType
-> [InvisTVBinder] -> ThetaType
-> [Type] -> Type
-> TcM (Maybe (Id, Bool))
mkPatSynBuilderId :: HsPatSynDir a
-> Located Name
-> [InvisTVBinder]
-> ThetaType
-> [InvisTVBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM (Maybe (Id, Bool))
mkPatSynBuilderId HsPatSynDir a
dir (L SrcSpan
_ 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
= Maybe (Id, Bool) -> TcM (Maybe (Id, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Bool)
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
builder_id :: Id
builder_id = Name -> Type -> Id
mkExportedVanillaId Name
builder_name Type
builder_sigma
builder_id' :: Id
builder_id' = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
pat_ty) Id
builder_id
; Maybe (Id, Bool) -> TcM (Maybe (Id, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id, Bool) -> Maybe (Id, Bool)
forall a. a -> Maybe a
Just (Id
builder_id', Bool
need_dummy_arg)) }
tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
-> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L loc 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 (Located (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (Located (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag
| Left SDoc
why <- Either SDoc (MatchGroup GhcRn (Located (HsExpr GhcRn)))
mb_match_group
= SrcSpan
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpan (Pat GhcRn) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
lpat) (IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$ SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
forall a. SDoc -> TcM a
failWithTc (SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc))))
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (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
name) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 SDoc
why
, String -> SDoc
text String
"RHS pattern:" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpan (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
lpat ]
| Right MatchGroup GhcRn (Located (HsExpr GhcRn))
match_group <- Either SDoc (MatchGroup GhcRn (Located (HsExpr GhcRn)))
mb_match_group
= do { PatSyn
patsyn <- Name -> TcM PatSyn
tcLookupPatSyn Name
name
; case PatSyn -> Maybe (Id, Bool)
patSynBuilder PatSyn
patsyn of {
Maybe (Id, Bool)
Nothing -> Bag (Located (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (Located (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag ;
Just (Id
builder_id, Bool
need_dummy_arg) ->
do {
let match_group' :: MatchGroup GhcRn (Located (HsExpr GhcRn))
match_group' | Bool
need_dummy_arg = MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg MatchGroup GhcRn (Located (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
match_group
| Bool
otherwise = MatchGroup GhcRn (Located (HsExpr GhcRn))
match_group
bind :: HsBindLR GhcRn GhcRn
bind = FunBind :: forall idL idR.
XFunBind idL idR
-> LIdP idL
-> MatchGroup idR (LHsExpr idR)
-> [Tickish Id]
-> HsBindLR idL idR
FunBind { fun_id :: LIdP GhcRn
fun_id = SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Id -> Name
idName Id
builder_id)
, fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches = MatchGroup GhcRn (Located (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
match_group'
, fun_ext :: XFunBind GhcRn GhcRn
fun_ext = NameSet
XFunBind GhcRn GhcRn
emptyNameSet
, fun_tick :: [Tickish Id]
fun_tick = [] }
sig :: TcIdSigInfo
sig = UserTypeCtxt -> Id -> TcIdSigInfo
completeSigFromId (Name -> UserTypeCtxt
PatSynCtxt Name
name) Id
builder_id
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
patsyn SDoc -> SDoc -> SDoc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
builder_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
builder_id)
; (Bag (Located (HsBindLR GhcTc GhcTc))
builder_binds, [Id]
_) <- TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [Id])
tcPolyCheck TcPragEnv
emptyPragEnv TcIdSigInfo
sig (HsBindLR GhcRn GhcRn -> Located (HsBindLR GhcRn GhcRn)
forall e. e -> Located e
noLoc HsBindLR GhcRn GhcRn
bind)
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynBuilderBind }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bag (Located (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (Located (HsBindLR GhcTc GhcTc))
builder_binds
; Bag (Located (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (Located (HsBindLR GhcTc GhcTc))
builder_binds } } }
#if __GLASGOW_HASKELL__ <= 810
| Bool
otherwise = String
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (Located (HsBindLR GhcTc GhcTc)))
forall a. String -> a
panic String
"tcPatSynBuilderBind"
#endif
where
mb_match_group :: Either SDoc (MatchGroup GhcRn (Located (HsExpr GhcRn)))
mb_match_group
= case HsPatSynDir GhcRn
dir of
ExplicitBidirectional MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg -> MatchGroup GhcRn (Located (HsExpr GhcRn))
-> Either SDoc (MatchGroup GhcRn (Located (HsExpr GhcRn)))
forall a b. b -> Either a b
Right MatchGroup GhcRn (Located (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg
HsPatSynDir GhcRn
ImplicitBidirectional -> (Located (HsExpr GhcRn)
-> MatchGroup GhcRn (Located (HsExpr GhcRn)))
-> Either SDoc (Located (HsExpr GhcRn))
-> Either SDoc (MatchGroup GhcRn (Located (HsExpr GhcRn)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located (HsExpr GhcRn) -> MatchGroup GhcRn (Located (HsExpr GhcRn))
LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg (Name -> [Located Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
name [Located Name]
args LPat GhcRn
lpat)
HsPatSynDir GhcRn
Unidirectional -> String -> Either SDoc (MatchGroup GhcRn (Located (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
-> [Located (Match GhcRn (Located (HsExpr GhcRn)))]
-> MatchGroup GhcRn (Located (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
(XMG (GhcPass p) (Located (body (GhcPass p))) ~ NoExtField) =>
Origin
-> [Located (Match (GhcPass p) (Located (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (Located (body (GhcPass p)))
mkMatchGroup Origin
Generated [Located (Match GhcRn (Located (HsExpr GhcRn)))
LMatch GhcRn (LHsExpr GhcRn)
builder_match]
where
builder_args :: [GenLocated SrcSpan (Pat GhcRn)]
builder_args = [SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVarPat GhcRn -> LIdP GhcRn -> Pat GhcRn
forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
XVarPat GhcRn
noExtField (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
n))
| L SrcSpan
loc Name
n <- [Located Name]
args]
builder_match :: LMatch GhcRn (LHsExpr GhcRn)
builder_match = HsMatchContext (NoGhcTc GhcRn)
-> [LPat GhcRn]
-> LHsExpr GhcRn
-> Located (HsLocalBinds GhcRn)
-> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
name))
[GenLocated SrcSpan (Pat GhcRn)]
[LPat GhcRn]
builder_args LHsExpr GhcRn
body
(HsLocalBinds GhcRn -> Located (HsLocalBinds GhcRn)
forall e. e -> Located e
noLoc (XEmptyLocalBinds GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcRn GhcRn
noExtField))
args :: [Located Name]
args = case HsPatSynDetails GhcRn
details of
PrefixCon [LIdP GhcRn]
args -> [Located Name]
[LIdP GhcRn]
args
InfixCon LIdP GhcRn
arg1 LIdP GhcRn
arg2 -> [Located Name
LIdP GhcRn
arg1, Located Name
LIdP GhcRn
arg2]
RecCon [RecordPatSynField (LIdP GhcRn)]
args -> (RecordPatSynField (Located Name) -> Located Name)
-> [RecordPatSynField (Located Name)] -> [Located Name]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField (Located Name) -> Located Name
forall fld. RecordPatSynField fld -> fld
recordPatSynPatVar [RecordPatSynField (Located Name)]
[RecordPatSynField (LIdP 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 (Located (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
mg { mg_alts :: XRec GhcRn [LMatch GhcRn (Located (HsExpr GhcRn))]
mg_alts = SrcSpan
-> [Located (Match GhcRn (Located (HsExpr GhcRn)))]
-> GenLocated
SrcSpan [Located (Match GhcRn (Located (HsExpr GhcRn)))]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [SrcSpan
-> Match GhcRn (Located (HsExpr GhcRn))
-> Located (Match GhcRn (Located (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Match GhcRn (Located (HsExpr GhcRn))
match { m_pats :: [LPat GhcRn]
m_pats = GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
nlWildPatName GenLocated SrcSpan (Pat GhcRn)
-> [GenLocated SrcSpan (Pat GhcRn)]
-> [GenLocated SrcSpan (Pat GhcRn)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpan (Pat GhcRn)]
[LPat GhcRn]
pats })] }
add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
other_mg = String -> SDoc -> MatchGroup GhcRn (Located (HsExpr GhcRn))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"add_dummy_arg" (SDoc -> MatchGroup GhcRn (Located (HsExpr GhcRn)))
-> SDoc -> MatchGroup GhcRn (Located (HsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$
MatchGroup GhcRn (Located (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (Located (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
other_mg
patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, Type)
patSynBuilderOcc PatSyn
ps
| Just (Id
builder_id, Bool
add_void_arg) <- PatSyn -> Maybe (Id, Bool)
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)
builder_ty :: Type
builder_ty = Id -> Type
idType Id
builder_id
= (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 -> [Located Name] -> LPat GhcRn
-> Either MsgDoc (LHsExpr GhcRn)
tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
name [Located Name]
args LPat GhcRn
pat = LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go LPat GhcRn
pat
where
lhsVars :: NameSet
lhsVars = [Name] -> NameSet
mkNameSet ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall l e. GenLocated l e -> e
unLoc [Located Name]
args)
mkPrefixConExpr :: Located Name -> [LPat GhcRn]
-> Either MsgDoc (HsExpr GhcRn)
mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr lcon :: Located Name
lcon@(L SrcSpan
loc Name
_) [LPat GhcRn]
pats
= do { [Located (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn)))
-> [GenLocated SrcSpan (Pat GhcRn)]
-> Either SDoc [Located (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn))
LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [GenLocated SrcSpan (Pat GhcRn)]
[LPat GhcRn]
pats
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsExpr GhcRn -> Located (HsExpr GhcRn) -> HsExpr GhcRn)
-> HsExpr GhcRn -> [Located (HsExpr GhcRn)] -> HsExpr GhcRn
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\HsExpr GhcRn
x Located (HsExpr GhcRn)
y -> XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcRn
noExtField (SrcSpan -> HsExpr GhcRn -> Located (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcRn
x) Located (HsExpr GhcRn)
LHsExpr GhcRn
y)
(XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField Located Name
LIdP GhcRn
lcon) [Located (HsExpr GhcRn)]
exprs) }
mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
-> Either MsgDoc (HsExpr GhcRn)
mkRecordConExpr :: Located Name
-> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn)
mkRecordConExpr Located Name
con HsRecFields GhcRn (LPat GhcRn)
fields
= do { HsRecFields GhcRn (Located (HsExpr GhcRn))
exprFields <- (GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn)))
-> HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
-> Either SDoc (HsRecFields GhcRn (Located (HsExpr GhcRn)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn))
LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
HsRecFields GhcRn (LPat GhcRn)
fields
; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRecordCon GhcRn
-> LIdP GhcRn -> HsRecordBinds GhcRn -> HsExpr GhcRn
forall p. XRecordCon p -> LIdP p -> HsRecordBinds p -> HsExpr p
RecordCon NoExtField
XRecordCon GhcRn
noExtField Located Name
LIdP GhcRn
con HsRecFields GhcRn (Located (HsExpr GhcRn))
HsRecordBinds GhcRn
exprFields) }
go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go (L loc p) = SrcSpan -> HsExpr GhcRn -> Located (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcRn -> Located (HsExpr GhcRn))
-> Either SDoc (HsExpr GhcRn)
-> Either SDoc (Located (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 MsgDoc (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 [LPat GhcRn]
ps -> Located Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr Located Name
XRec GhcRn (ConLikeP GhcRn)
con [LPat GhcRn]
ps
InfixCon LPat GhcRn
l LPat GhcRn
r -> Located Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr Located Name
XRec GhcRn (ConLikeP GhcRn)
con [LPat GhcRn
l,LPat GhcRn
r]
RecCon HsRecFields GhcRn (LPat GhcRn)
fields -> Located Name
-> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn)
mkRecordConExpr Located 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 SrcSpan (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (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 (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
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) = (Located (HsExpr GhcRn) -> HsExpr GhcRn)
-> Either SDoc (Located (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 NoExtField
XPar GhcRn
noExtField) (Either SDoc (Located (HsExpr GhcRn))
-> Either SDoc (HsExpr GhcRn))
-> Either SDoc (Located (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 { [Located (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn)))
-> [GenLocated SrcSpan (Pat GhcRn)]
-> Either SDoc [Located (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn))
LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [GenLocated SrcSpan (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
-> Maybe (SyntaxExpr GhcRn) -> [LHsExpr GhcRn] -> HsExpr GhcRn
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList NoExtField
XExplicitList GhcRn
noExtField Maybe (SyntaxExpr GhcRn)
forall a. Maybe a
Nothing [Located (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 { [Located (HsExpr GhcRn)]
exprs <- (GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn)))
-> [GenLocated SrcSpan (Pat GhcRn)]
-> Either SDoc [Located (HsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan (Pat GhcRn)
-> Either SDoc (Located (HsExpr GhcRn))
LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [GenLocated SrcSpan (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 -> [LHsTupArg GhcRn] -> Boxity -> HsExpr GhcRn
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
XExplicitTuple GhcRn
noExtField
((Located (HsExpr GhcRn) -> Located (HsTupArg GhcRn))
-> [Located (HsExpr GhcRn)] -> [Located (HsTupArg GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsTupArg GhcRn -> Located (HsTupArg GhcRn)
forall e. e -> Located e
noLoc (HsTupArg GhcRn -> Located (HsTupArg GhcRn))
-> (Located (HsExpr GhcRn) -> HsTupArg GhcRn)
-> Located (HsExpr GhcRn)
-> Located (HsTupArg GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XPresent GhcRn -> LHsExpr GhcRn -> HsTupArg GhcRn
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent GhcRn
noExtField)) [Located (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 SrcSpan (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (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 -> Located (HsExpr GhcRn)
forall e. e -> Located e
noLoc 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 NoExtField
XLitE GhcRn
noExtField 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
$ Located (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc (Located (HsExpr GhcRn) -> HsExpr GhcRn)
-> Located (HsExpr GhcRn) -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ (Located (HsExpr GhcRn)
-> Located (HsExpr GhcRn) -> Located (HsExpr GhcRn))
-> Located (HsExpr GhcRn)
-> [Located (HsExpr GhcRn)]
-> Located (HsExpr GhcRn)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Located (HsExpr GhcRn)
-> Located (HsExpr GhcRn) -> Located (HsExpr GhcRn)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsExpr GhcRn -> Located (HsExpr GhcRn)
forall e. e -> Located e
noLoc HsExpr GhcRn
neg)
[HsExpr GhcRn -> Located (HsExpr GhcRn)
forall e. e -> Located e
noLoc (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit NoExtField
XOverLitE GhcRn
noExtField 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 NoExtField
XOverLitE GhcRn
noExtField 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 SrcSpan (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (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 ((Located Name -> SDoc) -> [Located Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located 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 -> ([Id], [Id])
tcCollectEx LPat GhcTc
pat = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
pat
where
go :: LPat GhcTc -> ([TyVar], [EvVar])
go :: LPat GhcTc -> ([Id], [Id])
go = Pat GhcTc -> ([Id], [Id])
go1 (Pat GhcTc -> ([Id], [Id]))
-> (Located (Pat GhcTc) -> Pat GhcTc)
-> Located (Pat GhcTc)
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc
go1 :: Pat GhcTc -> ([TyVar], [EvVar])
go1 :: Pat GhcTc -> ([Id], [Id])
go1 (LazyPat XLazyPat GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (AsPat XAsPat GhcTc
_ LIdP GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (ParPat XParPat GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (BangPat XBangPat GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (ListPat XListPat GhcTc
_ [LPat GhcTc]
ps) = [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([Located (Pat GhcTc)] -> [([Id], [Id])])
-> [Located (Pat GhcTc)]
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (Pat GhcTc) -> ([Id], [Id]))
-> [Located (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcTc) -> ([Id], [Id])
LPat GhcTc -> ([Id], [Id])
go ([Located (Pat GhcTc)] -> ([Id], [Id]))
-> [Located (Pat GhcTc)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [Located (Pat GhcTc)]
[LPat GhcTc]
ps
go1 (TuplePat XTuplePat GhcTc
_ [LPat GhcTc]
ps Boxity
_) = [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([Located (Pat GhcTc)] -> [([Id], [Id])])
-> [Located (Pat GhcTc)]
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (Pat GhcTc) -> ([Id], [Id]))
-> [Located (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcTc) -> ([Id], [Id])
LPat GhcTc -> ([Id], [Id])
go ([Located (Pat GhcTc)] -> ([Id], [Id]))
-> [Located (Pat GhcTc)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [Located (Pat GhcTc)]
[LPat GhcTc]
ps
go1 (SumPat XSumPat GhcTc
_ LPat GhcTc
p Int
_ Int
_) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ LPat GhcTc
p) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 con :: Pat GhcTc
con@ConPat{ pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = XConPat GhcTc
con' }
= ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall a a. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge (ConPatTc -> [Id]
cpt_tvs ConPatTc
XConPat GhcTc
con', ConPatTc -> [Id]
cpt_dicts ConPatTc
XConPat GhcTc
con') (([Id], [Id]) -> ([Id], [Id])) -> ([Id], [Id]) -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (HsConPatDetails GhcTc -> ([Id], [Id]))
-> HsConPatDetails GhcTc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ Pat GhcTc -> HsConPatDetails GhcTc
forall p. Pat p -> HsConPatDetails p
pat_args Pat GhcTc
con
go1 (SigPat XSigPat GhcTc
_ LPat GhcTc
p HsPatSigType (NoGhcTc GhcTc)
_) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
go1 (XPat (CoPat _ p _)) = Pat GhcTc -> ([Id], [Id])
go1 Pat GhcTc
p
go1 (NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
n XRec GhcTc (HsOverLit GhcTc)
k HsOverLit GhcTc
_ SyntaxExpr GhcTc
geq SyntaxExpr GhcTc
subtract)
= String -> SDoc -> ([Id], [Id])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"TODO: NPlusKPat" (SDoc -> ([Id], [Id])) -> SDoc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan Id
LIdP GhcTc
n SDoc -> SDoc -> SDoc
$$ Located (HsOverLit GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (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
_ = ([Id], [Id])
forall a a. ([a], [a])
empty
goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
goConDetails :: HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (PrefixCon [LPat GhcTc]
ps) = [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([Located (Pat GhcTc)] -> [([Id], [Id])])
-> [Located (Pat GhcTc)]
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (Pat GhcTc) -> ([Id], [Id]))
-> [Located (Pat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcTc) -> ([Id], [Id])
LPat GhcTc -> ([Id], [Id])
go ([Located (Pat GhcTc)] -> ([Id], [Id]))
-> [Located (Pat GhcTc)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [Located (Pat GhcTc)]
[LPat GhcTc]
ps
goConDetails (InfixCon LPat GhcTc
p1 LPat GhcTc
p2) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p1 ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall a a. ([a], [a]) -> ([a], [a]) -> ([a], [a])
`merge` LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p2
goConDetails (RecCon HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcTc (LPat GhcTc)]
flds })
= [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LHsRecField GhcTc (Located (Pat GhcTc))] -> [([Id], [Id])])
-> [LHsRecField GhcTc (Located (Pat GhcTc))]
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsRecField GhcTc (Located (Pat GhcTc)) -> ([Id], [Id]))
-> [LHsRecField GhcTc (Located (Pat GhcTc))] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LHsRecField GhcTc (Located (Pat GhcTc)) -> ([Id], [Id])
LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
goRecFd ([LHsRecField GhcTc (Located (Pat GhcTc))] -> ([Id], [Id]))
-> [LHsRecField GhcTc (Located (Pat GhcTc))] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LHsRecField GhcTc (Located (Pat GhcTc))]
[LHsRecField GhcTc (LPat GhcTc)]
flds
goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
goRecFd (L SrcSpan
_ HsRecField{ hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LPat GhcTc
p }) = LPat GhcTc -> ([Id], [Id])
go 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 = ([], [])