never executed always true always false
1 -- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
2 --
3 -- Note that this does /not/ currently support the use case of annotating
4 -- every subexpression in an 'HsExpr' with its 'Type'. For more information on
5 -- this task, see #12706, #15320, #16804, and #17331.
6 module GHC.Hs.Syn.Type (
7 -- * Extracting types from HsExpr
8 lhsExprType, hsExprType, hsWrapperType,
9 -- * Extracting types from HsSyn
10 hsLitType, hsPatType, hsLPatType
11
12 ) where
13
14 import GHC.Prelude
15
16 import GHC.Builtin.Types
17 import GHC.Builtin.Types.Prim
18 import GHC.Core.Coercion
19 import GHC.Core.ConLike
20 import GHC.Core.DataCon
21 import GHC.Core.PatSyn
22 import GHC.Core.TyCo.Rep
23 import GHC.Core.Type
24 import GHC.Core.Utils
25 import GHC.Hs
26 import GHC.Tc.Types.Evidence
27 import GHC.Types.Id
28 import GHC.Types.SrcLoc
29 import GHC.Utils.Outputable
30 import GHC.Utils.Panic
31
32 {-
33 ************************************************************************
34 * *
35 Extracting the type from HsSyn
36 * *
37 ************************************************************************
38
39 -}
40
41 hsLPatType :: LPat GhcTc -> Type
42 hsLPatType (L _ p) = hsPatType p
43
44 hsPatType :: Pat GhcTc -> Type
45 hsPatType (ParPat _ _ pat _) = hsLPatType pat
46 hsPatType (WildPat ty) = ty
47 hsPatType (VarPat _ lvar) = idType (unLoc lvar)
48 hsPatType (BangPat _ pat) = hsLPatType pat
49 hsPatType (LazyPat _ pat) = hsLPatType pat
50 hsPatType (LitPat _ lit) = hsLitType lit
51 hsPatType (AsPat _ var _) = idType (unLoc var)
52 hsPatType (ViewPat ty _ _) = ty
53 hsPatType (ListPat ty _) = mkListTy ty
54 hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
55 -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
56 hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
57 hsPatType (ConPat { pat_con = lcon
58 , pat_con_ext = ConPatTc
59 { cpt_arg_tys = tys
60 }
61 })
62 = conLikeResTy (unLoc lcon) tys
63 hsPatType (SigPat ty _ _) = ty
64 hsPatType (NPat ty _ _ _) = ty
65 hsPatType (NPlusKPat ty _ _ _ _ _) = ty
66 hsPatType (XPat ext) =
67 case ext of
68 CoPat _ _ ty -> ty
69 ExpansionPat _ pat -> hsPatType pat
70 hsPatType (SplicePat v _) = dataConCantHappen v
71
72 hsLitType :: HsLit (GhcPass p) -> Type
73 hsLitType (HsChar _ _) = charTy
74 hsLitType (HsCharPrim _ _) = charPrimTy
75 hsLitType (HsString _ _) = stringTy
76 hsLitType (HsStringPrim _ _) = addrPrimTy
77 hsLitType (HsInt _ _) = intTy
78 hsLitType (HsIntPrim _ _) = intPrimTy
79 hsLitType (HsWordPrim _ _) = wordPrimTy
80 hsLitType (HsInt64Prim _ _) = int64PrimTy
81 hsLitType (HsWord64Prim _ _) = word64PrimTy
82 hsLitType (HsInteger _ _ ty) = ty
83 hsLitType (HsRat _ _ ty) = ty
84 hsLitType (HsFloatPrim _ _) = floatPrimTy
85 hsLitType (HsDoublePrim _ _) = doublePrimTy
86
87
88 -- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.
89 lhsExprType :: LHsExpr GhcTc -> Type
90 lhsExprType (L _ e) = hsExprType e
91
92 -- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
93 hsExprType :: HsExpr GhcTc -> Type
94 hsExprType (HsVar _ (L _ id)) = idType id
95 hsExprType (HsUnboundVar (HER _ ty _) _) = ty
96 hsExprType (HsRecSel _ (FieldOcc id _)) = idType id
97 hsExprType (HsOverLabel v _) = dataConCantHappen v
98 hsExprType (HsIPVar v _) = dataConCantHappen v
99 hsExprType (HsOverLit _ lit) = overLitType lit
100 hsExprType (HsLit _ lit) = hsLitType lit
101 hsExprType (HsLam _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
102 hsExprType (HsLamCase _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
103 hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f
104 hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x
105 hsExprType (OpApp v _ _ _) = dataConCantHappen v
106 hsExprType (NegApp _ _ se) = syntaxExprType se
107 hsExprType (HsPar _ _ e _) = lhsExprType e
108 hsExprType (SectionL v _ _) = dataConCantHappen v
109 hsExprType (SectionR v _ _) = dataConCantHappen v
110 hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args
111 hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys
112 hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group
113 hsExprType (HsIf _ _ t _) = lhsExprType t
114 hsExprType (HsMultiIf ty _) = ty
115 hsExprType (HsLet _ _ _ _ body) = lhsExprType body
116 hsExprType (HsDo ty _ _) = ty
117 hsExprType (ExplicitList ty _) = mkListTy ty
118 hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
119 hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) =
120 case cons of
121 con_like:_ -> conLikeResTy con_like out_tys
122 [] -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons"
123 (ppr e)
124 hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v
125 hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v
126 hsExprType (ExprWithTySig _ e _) = lhsExprType e
127 hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
128 Just op -> piResultTy (syntaxExprType op) asi_ty
129 Nothing -> asi_ty
130 where
131 asi_ty = arithSeqInfoType asi
132 hsExprType (HsBracket v _) = dataConCantHappen v
133 hsExprType (HsRnBracketOut v _ _) = dataConCantHappen v
134 hsExprType (HsTcBracketOut ty _wrap _bracket _pending) = ty
135 hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
136 (ppr e)
137 -- Typed splices should have been eliminated during zonking, but we
138 -- can't use `dataConCantHappen` since they are still present before
139 -- than in the typechecked AST.
140 hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
141 hsExprType (HsStatic _ e) = lhsExprType e
142 hsExprType (HsPragE _ _ e) = lhsExprType e
143 hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
144 hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
145 hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
146 hsExprType (XExpr (HsTick _ e)) = lhsExprType e
147 hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
148
149 arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
150 arithSeqInfoType asi = mkListTy $ case asi of
151 From x -> lhsExprType x
152 FromThen x _ -> lhsExprType x
153 FromTo x _ -> lhsExprType x
154 FromThenTo x _ _ -> lhsExprType x
155
156 conLikeType :: ConLike -> Type
157 conLikeType (RealDataCon con) = dataConNonlinearType con
158 conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of
159 Just (_, ty, _) -> ty
160 Nothing -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position"
161 (ppr patsyn)
162
163 hsTupArgType :: HsTupArg GhcTc -> Type
164 hsTupArgType (Present _ e) = lhsExprType e
165 hsTupArgType (Missing (Scaled _ ty)) = ty
166
167
168 -- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))
169 type PRType = (Type, [Type])
170
171 prTypeType :: PRType -> Type
172 prTypeType (ty, tys)
173 | null tys = ty
174 | otherwise = piResultTys ty (reverse tys)
175
176 liftPRType :: (Type -> Type) -> PRType -> PRType
177 liftPRType f pty = (f (prTypeType pty), [])
178
179 hsWrapperType :: HsWrapper -> Type -> Type
180 hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
181 where
182 go WpHole = id
183 go (w1 `WpCompose` w2) = go w1 . go w2
184 go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t ->
185 let act_res = funResultTy t
186 exp_res = hsWrapperType w2 act_res
187 in mkFunctionType m exp_arg exp_res
188 go (WpCast co) = liftPRType $ \_ -> coercionRKind co
189 go (WpEvLam v) = liftPRType $ mkInvisFunTyMany (idType v)
190 go (WpEvApp _) = liftPRType $ funResultTy
191 go (WpTyLam tv) = liftPRType $ mkForAllTy tv Inferred
192 go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas)
193 go (WpLet _) = id
194 go (WpMultCoercion _) = id
195
196 lhsCmdTopType :: LHsCmdTop GhcTc -> Type
197 lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
198
199 matchGroupTcType :: MatchGroupTc -> Type
200 matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res
201
202 syntaxExprType :: SyntaxExpr GhcTc -> Type
203 syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
204 syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc"