-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
--
-- Note that this does /not/ currently support the use case of annotating
-- every subexpression in an 'HsExpr' with its 'Type'. For more information on
-- this task, see #12706, #15320, #16804, and #17331.
module GHC.Hs.Syn.Type (
    -- * Extracting types from HsExpr
    lhsExprType, hsExprType, hsWrapperType,
    -- * Extracting types from HsSyn
    hsLitType, hsPatType, hsLPatType,
  ) where

import GHC.Prelude

import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Core.Coercion
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Hs
import GHC.Tc.Types.Evidence
import GHC.Types.Id
import GHC.Types.Var( VarBndr(..) )
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic

{-
************************************************************************
*                                                                      *
       Extracting the type from HsSyn
*                                                                      *
************************************************************************

-}

hsLPatType :: LPat GhcTc -> Type
hsLPatType :: LPat GhcTc -> Type
hsLPatType (L SrcSpanAnnA
_ Pat GhcTc
p) = Pat GhcTc -> Type
hsPatType Pat GhcTc
p

hsPatType :: Pat GhcTc -> Type
hsPatType :: Pat GhcTc -> Type
hsPatType (ParPat XParPat GhcTc
_ LPat GhcTc
pat)                = LPat GhcTc -> Type
hsLPatType LPat GhcTc
pat
hsPatType (WildPat XWildPat GhcTc
ty)                  = XWildPat GhcTc
Type
ty
hsPatType (VarPat XVarPat GhcTc
_ LIdP GhcTc
lvar)               = Id -> Type
idType (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
lvar)
hsPatType (BangPat XBangPat GhcTc
_ LPat GhcTc
pat)               = LPat GhcTc -> Type
hsLPatType LPat GhcTc
pat
hsPatType (LazyPat XLazyPat GhcTc
_ LPat GhcTc
pat)               = LPat GhcTc -> Type
hsLPatType LPat GhcTc
pat
hsPatType (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit)                = HsLit GhcTc -> Type
forall (p :: Pass). IsPass p => HsLit (GhcPass p) -> Type
hsLitType HsLit GhcTc
lit
hsPatType (AsPat XAsPat GhcTc
_ LIdP GhcTc
var LPat GhcTc
_)               = Id -> Type
idType (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
var)
hsPatType (ViewPat XViewPat GhcTc
ty LHsExpr GhcTc
_ LPat GhcTc
_)              = XViewPat GhcTc
Type
ty
hsPatType (ListPat XListPat GhcTc
ty [LPat GhcTc]
_)                = Type -> Type
mkListTy XListPat GhcTc
Type
ty
hsPatType (OrPat XOrPat GhcTc
ty NonEmpty (LPat GhcTc)
_)                  = XOrPat GhcTc
Type
ty
hsPatType (TuplePat XTuplePat GhcTc
tys [LPat GhcTc]
_ Boxity
bx)           = Boxity -> [Type] -> Type
mkTupleTy1 Boxity
bx [Type]
XTuplePat GhcTc
tys
                  -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
hsPatType (SumPat XSumPat GhcTc
tys LPat GhcTc
_ ConTag
_ ConTag
_ )           = [Type] -> Type
mkSumTy [Type]
XSumPat GhcTc
tys
hsPatType (ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = XRec GhcTc (ConLikeP GhcTc)
lcon
                  , pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = ConPatTc
                    { cpt_arg_tys :: ConPatTc -> [Type]
cpt_arg_tys = [Type]
tys
                    }
                  })
                                        = ConLike -> [Type] -> Type
