-- | 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 (L _ p) = hsPatType p
hsPatType :: Pat GhcTc -> Type
hsPatType (ParPat _ _ pat _) = hsLPatType pat
hsPatType (WildPat ty) = ty
hsPatType (VarPat _ lvar) = idType (unLoc lvar)
hsPatType (BangPat _ pat) = hsLPatType pat
hsPatType (LazyPat _ pat) = hsLPatType pat
hsPatType (LitPat _ lit) = hsLitType lit
hsPatType (AsPat _ var _ _) = idType (unLoc var)
hsPatType (ViewPat ty _ _) = ty
hsPatType (ListPat ty _) = mkListTy ty
hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
-- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
hsPatType (ConPat { pat_con = lcon
, pat_con_ext = ConPatTc
{ cpt_arg_tys = tys
}
})
= conLikeResTy (unLoc lcon) tys
hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
hsPatType (XPat ext) =
case ext of
CoPat _ _ ty -> ty
ExpansionPat _ pat -> hsPatType pat
hsPatType (SplicePat v _) = dataConCantHappen v
hsLitType :: HsLit (GhcPass p) -> Type
hsLitType (HsChar _ _) = charTy
hsLitType (HsCharPrim _ _) = charPrimTy
hsLitType (HsString _ _) = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
hsLitType (HsInt _ _) = intTy
hsLitType (HsIntPrim _ _) = intPrimTy
hsLitType (HsWordPrim _ _) = wordPrimTy
hsLitType (HsInt64Prim _ _) = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
hsLitType (HsRat _ _ ty) = ty
hsLitType (HsFloatPrim _ _) = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.
lhsExprType :: LHsExpr GhcTc -> Type
lhsExprType (L _ e) = hsExprType e
-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
hsExprType :: HsExpr GhcTc -> Type
hsExprType (HsVar _ (L _ id)) = idType id
hsExprType (HsUnboundVar (HER _ ty _) _) = ty
hsExprType (HsRecSel _ (FieldOcc id _)) = idType id
hsExprType (HsOverLabel v _ _) = dataConCantHappen v
hsExprType (HsIPVar v _) = dataConCantHappen v
hsExprType (HsOverLit _ lit) = overLitType lit
hsExprType (HsLit _ lit) = hsLitType lit
hsExprType (HsLam _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f
hsExprType (HsAppType x f _ _) = piResultTy (lhsExprType f) x
hsExprType (OpApp v _ _ _) = dataConCantHappen v
hsExprType (NegApp _ _ se) = syntaxExprType se
hsExprType (HsPar _ _ e _) = lhsExprType e
hsExprType (SectionL v _ _) = dataConCantHappen v
hsExprType (SectionR v _ _) = dataConCantHappen v
hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args
hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys
hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group
hsExprType (HsIf _ _ t _) = lhsExprType t
hsExprType (HsMultiIf ty _) = ty
hsExprType (HsLet _ _ _ _ body) = lhsExprType body
hsExprType (HsDo ty _ _) = ty
hsExprType (ExplicitList ty _) = mkListTy ty
hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
hsExprType (RecordUpd v _ _) = dataConCantHappen v
hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v
hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v
hsExprType (ExprWithTySig _ e _) = lhsExprType e
hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
Just op -> piResultTy (syntaxExprType op) asi_ty
Nothing -> asi_ty
where
asi_ty = arithSeqInfoType asi
hsExprType (HsTypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty
hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty
hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice"
(ppr 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 ext _) = dataConCantHappen ext
hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
hsExprType (HsStatic (_, ty) _s) = ty
hsExprType (HsPragE _ _ e) = lhsExprType e
hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
arithSeqInfoType asi = mkListTy $ case asi of
From x -> lhsExprType x
FromThen x _ -> lhsExprType x
FromTo x _ -> lhsExprType x
FromThenTo x _ _ -> lhsExprType x
conLikeType :: ConLike -> Type
conLikeType (RealDataCon con) = dataConNonlinearType con
conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of
Just (_, ty, _) -> ty
Nothing -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position"
(ppr patsyn)
hsTupArgType :: HsTupArg GhcTc -> Type
hsTupArgType (Present _ e) = lhsExprType e
hsTupArgType (Missing (Scaled _ ty)) = ty
-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))
type PRType = (Type, [Type])
prTypeType :: PRType -> Type
prTypeType (ty, tys)
| null tys = ty
| otherwise = piResultTys ty (reverse tys)
liftPRType :: (Type -> Type) -> PRType -> PRType
liftPRType f pty = (f (prTypeType pty), [])
hsWrapperType :: HsWrapper -> Type -> Type
hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
where
go WpHole = id
go (w1 `WpCompose` w2) = go w1 . go w2
go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t ->
let act_res = funResultTy t
exp_res = hsWrapperType w2 act_res
in mkFunctionType m exp_arg exp_res
go (WpCast co) = liftPRType $ \_ -> coercionRKind co
go (WpEvLam v) = liftPRType $ mkInvisFunTy (idType v)
go (WpEvApp _) = liftPRType $ funResultTy
go (WpTyLam tv) = liftPRType $ mkForAllTy (Bndr tv Inferred)
go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas)
go (WpLet _) = id
go (WpMultCoercion _) = id
lhsCmdTopType :: LHsCmdTop GhcTc -> Type
lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
matchGroupTcType :: MatchGroupTc -> Type
matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res
syntaxExprType :: SyntaxExpr GhcTc -> Type
syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc"