module GHC.Core.PatSyn (
PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,
patSynName, patSynArity, patSynIsInfix, patSynResultType,
isVanillaPatSyn,
patSynArgs,
patSynMatcher, patSynBuilder,
patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders,
patSynSig, patSynSigBndr,
patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType,
pprPatSynType
) where
import GHC.Prelude
import GHC.Core.Type
import GHC.Core.TyCo.Ppr
import GHC.Types.Name
import GHC.Types.Unique
import GHC.Types.Basic
import GHC.Types.Var
import GHC.Types.FieldLabel
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.Data as Data
import Data.Function
import Data.List (find)
data PatSyn
= MkPatSyn {
PatSyn -> Name
psName :: Name,
PatSyn -> Unique
psUnique :: Unique,
PatSyn -> [Type]
psArgs :: [FRRType],
PatSyn -> Arity
psArity :: Arity,
PatSyn -> Bool
psInfix :: Bool,
PatSyn -> [FieldLabel]
psFieldLabels :: [FieldLabel],
PatSyn -> [InvisTVBinder]
psUnivTyVars :: [InvisTVBinder],
PatSyn -> [Type]
psReqTheta :: ThetaType,
PatSyn -> [InvisTVBinder]
psExTyVars :: [InvisTVBinder],
PatSyn -> [Type]
psProvTheta :: ThetaType,
PatSyn -> Type
psResultTy :: Type,
PatSyn -> PatSynMatcher
psMatcher :: PatSynMatcher,
PatSyn -> PatSynBuilder
psBuilder :: PatSynBuilder
}
type PatSynMatcher = (Name, Type, Bool)
type PatSynBuilder = Maybe (Name, Type, Bool)
instance Eq PatSyn where
== :: PatSyn -> PatSyn -> Bool
(==) = Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Unique -> Unique -> Bool)
-> (PatSyn -> Unique) -> PatSyn -> PatSyn -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PatSyn -> Unique
forall a. Uniquable a => a -> Unique
getUnique
/= :: PatSyn -> PatSyn -> Bool
(/=) = Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (Unique -> Unique -> Bool)
-> (PatSyn -> Unique) -> PatSyn -> PatSyn -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PatSyn -> Unique
forall a. Uniquable a => a -> Unique
getUnique
instance Uniquable PatSyn where
getUnique :: PatSyn -> Unique
getUnique = PatSyn -> Unique
psUnique
instance NamedThing PatSyn where
getName :: PatSyn -> Name
getName = PatSyn -> Name
patSynName
instance Outputable PatSyn where
ppr :: PatSyn -> SDoc
ppr = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SDoc) -> (PatSyn -> Name) -> PatSyn -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSyn -> Name
forall a. NamedThing a => a -> Name
getName
instance OutputableBndr PatSyn where
pprInfixOcc :: PatSyn -> SDoc
pprInfixOcc = Name -> SDoc
forall a. (Outputable a, NamedThing a) => a -> SDoc
pprInfixName (Name -> SDoc) -> (PatSyn -> Name) -> PatSyn -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSyn -> Name
forall a. NamedThing a => a -> Name
getName
pprPrefixOcc :: PatSyn -> SDoc
pprPrefixOcc = Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName (Name -> SDoc) -> (PatSyn -> Name) -> PatSyn -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSyn -> Name
forall a. NamedThing a => a -> Name
getName
instance Data.Data PatSyn where
toConstr :: PatSyn -> Constr
toConstr PatSyn
_ = String -> Constr
abstractConstr String
"PatSyn"
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PatSyn
gunfold forall b r. Data b => c (b -> r) -> c r
_ forall r. r -> c r
_ = String -> Constr -> c PatSyn
forall a. HasCallStack => String -> a
error String
"gunfold"
dataTypeOf :: PatSyn -> DataType
dataTypeOf PatSyn
_ = String -> DataType
mkNoRepType String
"PatSyn"
mkPatSyn :: Name
-> Bool
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> [FRRType]
-> Type
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn :: Name
-> Bool
-> ([InvisTVBinder], [Type])
-> ([InvisTVBinder], [Type])
-> [Type]
-> Type
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
name Bool
declared_infix
([InvisTVBinder]
univ_tvs, [Type]
req_theta)
([InvisTVBinder]
ex_tvs, [Type]
prov_theta)
[Type]
orig_args
Type
orig_res_ty
PatSynMatcher
matcher PatSynBuilder
builder [FieldLabel]
field_labels
= MkPatSyn {psName :: Name
psName = Name
name, psUnique :: Unique
psUnique = Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
name,
psUnivTyVars :: [InvisTVBinder]
psUnivTyVars = [InvisTVBinder]
univ_tvs,
psExTyVars :: [InvisTVBinder]
psExTyVars = [InvisTVBinder]
ex_tvs,
psProvTheta :: [Type]
psProvTheta = [Type]
prov_theta, psReqTheta :: [Type]
psReqTheta = [Type]
req_theta,
psInfix :: Bool
psInfix = Bool
declared_infix,
psArgs :: [Type]
psArgs = [Type]
orig_args,
psArity :: Arity
psArity = [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
orig_args,
psResultTy :: Type
psResultTy = Type
orig_res_ty,
psMatcher :: PatSynMatcher
psMatcher = PatSynMatcher
matcher,
psBuilder :: PatSynBuilder
psBuilder = PatSynBuilder
builder,
psFieldLabels :: [FieldLabel]
psFieldLabels = [FieldLabel]
field_labels
}
patSynName :: PatSyn -> Name
patSynName :: PatSyn -> Name
patSynName = PatSyn -> Name
psName
patSynIsInfix :: PatSyn -> Bool
patSynIsInfix :: PatSyn -> Bool
patSynIsInfix = PatSyn -> Bool
psInfix
patSynArity :: PatSyn -> Arity
patSynArity :: PatSyn -> Arity
patSynArity = PatSyn -> Arity
psArity
isVanillaPatSyn :: PatSyn -> Bool
isVanillaPatSyn :: PatSyn -> Bool
isVanillaPatSyn PatSyn
ps = [InvisTVBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PatSyn -> [InvisTVBinder]
psExTyVars PatSyn
ps) Bool -> Bool -> Bool
&& [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PatSyn -> [Type]
psProvTheta PatSyn
ps)
patSynArgs :: PatSyn -> [Type]
patSynArgs :: PatSyn -> [Type]
patSynArgs = PatSyn -> [Type]
psArgs
patSynFieldLabels :: PatSyn -> [FieldLabel]
patSynFieldLabels :: PatSyn -> [FieldLabel]
patSynFieldLabels = PatSyn -> [FieldLabel]
psFieldLabels
patSynFieldType :: PatSyn -> FieldLabelString -> Type
patSynFieldType :: PatSyn -> FieldLabelString -> Type
patSynFieldType PatSyn
ps FieldLabelString
label
= case ((FieldLabel, Type) -> Bool)
-> [(FieldLabel, Type)] -> Maybe (FieldLabel, Type)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FieldLabelString -> FieldLabelString -> Bool
forall a. Eq a => a -> a -> Bool
== FieldLabelString
label) (FieldLabelString -> Bool)
-> ((FieldLabel, Type) -> FieldLabelString)
-> (FieldLabel, Type)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FieldLabelString
flLabel (FieldLabel -> FieldLabelString)
-> ((FieldLabel, Type) -> FieldLabel)
-> (FieldLabel, Type)
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLabel, Type) -> FieldLabel
forall a b. (a, b) -> a
fst) (PatSyn -> [FieldLabel]
psFieldLabels PatSyn
ps [FieldLabel] -> [Type] -> [(FieldLabel, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` PatSyn -> [Type]
psArgs PatSyn
ps) of
Just (FieldLabel
_, Type
ty) -> Type
ty
Maybe (FieldLabel, Type)
Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dataConFieldType" (PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
label)
patSynUnivTyVarBinders :: PatSyn -> [InvisTVBinder]
patSynUnivTyVarBinders :: PatSyn -> [InvisTVBinder]
patSynUnivTyVarBinders = PatSyn -> [InvisTVBinder]
psUnivTyVars
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars PatSyn
ps = [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars (PatSyn -> [InvisTVBinder]
psExTyVars PatSyn
ps)
patSynExTyVarBinders :: PatSyn -> [InvisTVBinder]
patSynExTyVarBinders :: PatSyn -> [InvisTVBinder]
patSynExTyVarBinders = PatSyn -> [InvisTVBinder]
psExTyVars
patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type)
patSynSigBndr :: PatSyn
-> ([InvisTVBinder], [Type], [InvisTVBinder], [Type],
[Scaled Type], Type)
patSynSigBndr (MkPatSyn { psUnivTyVars :: PatSyn -> [InvisTVBinder]
psUnivTyVars = [InvisTVBinder]
univ_tvs, psExTyVars :: PatSyn -> [InvisTVBinder]
psExTyVars = [InvisTVBinder]
ex_tvs
, psProvTheta :: PatSyn -> [Type]
psProvTheta = [Type]
prov, psReqTheta :: PatSyn -> [Type]
psReqTheta = [Type]
req
, psArgs :: PatSyn -> [Type]
psArgs = [Type]
arg_tys, psResultTy :: PatSyn -> Type
psResultTy = Type
res_ty })
= ([InvisTVBinder]
univ_tvs, [Type]
req, [InvisTVBinder]
ex_tvs, [Type]
prov, (Type -> Scaled Type) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted [Type]
arg_tys, Type
res_ty)
patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Scaled Type], Type)
patSynSig :: PatSyn -> ([TyVar], [Type], [TyVar], [Type], [Scaled Type], Type)
patSynSig PatSyn
ps = let ([InvisTVBinder]
u_tvs, [Type]
req, [InvisTVBinder]
e_tvs, [Type]
prov, [Scaled Type]
arg_tys, Type
res_ty) = PatSyn
-> ([InvisTVBinder], [Type], [InvisTVBinder], [Type],
[Scaled Type], Type)
patSynSigBndr PatSyn
ps
in ([InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
u_tvs, [Type]
req, [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
e_tvs, [Type]
prov, [Scaled Type]
arg_tys, Type
res_ty)
patSynMatcher :: PatSyn -> PatSynMatcher
patSynMatcher :: PatSyn -> PatSynMatcher
patSynMatcher = PatSyn -> PatSynMatcher
psMatcher
patSynBuilder :: PatSyn -> PatSynBuilder
patSynBuilder :: PatSyn -> PatSynBuilder
patSynBuilder = PatSyn -> PatSynBuilder
psBuilder
patSynResultType :: PatSyn -> Type
patSynResultType :: PatSyn -> Type
patSynResultType = PatSyn -> Type
psResultTy
patSynInstArgTys :: PatSyn -> [Type] -> [Type]
patSynInstArgTys :: PatSyn -> [Type] -> [Type]
patSynInstArgTys (MkPatSyn { psName :: PatSyn -> Name
psName = Name
name, psUnivTyVars :: PatSyn -> [InvisTVBinder]
psUnivTyVars = [InvisTVBinder]
univ_tvs
, psExTyVars :: PatSyn -> [InvisTVBinder]
psExTyVars = [InvisTVBinder]
ex_tvs, psArgs :: PatSyn -> [Type]
psArgs = [Type]
arg_tys })
[Type]
inst_tys
= Bool -> SDoc -> [Type] -> [Type]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([TyVar]
tyvars [TyVar] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Type]
inst_tys)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"patSynInstArgTys" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tyvars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
inst_tys) ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
(Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([TyVar] -> [Type] -> Type -> Type
(() :: Constraint) => [TyVar] -> [Type] -> Type -> Type
substTyWith [TyVar]
tyvars [Type]
inst_tys) [Type]
arg_tys
where
tyvars :: [TyVar]
tyvars = [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars ([InvisTVBinder]
univ_tvs [InvisTVBinder] -> [InvisTVBinder] -> [InvisTVBinder]
forall a. [a] -> [a] -> [a]
++ [InvisTVBinder]
ex_tvs)
patSynInstResTy :: PatSyn -> [Type] -> Type
patSynInstResTy :: PatSyn -> [Type] -> Type
patSynInstResTy (MkPatSyn { psName :: PatSyn -> Name
psName = Name
name, psUnivTyVars :: PatSyn -> [InvisTVBinder]
psUnivTyVars = [InvisTVBinder]
univ_tvs
, psResultTy :: PatSyn -> Type
psResultTy = Type
res_ty })
[Type]
inst_tys
= Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([InvisTVBinder]
univ_tvs [InvisTVBinder] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Type]
inst_tys)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"patSynInstResTy" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [InvisTVBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InvisTVBinder]
univ_tvs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
inst_tys) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[TyVar] -> [Type] -> Type -> Type
(() :: Constraint) => [TyVar] -> [Type] -> Type -> Type
substTyWith ([InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
univ_tvs) [Type]
inst_tys Type
res_ty
pprPatSynType :: PatSyn -> SDoc
pprPatSynType :: PatSyn -> SDoc
pprPatSynType (MkPatSyn { psUnivTyVars :: PatSyn -> [InvisTVBinder]
psUnivTyVars = [InvisTVBinder]
univ_tvs, psReqTheta :: PatSyn -> [Type]
psReqTheta = [Type]
req_theta
, psExTyVars :: PatSyn -> [InvisTVBinder]
psExTyVars = [InvisTVBinder]
ex_tvs, psProvTheta :: PatSyn -> [Type]
psProvTheta = [Type]
prov_theta
, psArgs :: PatSyn -> [Type]
psArgs = [Type]
orig_args, psResultTy :: PatSyn -> Type
psResultTy = Type
orig_res_ty })
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ [ForAllTyBinder] -> SDoc
pprForAll ([ForAllTyBinder] -> SDoc) -> [ForAllTyBinder] -> SDoc
forall a b. (a -> b) -> a -> b
$ [InvisTVBinder] -> [ForAllTyBinder]
forall a. [VarBndr a Specificity] -> [VarBndr a ForAllTyFlag]
tyVarSpecToBinders [InvisTVBinder]
univ_tvs
, [Type] -> SDoc
pprThetaArrowTy [Type]
req_theta
, Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppWhen Bool
insert_empty_ctxt (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
forall doc. IsOutput doc => doc
empty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
darrow
, Type -> SDoc
pprType Type
sigma_ty ]
where
sigma_ty :: Type
sigma_ty = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
ex_tvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
mkInvisFunTys [Type]
prov_theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkVisFunTysMany [Type]
orig_args Type
orig_res_ty
insert_empty_ctxt :: Bool
insert_empty_ctxt = [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
req_theta Bool -> Bool -> Bool
&& Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
prov_theta Bool -> Bool -> Bool
&& [InvisTVBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InvisTVBinder]
ex_tvs)