conLikeResTy (GenLocated SrcSpanAnnN ConLike -> ConLike
forall l e. GenLocated l e -> e
unLoc XRec GhcTc (ConLikeP GhcTc)
GenLocated SrcSpanAnnN ConLike
lcon) [Type]
tys
hsPatType (SigPat XSigPat GhcTc
ty LPat GhcTc
_ HsPatSigType (NoGhcTc GhcTc)
_)               = XSigPat GhcTc
Type
ty
hsPatType (NPat XNPat GhcTc
ty XRec GhcTc (HsOverLit GhcTc)
_ Maybe (SyntaxExpr GhcTc)
_ SyntaxExpr GhcTc
_)               = XNPat GhcTc
Type
ty
hsPatType (NPlusKPat XNPlusKPat GhcTc
ty LIdP GhcTc
_ XRec GhcTc (HsOverLit GhcTc)
_ HsOverLit GhcTc
_ SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_)      = XNPlusKPat GhcTc
Type
ty
hsPatType (EmbTyPat XEmbTyPat GhcTc
ty HsTyPat (NoGhcTc GhcTc)
_)               = HasDebugCallStack => Type -> Type
Type -> Type
typeKind XEmbTyPat GhcTc
Type
ty
hsPatType (InvisPat XInvisPat GhcTc
ty HsTyPat (NoGhcTc GhcTc)
_)               = HasDebugCallStack => Type -> Type
Type -> Type
typeKind XInvisPat GhcTc
Type
ty
hsPatType (XPat XXPat GhcTc
ext) =
  case XXPat GhcTc
ext of
    CoPat HsWrapper
_ Pat GhcTc
_ Type
ty       -> Type
ty
    ExpansionPat Pat GhcRn
_ Pat GhcTc
pat -> Pat GhcTc -> Type
hsPatType Pat GhcTc
pat
hsPatType (SplicePat XSplicePat GhcTc
v HsUntypedSplice GhcTc
_)               = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XSplicePat GhcTc
DataConCantHappen
v

hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type
hsLitType :: forall (p :: Pass). IsPass p => HsLit (GhcPass p) -> Type
hsLitType (HsChar XHsChar (GhcPass p)
_ Char
_)       = Type
charTy
hsLitType (HsCharPrim XHsCharPrim (GhcPass p)
_ Char
_)   = Type
charPrimTy
hsLitType (HsString XHsString (GhcPass p)
_ FastString
_)     = Type
stringTy
hsLitType (HsMultilineString XHsMultilineString (GhcPass p)
_ FastString
_) = Type
stringTy
hsLitType (HsStringPrim XHsStringPrim (GhcPass p)
_ ByteString
_) = Type
addrPrimTy
hsLitType (HsInt XHsInt (GhcPass p)
_ IntegralLit
_)        = Type
intTy
hsLitType (HsIntPrim XHsIntPrim (GhcPass p)
_ Integer
_)    = Type
intPrimTy
hsLitType (HsWordPrim XHsWordPrim (GhcPass p)
_ Integer
_)   = Type
wordPrimTy
hsLitType (HsInt8Prim XHsInt8Prim (GhcPass p)
_ Integer
_)   = Type
int8PrimTy
hsLitType (HsInt16Prim XHsInt16Prim (GhcPass p)
_ Integer
_)  = Type
int16PrimTy
hsLitType (HsInt32Prim XHsInt32Prim (GhcPass p)
_ Integer
_)  = Type
int32PrimTy
hsLitType (HsInt64Prim XHsInt64Prim (GhcPass p)
_ Integer
_)  = Type
int64PrimTy
hsLitType (HsWord8Prim XHsWord8Prim (GhcPass p)
_ Integer
_)  = Type
word8PrimTy
hsLitType (HsWord16Prim XHsWord16Prim (GhcPass p)
_ Integer
_) = Type
word16PrimTy
hsLitType (HsWord32Prim XHsWord32Prim (GhcPass p)
_ Integer
_) = Type
word32PrimTy
hsLitType (HsWord64Prim XHsWord64Prim (GhcPass p)
_ Integer
_) = Type
word64PrimTy
hsLitType (HsFloatPrim XHsFloatPrim (GhcPass p)
_ FractionalLit
_)  = Type
floatPrimTy
hsLitType (HsDoublePrim XHsDoublePrim (GhcPass p)
_ FractionalLit
_) = Type
doublePrimTy
hsLitType (XLit XXLit (GhcPass p)
x)           = case forall (p :: Pass). IsPass p => GhcPass p
ghcPass @p of
      GhcPass p
GhcTc -> case XXLit (GhcPass p)
x of
         (HsInteger SourceText
_ Integer
_ Type
ty) -> Type
ty
         (HsRat  FractionalLit
_ Type
ty)      -> Type
ty


-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.
lhsExprType :: LHsExpr GhcTc -> Type
lhsExprType :: LHsExpr GhcTc -> Type
lhsExprType (L SrcSpanAnnA
_ HsExpr GhcTc
e) = HsExpr GhcTc -> Type
hsExprType HsExpr GhcTc
e

-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
hsExprType :: HsExpr GhcTc -> Type
hsExprType :: HsExpr GhcTc -> Type
hsExprType (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
id)) = Id -> Type
idType Id
id
hsExprType (HsUnboundVar (HER IORef EvTerm
_ Type
ty Unique
_) RdrName
_) = Type
ty
hsExprType (HsOverLabel XOverLabel GhcTc
v FastString
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XOverLabel GhcTc
DataConCantHappen
v
hsExprType (HsIPVar XIPVar GhcTc
v HsIPName
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XIPVar GhcTc
DataConCantHappen
v
hsExprType (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
lit) = HsOverLit GhcTc -> Type
overLitType HsOverLit GhcTc
lit
hsExprType (HsLit XLitE GhcTc
_ HsLit GhcTc
lit) = HsLit GhcTc -> Type
forall (p :: Pass). IsPass p => HsLit (GhcPass p) -> Type
hsLitType HsLit GhcTc
lit
hsExprType (HsLam XLam GhcTc
_ HsLamVariant
_ (MG { mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = XMG GhcTc (LHsExpr GhcTc)
match_group })) = MatchGroupTc -> Type
matchGroupTcType XMG GhcTc (LHsExpr GhcTc)
MatchGroupTc
match_group
hsExprType (HsApp XApp GhcTc
_ LHsExpr GhcTc
f LHsExpr GhcTc
_) = HasDebugCallStack => Type -> Type
Type -> Type
funResultTy (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
f
hsExprType (HsAppType XAppTypeE GhcTc
x LHsExpr GhcTc
f LHsWcType (NoGhcTc GhcTc)
_) = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
piResultTy (LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
f) XAppTypeE GhcTc
Type
x
hsExprType (OpApp XOpApp GhcTc
v LHsExpr GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XOpApp GhcTc
DataConCantHappen
v
hsExprType (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
_ SyntaxExpr GhcTc
se) = SyntaxExpr GhcTc -> Type
syntaxExprType SyntaxExpr GhcTc
se
hsExprType (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
e
hsExprType (SectionL XSectionL GhcTc
v LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XSectionL GhcTc
DataConCantHappen
v
hsExprType (SectionR XSectionR GhcTc
v LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XSectionR GhcTc
DataConCantHappen
v
hsExprType (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
args Boxity
box) = Boxity -> [Type] -> Type
mkTupleTy Boxity
box ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (HsTupArg GhcTc -> Type) -> [HsTupArg GhcTc] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map HsTupArg GhcTc -> Type
hsTupArgType [HsTupArg GhcTc]
args
hsExprType (ExplicitSum XExplicitSum GhcTc
alt_tys ConTag
_ ConTag
_ LHsExpr GhcTc
_) = [Type] -> Type
mkSumTy [Type]
XExplicitSum GhcTc
alt_tys
hsExprType (HsCase XCase GhcTc
_ LHsExpr GhcTc
_ (MG { mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = XMG GhcTc (LHsExpr GhcTc)
match_group })) = MatchGroupTc -> Type
mg_res_ty XMG GhcTc (LHsExpr GhcTc)
MatchGroupTc
match_group
hsExprType (HsIf XIf GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
t LHsExpr GhcTc
_) = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
t
hsExprType (HsMultiIf XMultiIf GhcTc
ty [LGRHS GhcTc (LHsExpr GhcTc)]
_) = XMultiIf GhcTc
Type
ty
hsExprType (HsLet XLet GhcTc
_ HsLocalBinds GhcTc
_ LHsExpr GhcTc
body) = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
body
hsExprType (HsDo XDo GhcTc
ty HsDoFlavour
_ XRec GhcTc [ExprLStmt GhcTc]
_) = XDo GhcTc
Type
ty
hsExprType (ExplicitList XExplicitList GhcTc
ty [LHsExpr GhcTc]
_) = Type -> Type
mkListTy XExplicitList GhcTc
Type
ty
hsExprType (RecordCon XRecordCon GhcTc
con_expr XRec GhcTc (ConLikeP GhcTc)
_ HsRecordBinds GhcTc
_) = HsExpr GhcTc -> Type
hsExprType XRecordCon GhcTc
HsExpr GhcTc
con_expr
hsExprType (RecordUpd XRecordUpd GhcTc
v LHsExpr GhcTc
_ LHsRecUpdFields GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XRecordUpd GhcTc
DataConCantHappen
v
hsExprType (HsGetField { gf_ext :: forall p. HsExpr p -> XGetField p
gf_ext = XGetField GhcTc
v }) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XGetField GhcTc
DataConCantHappen
v
hsExprType (HsProjection { proj_ext :: forall p. HsExpr p -> XProjection p
proj_ext = XProjection GhcTc
v }) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XProjection GhcTc
DataConCantHappen
v
hsExprType (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
e
hsExprType (ArithSeq XArithSeq GhcTc
_ Maybe (SyntaxExpr GhcTc)
mb_overloaded_op ArithSeqInfo GhcTc
asi) = case Maybe (SyntaxExpr GhcTc)
mb_overloaded_op of
  Just SyntaxExpr GhcTc
op -> HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
piResultTy (SyntaxExpr GhcTc -> Type
syntaxExprType SyntaxExpr GhcTc
op) Type
asi_ty
  Maybe (SyntaxExpr GhcTc)
Nothing -> Type
asi_ty
  where
    asi_ty :: Type
asi_ty = ArithSeqInfo GhcTc -> Type
arithSeqInfoType ArithSeqInfo GhcTc
asi
hsExprType (HsTypedBracket   (HsBracketTc { hsb_ty :: HsBracketTc -> Type
hsb_ty = Type
ty }) LHsExpr GhcTc
_) = Type
ty
hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty :: HsBracketTc -> Type
hsb_ty = Type
ty }) HsQuote GhcTc
_) = Type
ty
hsExprType e :: HsExpr GhcTc
e@(HsTypedSplice{}) = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"hsExprType: Unexpected HsTypedSplice"
                                          (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)
                                      -- Typed splices should have been eliminated during zonking, but we
                                      -- can't use `dataConCantHappen` since they are still present before
                                      -- than in the typechecked AST.
hsExprType (HsUntypedSplice XUntypedSplice GhcTc
ext HsUntypedSplice GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XUntypedSplice GhcTc
DataConCantHappen
ext
hsExprType (HsProc XProc GhcTc
_ LPat GhcTc
_ LHsCmdTop GhcTc
lcmd_top) = LHsCmdTop GhcTc -> Type
lhsCmdTopType LHsCmdTop GhcTc
lcmd_top
hsExprType (HsStatic (NameSet
_, Type
ty) LHsExpr GhcTc
_s) = Type
ty
hsExprType (HsPragE XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
e
hsExprType (HsEmbTy XEmbTy GhcTc
x LHsWcType (NoGhcTc GhcTc)
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XEmbTy GhcTc
DataConCantHappen
x
hsExprType (HsQual XQual GhcTc
x XRec GhcTc [LHsExpr GhcTc]
_ LHsExpr GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XQual GhcTc
DataConCantHappen
x
hsExprType (HsForAll XForAll GhcTc
x HsForAllTelescope GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XForAll GhcTc
DataConCantHappen
x
hsExprType (HsFunArr XFunArr GhcTc
x HsArrowOf (LHsExpr GhcTc) GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> Type
forall a. DataConCantHappen -> a
dataConCantHappen XFunArr GhcTc
DataConCantHappen
x
hsExprType (XExpr (WrapExpr HsWrapper
wrap HsExpr GhcTc
e)) = HsWrapper -> Type -> Type
hsWrapperType HsWrapper
wrap (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> Type
hsExprType HsExpr GhcTc
e
hsExprType (XExpr (ExpandedThingTc HsThingRn
_ HsExpr GhcTc
e))  = HsExpr GhcTc -> Type
hsExprType HsExpr GhcTc
e
hsExprType (XExpr (ConLikeTc ConLike
con [Id]
_ [Scaled Type]
_)) = ConLike -> Type
conLikeType ConLike
con
hsExprType (XExpr (HsTick CoreTickish
_ LHsExpr GhcTc
e)) = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
e
hsExprType (XExpr (HsBinTick ConTag
_ ConTag
_ LHsExpr GhcTc
e)) = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
e
hsExprType (XExpr (HsRecSelTc (FieldOcc XCFieldOcc GhcTc
_ LIdP GhcTc
id))) = Id -> Type
idType (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
id)

arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
arithSeqInfoType ArithSeqInfo GhcTc
asi = Type -> Type
mkListTy (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ case ArithSeqInfo GhcTc
asi of
  From LHsExpr GhcTc
x           -> LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
x
  FromThen LHsExpr GhcTc
x LHsExpr GhcTc
_     -> LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
x
  FromTo LHsExpr GhcTc
x LHsExpr GhcTc
_       -> LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
x
  FromThenTo LHsExpr GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_ -> LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
x

conLikeType :: ConLike -> Type
conLikeType :: ConLike -> Type
conLikeType (RealDataCon DataCon
con)  = DataCon -> Type
dataConNonlinearType DataCon
con
conLikeType (PatSynCon PatSyn
patsyn) = case PatSyn -> PatSynBuilder
patSynBuilder PatSyn
patsyn of
    Just (Name
_, Type
ty, Bool
_) -> Type
ty
    PatSynBuilder
Nothing         -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"conLikeType: Unidirectional pattern synonym in expression position"
                                (PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
patsyn)

hsTupArgType :: HsTupArg GhcTc -> Type
hsTupArgType :: HsTupArg GhcTc -> Type
hsTupArgType (Present XPresent GhcTc
_ LHsExpr GhcTc
e)           = LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
e
hsTupArgType (Missing (Scaled Type
_ Type
ty)) = Type
ty


-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))
type PRType = (Type, [Type])

prTypeType :: PRType -> Type
prTypeType :: PRType -> Type
prTypeType (Type
ty, [Type]
tys)
  | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys  = Type
ty
  | Bool
otherwise = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
ty ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
tys)

liftPRType :: (Type -> Type) -> PRType -> PRType
liftPRType :: (Type -> Type) -> PRType -> PRType
liftPRType Type -> Type
f PRType
pty = (Type -> Type
f (PRType -> Type
prTypeType PRType
pty), [])

hsWrapperType :: HsWrapper -> Type -> Type
hsWrapperType :: HsWrapper -> Type -> Type
hsWrapperType HsWrapper
wrap Type
ty = PRType -> Type
prTypeType (PRType -> Type) -> PRType -> Type
forall a b. (a -> b) -> a -> b
$ HsWrapper -> PRType -> PRType
go HsWrapper
wrap (Type
ty,[])
  where
    go :: HsWrapper -> PRType -> PRType
go HsWrapper
WpHole              = PRType -> PRType
forall a. a -> a
id
    go (HsWrapper
w1 `WpCompose` HsWrapper
w2) = HsWrapper -> PRType -> PRType
go HsWrapper
w1 (PRType -> PRType) -> (PRType -> PRType) -> PRType -> PRType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsWrapper -> PRType -> PRType
go HsWrapper
w2
    go (WpFun HsWrapper
_ HsWrapper
w2 (Scaled Type
m Type
exp_arg)) = (Type -> Type) -> PRType -> PRType
liftPRType ((Type -> Type) -> PRType -> PRType)
-> (Type -> Type) -> PRType -> PRType
forall a b. (a -> b) -> a -> b
$ \Type
t ->
      let act_res :: Type
act_res = HasDebugCallStack => Type -> Type
Type -> Type
funResultTy Type
t
          exp_res :: Type
exp_res = HsWrapper -> Type -> Type
hsWrapperType HsWrapper
w2 Type
act_res
      in HasDebugCallStack => Type -> Type -> Type -> Type
Type -> Type -> Type -> Type
mkFunctionType Type
m Type
exp_arg Type
exp_res
    go (WpCast TcCoercionR
co)        = (Type -> Type) -> PRType -> PRType
liftPRType ((Type -> Type) -> PRType -> PRType)
-> (Type -> Type) -> PRType -> PRType
forall a b. (a -> b) -> a -> b
$ \Type
_ -> HasDebugCallStack => TcCoercionR -> Type
TcCoercionR -> Type
coercionRKind TcCoercionR
co
    go (WpEvLam Id
v)        = (Type -> Type) -> PRType -> PRType
liftPRType ((Type -> Type) -> PRType -> PRType)
-> (Type -> Type) -> PRType -> PRType
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkInvisFunTy (Id -> Type
idType Id
v)
    go (WpEvApp EvTerm
_)        = (Type -> Type) -> PRType -> PRType
liftPRType ((Type -> Type) -> PRType -> PRType)
-> (Type -> Type) -> PRType -> PRType
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type
Type -> Type
funResultTy
    go (WpTyLam Id
tv)       = (Type -> Type) -> PRType -> PRType
liftPRType ((Type -> Type) -> PRType -> PRType)
-> (Type -> Type) -> PRType -> PRType
forall a b. (a -> b) -> a -> b
$ ForAllTyBinder -> Type -> Type
mkForAllTy (Id -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
tv ForAllTyFlag
Inferred)
    go (WpTyApp Type
ta)       = \(Type
ty,[Type]
tas) -> (Type
ty, Type
taType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
tas)
    go (WpLet TcEvBinds
_)          = PRType -> PRType
forall a. a -> a
id

lhsCmdTopType :: LHsCmdTop GhcTc -> Type
lhsCmdTopType :: LHsCmdTop GhcTc -> Type
lhsCmdTopType (L EpAnnCO
_ (HsCmdTop (CmdTopTc Type
_ Type
ret_ty CmdSyntaxTable GhcTc
_) LHsCmd GhcTc
_)) = Type
ret_ty

matchGroupTcType :: MatchGroupTc -> Type
matchGroupTcType :: MatchGroupTc -> Type
matchGroupTcType (MatchGroupTc [Scaled Type]
args Type
res Origin
_) = [Scaled Type] -> Type -> Type
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
args Type
res

syntaxExprType :: SyntaxExpr GhcTc -> Type
syntaxExprType :: SyntaxExpr GhcTc -> Type
syntaxExprType (SyntaxExprTc HsExpr GhcTc
e [HsWrapper]
_ HsWrapper
_) = HsExpr GhcTc -> Type
hsExprType HsExpr GhcTc
e
syntaxExprType SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc       = String -> Type
forall a. HasCallStack => String -> a
panic String
"syntaxExprType: Unexpected NoSyntaxExprTc"