never executed always true always false
1
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeApplications #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE ViewPatterns #-}
10 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
11 -- in module Language.Haskell.Syntax.Extension
12
13 {-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId
14
15 {-
16 (c) The University of Glasgow 2006
17 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
18
19
20 GHC.Hs.Type: Abstract syntax: user-defined types
21 -}
22
23 module GHC.Hs.Type (
24 Mult, HsScaled(..),
25 hsMult, hsScaledThing,
26 HsArrow(..), arrowToHsType,
27 HsLinearArrowTokens(..),
28 hsLinear, hsUnrestricted, isUnrestricted,
29 pprHsArrow,
30
31 HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
32 HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr,
33 LHsQTyVars(..),
34 HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,
35 HsWildCardBndrs(..),
36 HsPatSigType(..), HsPSRn(..),
37 HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,
38 HsTupleSort(..),
39 HsContext, LHsContext, fromMaybeContext,
40 HsTyLit(..),
41 HsIPName(..), hsIPNameFS,
42 HsArg(..), numVisibleArgs, pprHsArgsApp,
43 LHsTypeArg, lhsTypeArgSrcSpan,
44 OutputableBndrFlag,
45
46 LBangType, BangType,
47 HsSrcBang(..), HsImplBang(..),
48 SrcStrictness(..), SrcUnpackedness(..),
49 getBangType, getBangStrictness,
50
51 ConDeclField(..), LConDeclField, pprConDeclFields,
52
53 HsConDetails(..), noTypeArgs,
54
55 FieldOcc(..), LFieldOcc, mkFieldOcc,
56 AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,
57 rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
58 unambiguousFieldOcc, ambiguousFieldOcc,
59
60 mkAnonWildCardTy, pprAnonWildCard,
61
62 hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,
63 mkHsOuterImplicit, mkHsOuterExplicit,
64 mkHsImplicitSigType, mkHsExplicitSigType,
65 mkHsWildCardBndrs, mkHsPatSigType,
66 mkEmptyWildCardBndrs,
67 mkHsForAllVisTele, mkHsForAllInvisTele,
68 mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,
69 isHsKindedTyVar, hsTvbAllKinded,
70 hsScopedTvs, hsWcScopedTvs, dropWildCards,
71 hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
72 hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
73 splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
74 splitLHsPatSynTy,
75 splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,
76 splitLHsSigmaTyInvis, splitLHsGadtTy,
77 splitHsFunType, hsTyGetAppHead_maybe,
78 mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
79 ignoreParens, hsSigWcType, hsPatSigType,
80 hsTyKindSig,
81 setHsTyVarBndrFlag, hsTyVarBndrFlag,
82
83 -- Printing
84 pprHsType, pprHsForAll,
85 pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,
86 pprLHsContext,
87 hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
88 ) where
89
90 import GHC.Prelude
91
92 import Language.Haskell.Syntax.Type
93
94 import {-# SOURCE #-} GHC.Hs.Expr ( pprSplice )
95
96 import Language.Haskell.Syntax.Extension
97 import GHC.Hs.Extension
98 import GHC.Parser.Annotation
99
100 import GHC.Types.Id ( Id )
101 import GHC.Types.SourceText
102 import GHC.Types.Name( Name, NamedThing(getName) )
103 import GHC.Types.Name.Reader ( RdrName )
104 import GHC.Types.Var ( VarBndr )
105 import GHC.Core.TyCo.Rep ( Type(..) )
106 import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )
107 import GHC.Core.Type
108 import GHC.Hs.Doc
109 import GHC.Types.Basic
110 import GHC.Types.SrcLoc
111 import GHC.Utils.Outputable
112
113 import Data.Maybe
114
115 import qualified Data.Semigroup as S
116
117 {-
118 ************************************************************************
119 * *
120 \subsection{Bang annotations}
121 * *
122 ************************************************************************
123 -}
124
125 getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)
126 getBangType (L _ (HsBangTy _ _ lty)) = lty
127 getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
128 addCLocA lty lds (HsDocTy x lty lds)
129 getBangType lty = lty
130
131 getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang
132 getBangStrictness (L _ (HsBangTy _ s _)) = s
133 getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s
134 getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
135
136 {-
137 ************************************************************************
138 * *
139 \subsection{Data types}
140 * *
141 ************************************************************************
142 -}
143
144 fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
145 fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
146
147 type instance XHsForAllVis (GhcPass _) = EpAnnForallTy
148 -- Location of 'forall' and '->'
149 type instance XHsForAllInvis (GhcPass _) = EpAnnForallTy
150 -- Location of 'forall' and '.'
151
152 type instance XXHsForAllTelescope (GhcPass _) = NoExtCon
153
154 type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn)
155 -- ^ Location of 'forall' and '->' for HsForAllVis
156 -- Location of 'forall' and '.' for HsForAllInvis
157
158 type HsQTvsRn = [Name] -- Implicit variables
159 -- For example, in data T (a :: k1 -> k2) = ...
160 -- the 'a' is explicit while 'k1', 'k2' are implicit
161
162 type instance XHsQTvs GhcPs = NoExtField
163 type instance XHsQTvs GhcRn = HsQTvsRn
164 type instance XHsQTvs GhcTc = HsQTvsRn
165
166 type instance XXLHsQTyVars (GhcPass _) = NoExtCon
167
168 mkHsForAllVisTele ::EpAnnForallTy ->
169 [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
170 mkHsForAllVisTele an vis_bndrs =
171 HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs }
172
173 mkHsForAllInvisTele :: EpAnnForallTy
174 -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)
175 mkHsForAllInvisTele an invis_bndrs =
176 HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs }
177
178 mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
179 mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }
180
181 emptyLHsQTvs :: LHsQTyVars GhcRn
182 emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }
183
184 ------------------------------------------------
185 -- HsOuterTyVarBndrs
186
187 type instance XHsOuterImplicit GhcPs = NoExtField
188 type instance XHsOuterImplicit GhcRn = [Name]
189 type instance XHsOuterImplicit GhcTc = [TyVar]
190
191 type instance XHsOuterExplicit GhcPs _ = EpAnnForallTy
192 type instance XHsOuterExplicit GhcRn _ = NoExtField
193 type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag]
194
195 type instance XXHsOuterTyVarBndrs (GhcPass _) = NoExtCon
196
197 type instance XHsWC GhcPs b = NoExtField
198 type instance XHsWC GhcRn b = [Name]
199 type instance XHsWC GhcTc b = [Name]
200
201 type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon
202
203 type instance XHsPS GhcPs = EpAnn EpaLocation
204 type instance XHsPS GhcRn = HsPSRn
205 type instance XHsPS GhcTc = HsPSRn
206
207 type instance XXHsPatSigType (GhcPass _) = NoExtCon
208
209 type instance XHsSig (GhcPass _) = NoExtField
210 type instance XXHsSigType (GhcPass _) = NoExtCon
211
212 hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p
213 hsSigWcType = sig_body . unXRec @p . hswc_body
214
215 dropWildCards :: LHsSigWcType pass -> LHsSigType pass
216 -- Drop the wildcard part of a LHsSigWcType
217 dropWildCards sig_ty = hswc_body sig_ty
218
219 hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]
220 hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs
221 hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs}) = hsLTyVarNames bndrs
222
223 hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)
224 -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
225 hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs
226 hsOuterExplicitBndrs (HsOuterImplicit{}) = []
227
228 mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs
229 mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField}
230
231 mkHsOuterExplicit :: EpAnnForallTy -> [LHsTyVarBndr flag GhcPs]
232 -> HsOuterTyVarBndrs flag GhcPs
233 mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an
234 , hso_bndrs = bndrs }
235
236 mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs
237 mkHsImplicitSigType body =
238 HsSig { sig_ext = noExtField
239 , sig_bndrs = mkHsOuterImplicit, sig_body = body }
240
241 mkHsExplicitSigType :: EpAnnForallTy
242 -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs
243 -> HsSigType GhcPs
244 mkHsExplicitSigType an bndrs body =
245 HsSig { sig_ext = noExtField
246 , sig_bndrs = mkHsOuterExplicit an bndrs, sig_body = body }
247
248 mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
249 mkHsWildCardBndrs x = HsWC { hswc_body = x
250 , hswc_ext = noExtField }
251
252 mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs
253 mkHsPatSigType ann x = HsPS { hsps_ext = ann
254 , hsps_body = x }
255
256 mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
257 mkEmptyWildCardBndrs x = HsWC { hswc_body = x
258 , hswc_ext = [] }
259
260 --------------------------------------------------
261
262 type instance XUserTyVar (GhcPass _) = EpAnn [AddEpAnn]
263 type instance XKindedTyVar (GhcPass _) = EpAnn [AddEpAnn]
264
265 type instance XXTyVarBndr (GhcPass _) = NoExtCon
266
267 -- | Return the attached flag
268 hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag
269 hsTyVarBndrFlag (UserTyVar _ fl _) = fl
270 hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl
271
272 -- | Set the attached flag
273 setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)
274 -> HsTyVarBndr flag (GhcPass pass)
275 setHsTyVarBndrFlag f (UserTyVar x _ l) = UserTyVar x f l
276 setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k
277
278 -- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
279 hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool
280 hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
281
282 instance NamedThing (HsTyVarBndr flag GhcRn) where
283 getName (UserTyVar _ _ v) = unLoc v
284 getName (KindedTyVar _ _ v _) = unLoc v
285
286 type instance XForAllTy (GhcPass _) = NoExtField
287 type instance XQualTy (GhcPass _) = NoExtField
288 type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn]
289 type instance XAppTy (GhcPass _) = NoExtField
290 type instance XFunTy (GhcPass _) = EpAnnCO
291 type instance XListTy (GhcPass _) = EpAnn AnnParen
292 type instance XTupleTy (GhcPass _) = EpAnn AnnParen
293 type instance XSumTy (GhcPass _) = EpAnn AnnParen
294 type instance XOpTy (GhcPass _) = NoExtField
295 type instance XParTy (GhcPass _) = EpAnn AnnParen
296 type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn]
297 type instance XStarTy (GhcPass _) = NoExtField
298 type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn]
299
300 type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives
301
302 type instance XSpliceTy GhcPs = NoExtField
303 type instance XSpliceTy GhcRn = NoExtField
304 type instance XSpliceTy GhcTc = Kind
305
306 type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn]
307 type instance XBangTy (GhcPass _) = EpAnn [AddEpAnn]
308
309 type instance XRecTy GhcPs = EpAnn AnnList
310 type instance XRecTy GhcRn = NoExtField
311 type instance XRecTy GhcTc = NoExtField
312
313 type instance XExplicitListTy GhcPs = EpAnn [AddEpAnn]
314 type instance XExplicitListTy GhcRn = NoExtField
315 type instance XExplicitListTy GhcTc = Kind
316
317 type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn]
318 type instance XExplicitTupleTy GhcRn = NoExtField
319 type instance XExplicitTupleTy GhcTc = [Kind]
320
321 type instance XTyLit (GhcPass _) = NoExtField
322
323 type instance XWildCardTy (GhcPass _) = NoExtField
324
325 type instance XXType (GhcPass _) = HsCoreTy
326
327
328 oneDataConHsTy :: HsType GhcRn
329 oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName)
330
331 manyDataConHsTy :: HsType GhcRn
332 manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName)
333
334 hsLinear :: a -> HsScaled (GhcPass p) a
335 hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok))
336
337 hsUnrestricted :: a -> HsScaled (GhcPass p) a
338 hsUnrestricted = HsScaled (HsUnrestrictedArrow noHsUniTok)
339
340 isUnrestricted :: HsArrow GhcRn -> Bool
341 isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName
342 isUnrestricted _ = False
343
344 -- | Convert an arrow into its corresponding multiplicity. In essence this
345 -- erases the information of whether the programmer wrote an explicit
346 -- multiplicity or a shorthand.
347 arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn
348 arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy
349 arrowToHsType (HsLinearArrow _) = noLocA oneDataConHsTy
350 arrowToHsType (HsExplicitMult _ p _) = p
351
352 instance
353 (OutputableBndrId pass) =>
354 Outputable (HsArrow (GhcPass pass)) where
355 ppr arr = parens (pprHsArrow arr)
356
357 -- See #18846
358 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc
359 pprHsArrow (HsUnrestrictedArrow _) = arrow
360 pprHsArrow (HsLinearArrow _) = lollipop
361 pprHsArrow (HsExplicitMult _ p _) = mulArrow (ppr p)
362
363 type instance XConDeclField (GhcPass _) = EpAnn [AddEpAnn]
364 type instance XXConDeclField (GhcPass _) = NoExtCon
365
366 instance OutputableBndrId p
367 => Outputable (ConDeclField (GhcPass p)) where
368 ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
369
370 ---------------------
371 hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
372 -- Get the lexically-scoped type variables of an LHsSigWcType:
373 -- - the explicitly-given forall'd type variables;
374 -- see Note [Lexically scoped type variables]
375 -- - the named wildcards; see Note [Scoping of named wildcards]
376 -- because they scope in the same way
377 hsWcScopedTvs sig_wc_ty
378 | HsWC { hswc_ext = nwcs, hswc_body = sig_ty } <- sig_wc_ty
379 , L _ (HsSig{sig_bndrs = outer_bndrs}) <- sig_ty
380 = nwcs ++ hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)
381 -- See Note [hsScopedTvs and visible foralls]
382
383 hsScopedTvs :: LHsSigType GhcRn -> [Name]
384 -- Same as hsWcScopedTvs, but for a LHsSigType
385 hsScopedTvs (L _ (HsSig{sig_bndrs = outer_bndrs}))
386 = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)
387 -- See Note [hsScopedTvs and visible foralls]
388
389 ---------------------
390 hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
391 hsTyVarName (UserTyVar _ _ (L _ n)) = n
392 hsTyVarName (KindedTyVar _ _ (L _ n) _) = n
393
394 hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
395 hsLTyVarName = hsTyVarName . unLoc
396
397 hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]
398 hsLTyVarNames = map hsLTyVarName
399
400 hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]
401 -- Explicit variables only
402 hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)
403
404 hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]
405 -- All variables
406 hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
407 , hsq_explicit = tvs })
408 = kvs ++ hsLTyVarNames tvs
409
410 hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
411 hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)
412
413 hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
414 hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
415
416 -- | Get the kind signature of a type, ignoring parentheses:
417 --
418 -- hsTyKindSig `Maybe ` = Nothing
419 -- hsTyKindSig `Maybe :: Type -> Type ` = Just `Type -> Type`
420 -- hsTyKindSig `Maybe :: ((Type -> Type))` = Just `Type -> Type`
421 --
422 -- This is used to extract the result kind of type synonyms with a CUSK:
423 --
424 -- type S = (F :: res_kind)
425 -- ^^^^^^^^
426 --
427 hsTyKindSig :: LHsType (GhcPass p) -> Maybe (LHsKind (GhcPass p))
428 hsTyKindSig lty =
429 case unLoc lty of
430 HsParTy _ lty' -> hsTyKindSig lty'
431 HsKindSig _ _ k -> Just k
432 _ -> Nothing
433
434 ---------------------
435 ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p)
436 ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
437 ignoreParens ty = ty
438
439 {-
440 ************************************************************************
441 * *
442 Building types
443 * *
444 ************************************************************************
445 -}
446
447 mkAnonWildCardTy :: HsType GhcPs
448 mkAnonWildCardTy = HsWildCardTy noExtField
449
450 mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)
451 => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))
452 -> LHsType (GhcPass p) -> HsType (GhcPass p)
453 mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2
454
455 mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
456 mkHsAppTy t1 t2
457 = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))
458
459 mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
460 -> LHsType (GhcPass p)
461 mkHsAppTys = foldl' mkHsAppTy
462
463 mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
464 -> LHsType (GhcPass p)
465 mkHsAppKindTy ext ty k
466 = addCLocAA ty k (HsAppKindTy ext ty k)
467
468 {-
469 ************************************************************************
470 * *
471 Decomposing HsTypes
472 * *
473 ************************************************************************
474 -}
475
476 ---------------------------------
477 -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
478 -- Breaks up any parens in the result type:
479 -- splitHsFunType (a -> (b -> c)) = ([a,b], c)
480 -- It returns API Annotations for any parens removed
481 splitHsFunType ::
482 LHsType (GhcPass p)
483 -> ( [AddEpAnn], EpAnnComments -- The locations of any parens and
484 -- comments discarded
485 , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
486 splitHsFunType ty = go ty
487 where
488 go (L l (HsParTy an ty))
489 = let
490 (anns, cs, args, res) = splitHsFunType ty
491 anns' = anns ++ annParen2AddEpAnn an
492 cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an
493 in (anns', cs', args, res)
494
495 go (L ll (HsFunTy (EpAnn _ _ cs) mult x y))
496 | (anns, csy, args, res) <- splitHsFunType y
497 = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res)
498 where
499 L l t = x
500 x' = L (addCommentsToSrcAnn l cs) t
501
502 go other = ([], emptyComments, [], other)
503
504 -- | Retrieve the name of the \"head\" of a nested type application.
505 -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more
506 -- thorough. The purpose of this function is to examine instance heads, so it
507 -- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.).
508 hsTyGetAppHead_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN)
509 => LHsType (GhcPass p)
510 -> Maybe (LocatedN (IdP (GhcPass p)))
511 hsTyGetAppHead_maybe = go
512 where
513 go (L _ (HsTyVar _ _ ln)) = Just ln
514 go (L _ (HsAppTy _ l _)) = go l
515 go (L _ (HsAppKindTy _ t _)) = go t
516 go (L _ (HsOpTy _ _ ln _)) = Just ln
517 go (L _ (HsParTy _ t)) = go t
518 go (L _ (HsKindSig _ t _)) = go t
519 go _ = Nothing
520
521 ------------------------------------------------------------
522
523 -- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.
524 lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan
525 lhsTypeArgSrcSpan arg = case arg of
526 HsValArg tm -> getLocA tm
527 HsTypeArg at ty -> at `combineSrcSpans` getLocA ty
528 HsArgPar sp -> sp
529
530 --------------------------------
531
532 -- | Decompose a pattern synonym type signature into its constituent parts.
533 --
534 -- Note that this function looks through parentheses, so it will work on types
535 -- such as @(forall a. <...>)@. The downside to this is that it is not
536 -- generally possible to take the returned types and reconstruct the original
537 -- type (parentheses and all) from them.
538 splitLHsPatSynTy ::
539 LHsSigType (GhcPass p)
540 -> ( [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))] -- universals
541 , Maybe (LHsContext (GhcPass p)) -- required constraints
542 , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials
543 , Maybe (LHsContext (GhcPass p)) -- provided constraints
544 , LHsType (GhcPass p)) -- body type
545 splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
546 where
547 -- split_sig_ty ::
548 -- LHsSigType (GhcPass p)
549 -- -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], LHsType (GhcPass p))
550 split_sig_ty (L _ HsSig{sig_bndrs = outer_bndrs, sig_body = body}) =
551 case outer_bndrs of
552 -- NB: Use ignoreParens here in order to be consistent with the use of
553 -- splitLHsForAllTyInvis below, which also looks through parentheses.
554 HsOuterImplicit{} -> ([], ignoreParens body)
555 HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body)
556
557 (univs, ty1) = split_sig_ty ty
558 (reqs, ty2) = splitLHsQualTy ty1
559 ((_an, exis), ty3) = splitLHsForAllTyInvis ty2
560 (provs, ty4) = splitLHsQualTy ty3
561
562 -- | Decompose a sigma type (of the form @forall <tvs>. context => body@)
563 -- into its constituent parts.
564 -- Only splits type variable binders that were
565 -- quantified invisibly (e.g., @forall a.@, with a dot).
566 --
567 -- This function is used to split apart certain types, such as instance
568 -- declaration types, which disallow visible @forall@s. For instance, if GHC
569 -- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that
570 -- declaration would mistakenly be accepted!
571 --
572 -- Note that this function looks through parentheses, so it will work on types
573 -- such as @(forall a. <...>)@. The downside to this is that it is not
574 -- generally possible to take the returned types and reconstruct the original
575 -- type (parentheses and all) from them.
576 splitLHsSigmaTyInvis :: LHsType (GhcPass p)
577 -> ([LHsTyVarBndr Specificity (GhcPass p)]
578 , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))
579 splitLHsSigmaTyInvis ty
580 | ((_an,tvs), ty1) <- splitLHsForAllTyInvis ty
581 , (ctxt, ty2) <- splitLHsQualTy ty1
582 = (tvs, ctxt, ty2)
583
584 -- | Decompose a GADT type into its constituent parts.
585 -- Returns @(outer_bndrs, mb_ctxt, body)@, where:
586 --
587 -- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost
588 -- type variable binders. Otherwise, they are 'HsOuterImplicit'.
589 --
590 -- * @mb_ctxt@ is @Just@ the context, if it is provided.
591 -- Otherwise, it is @Nothing@.
592 --
593 -- * @body@ is the body of the type after the optional @forall@s and context.
594 --
595 -- This function is careful not to look through parentheses.
596 -- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
597 -- "GHC.Hs.Decls" for why this is important.
598 splitLHsGadtTy ::
599 LHsSigType GhcPs
600 -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs)
601 splitLHsGadtTy (L _ sig_ty)
602 | (outer_bndrs, rho_ty) <- split_bndrs sig_ty
603 , (mb_ctxt, tau_ty) <- splitLHsQualTy_KP rho_ty
604 = (outer_bndrs, mb_ctxt, tau_ty)
605 where
606 split_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
607 split_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =
608 (outer_bndrs, body_ty)
609
610 -- | Decompose a type of the form @forall <tvs>. body@ into its constituent
611 -- parts. Only splits type variable binders that
612 -- were quantified invisibly (e.g., @forall a.@, with a dot).
613 --
614 -- This function is used to split apart certain types, such as instance
615 -- declaration types, which disallow visible @forall@s. For instance, if GHC
616 -- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that
617 -- declaration would mistakenly be accepted!
618 --
619 -- Note that this function looks through parentheses, so it will work on types
620 -- such as @(forall a. <...>)@. The downside to this is that it is not
621 -- generally possible to take the returned types and reconstruct the original
622 -- type (parentheses and all) from them.
623 -- Unlike 'splitLHsSigmaTyInvis', this function does not look through
624 -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
625 splitLHsForAllTyInvis ::
626 LHsType (GhcPass pass) -> ( (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])
627 , LHsType (GhcPass pass))
628 splitLHsForAllTyInvis ty
629 | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)
630 = (fromMaybe (EpAnnNotUsed,[]) mb_tvbs, body)
631
632 -- | Decompose a type of the form @forall <tvs>. body@ into its constituent
633 -- parts. Only splits type variable binders that
634 -- were quantified invisibly (e.g., @forall a.@, with a dot).
635 --
636 -- This function is used to split apart certain types, such as instance
637 -- declaration types, which disallow visible @forall@s. For instance, if GHC
638 -- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that
639 -- declaration would mistakenly be accepted!
640 --
641 -- Unlike 'splitLHsForAllTyInvis', this function does not look through
642 -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
643 splitLHsForAllTyInvis_KP ::
644 LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])
645 , LHsType (GhcPass pass))
646 splitLHsForAllTyInvis_KP lty@(L _ ty) =
647 case ty of
648 HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an
649 , hsf_invis_bndrs = tvs }
650 , hst_body = body }
651 -> (Just (an, tvs), body)
652 _ -> (Nothing, lty)
653
654 -- | Decompose a type of the form @context => body@ into its constituent parts.
655 --
656 -- Note that this function looks through parentheses, so it will work on types
657 -- such as @(context => <...>)@. The downside to this is that it is not
658 -- generally possible to take the returned types and reconstruct the original
659 -- type (parentheses and all) from them.
660 splitLHsQualTy :: LHsType (GhcPass pass)
661 -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
662 splitLHsQualTy ty
663 | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty)
664 = (mb_ctxt, body)
665
666 -- | Decompose a type of the form @context => body@ into its constituent parts.
667 --
668 -- Unlike 'splitLHsQualTy', this function does not look through
669 -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
670 splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
671 splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))
672 = (Just ctxt, body)
673 splitLHsQualTy_KP body = (Nothing, body)
674
675 -- | Decompose a type class instance type (of the form
676 -- @forall <tvs>. context => instance_head@) into its constituent parts.
677 -- Note that the @[Name]@s returned correspond to either:
678 --
679 -- * The implicitly bound type variables (if the type lacks an outermost
680 -- @forall@), or
681 --
682 -- * The explicitly bound type variables (if the type has an outermost
683 -- @forall@).
684 --
685 -- This function is careful not to look through parentheses.
686 -- See @Note [No nested foralls or contexts in instance types]@
687 -- for why this is important.
688 splitLHsInstDeclTy :: LHsSigType GhcRn
689 -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)
690 splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =
691 (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty)
692 where
693 (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty
694
695 -- | Decompose a type class instance type (of the form
696 -- @forall <tvs>. context => instance_head@) into the @instance_head@.
697 getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)
698 getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty}))
699 | (_mb_cxt, body_ty) <- splitLHsQualTy_KP qual_ty
700 = body_ty
701
702 -- | Decompose a type class instance type (of the form
703 -- @forall <tvs>. context => instance_head@) into the @instance_head@ and
704 -- retrieve the underlying class type constructor (if it exists).
705 getLHsInstDeclClass_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN)
706 => LHsSigType (GhcPass p)
707 -> Maybe (LocatedN (IdP (GhcPass p)))
708 -- Works on (LHsSigType GhcPs)
709 getLHsInstDeclClass_maybe inst_ty
710 = do { let head_ty = getLHsInstDeclHead inst_ty
711 ; hsTyGetAppHead_maybe head_ty
712 }
713
714 {-
715 Note [No nested foralls or contexts in instance types]
716 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
717 The type at the top of an instance declaration is one of the few places in GHC
718 where nested `forall`s or contexts are not permitted, even with RankNTypes
719 enabled. For example, the following will be rejected:
720
721 instance forall a. forall b. Show (Either a b) where ...
722 instance Eq a => Eq b => Show (Either a b) where ...
723 instance (forall a. Show (Maybe a)) where ...
724 instance (Eq a => Show (Maybe a)) where ...
725
726 This restriction is partly motivated by an unusual quirk of instance
727 declarations. Namely, if ScopedTypeVariables is enabled, then the type
728 variables from the top of an instance will scope over the bodies of the
729 instance methods, /even if the type variables are implicitly quantified/.
730 For example, GHC will accept the following:
731
732 instance Monoid a => Monoid (Identity a) where
733 mempty = Identity (mempty @a)
734
735 Moreover, the type in the top of an instance declaration must obey the
736 forall-or-nothing rule (see Note [forall-or-nothing rule]).
737 If instance types allowed nested `forall`s, this could
738 result in some strange interactions. For example, consider the following:
739
740 class C a where
741 m :: Proxy a
742 instance (forall a. C (Either a b)) where
743 m = Proxy @(Either a b)
744
745 Somewhat surprisingly, old versions of GHC would accept the instance above.
746 Even though the `forall` only quantifies `a`, the outermost parentheses mean
747 that the `forall` is nested, and per the forall-or-nothing rule, this means
748 that implicit quantification would occur. Therefore, the `a` is explicitly
749 bound and the `b` is implicitly bound. Moreover, ScopedTypeVariables would
750 bring /both/ sorts of type variables into scope over the body of `m`.
751 How utterly confusing!
752
753 To avoid this sort of confusion, we simply disallow nested `forall`s in
754 instance types, which makes things like the instance above become illegal.
755 For the sake of consistency, we also disallow nested contexts, even though they
756 don't have the same strange interaction with ScopedTypeVariables.
757
758 Just as we forbid nested `forall`s and contexts in normal instance
759 declarations, we also forbid them in SPECIALISE instance pragmas (#18455).
760 Unlike normal instance declarations, ScopedTypeVariables don't have any impact
761 on SPECIALISE instance pragmas, but we use the same validity checks for
762 SPECIALISE instance pragmas anyway to be consistent.
763
764 -----
765 -- Wrinkle: Derived instances
766 -----
767
768 `deriving` clauses and standalone `deriving` declarations also permit bringing
769 type variables into scope, either through explicit or implicit quantification.
770 Unlike in the tops of instance declarations, however, one does not need to
771 enable ScopedTypeVariables for this to take effect.
772
773 Just as GHC forbids nested `forall`s in the top of instance declarations, it
774 also forbids them in types involved with `deriving`:
775
776 1. In the `via` types in DerivingVia. For example, this is rejected:
777
778 deriving via (forall x. V x) instance C (S x)
779
780 Just like the types in instance declarations, `via` types can also bring
781 both implicitly and explicitly bound type variables into scope. As a result,
782 we adopt the same no-nested-`forall`s rule in `via` types to avoid confusing
783 behavior like in the example below:
784
785 deriving via (forall x. T x y) instance W x y (Foo a b)
786 -- Both x and y are brought into scope???
787 2. In the classes in `deriving` clauses. For example, this is rejected:
788
789 data T = MkT deriving (C1, (forall x. C2 x y))
790
791 This is because the generated instance would look like:
792
793 instance forall x y. C2 x y T where ...
794
795 So really, the same concerns as instance declarations apply here as well.
796 -}
797
798 {-
799 ************************************************************************
800 * *
801 FieldOcc
802 * *
803 ************************************************************************
804 -}
805
806 type instance XCFieldOcc GhcPs = NoExtField
807 type instance XCFieldOcc GhcRn = Name
808 type instance XCFieldOcc GhcTc = Id
809
810 type instance XXFieldOcc (GhcPass _) = NoExtCon
811
812 mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs
813 mkFieldOcc rdr = FieldOcc noExtField rdr
814
815
816 type instance XUnambiguous GhcPs = NoExtField
817 type instance XUnambiguous GhcRn = Name
818 type instance XUnambiguous GhcTc = Id
819
820 type instance XAmbiguous GhcPs = NoExtField
821 type instance XAmbiguous GhcRn = NoExtField
822 type instance XAmbiguous GhcTc = Id
823
824 type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon
825
826 instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
827 ppr = ppr . rdrNameAmbiguousFieldOcc
828
829 instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
830 pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
831 pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
832
833 instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where
834 pprInfixOcc = pprInfixOcc . unLoc
835 pprPrefixOcc = pprPrefixOcc . unLoc
836
837 mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs
838 mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr
839
840 rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
841 rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
842 rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr
843
844 selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
845 selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
846 selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
847
848 unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
849 unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
850 unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
851
852 ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
853 ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
854
855 {-
856 ************************************************************************
857 * *
858 \subsection{Pretty printing}
859 * *
860 ************************************************************************
861 -}
862
863 class OutputableBndrFlag flag p where
864 pprTyVarBndr :: OutputableBndrId p
865 => HsTyVarBndr flag (GhcPass p) -> SDoc
866
867 instance OutputableBndrFlag () p where
868 pprTyVarBndr (UserTyVar _ _ n) -- = pprIdP n
869 = case ghcPass @p of
870 GhcPs -> ppr n
871 GhcRn -> ppr n
872 GhcTc -> ppr n
873 pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr_n, dcolon, ppr k]
874 where
875 ppr_n = case ghcPass @p of
876 GhcPs -> ppr n
877 GhcRn -> ppr n
878 GhcTc -> ppr n
879
880 instance OutputableBndrFlag Specificity p where
881 pprTyVarBndr (UserTyVar _ SpecifiedSpec n) -- = pprIdP n
882 = case ghcPass @p of
883 GhcPs -> ppr n
884 GhcRn -> ppr n
885 GhcTc -> ppr n
886 pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr_n
887 where
888 ppr_n = case ghcPass @p of
889 GhcPs -> ppr n
890 GhcRn -> ppr n
891 GhcTc -> ppr n
892 pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr_n, dcolon, ppr k]
893 where
894 ppr_n = case ghcPass @p of
895 GhcPs -> ppr n
896 GhcRn -> ppr n
897 GhcTc -> ppr n
898 pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr_n, dcolon, ppr k]
899 where
900 ppr_n = case ghcPass @p of
901 GhcPs -> ppr n
902 GhcRn -> ppr n
903 GhcTc -> ppr n
904
905 instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where
906 ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =
907 pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body
908
909 instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where
910 ppr ty = pprHsType ty
911
912 instance OutputableBndrId p
913 => Outputable (LHsQTyVars (GhcPass p)) where
914 ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
915
916 instance (OutputableBndrFlag flag p,
917 OutputableBndrFlag flag (NoGhcTcPass p),
918 OutputableBndrId p)
919 => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where
920 ppr (HsOuterImplicit{hso_ximplicit = imp_tvs}) =
921 text "HsOuterImplicit:" <+> case ghcPass @p of
922 GhcPs -> ppr imp_tvs
923 GhcRn -> ppr imp_tvs
924 GhcTc -> ppr imp_tvs
925 ppr (HsOuterExplicit{hso_bndrs = exp_tvs}) =
926 text "HsOuterExplicit:" <+> ppr exp_tvs
927
928 instance OutputableBndrId p
929 => Outputable (HsForAllTelescope (GhcPass p)) where
930 ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =
931 text "HsForAllVis:" <+> ppr bndrs
932 ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =
933 text "HsForAllInvis:" <+> ppr bndrs
934
935 instance (OutputableBndrId p, OutputableBndrFlag flag p)
936 => Outputable (HsTyVarBndr flag (GhcPass p)) where
937 ppr = pprTyVarBndr
938
939 instance Outputable thing
940 => Outputable (HsWildCardBndrs (GhcPass p) thing) where
941 ppr (HsWC { hswc_body = ty }) = ppr ty
942
943 instance (OutputableBndrId p)
944 => Outputable (HsPatSigType (GhcPass p)) where
945 ppr (HsPS { hsps_body = ty }) = ppr ty
946
947 pprAnonWildCard :: SDoc
948 pprAnonWildCard = char '_'
949
950 -- | Prints the explicit @forall@ in a type family equation if one is written.
951 -- If there is no explicit @forall@, nothing is printed.
952 pprHsOuterFamEqnTyVarBndrs :: OutputableBndrId p
953 => HsOuterFamEqnTyVarBndrs (GhcPass p) -> SDoc
954 pprHsOuterFamEqnTyVarBndrs (HsOuterImplicit{}) = empty
955 pprHsOuterFamEqnTyVarBndrs (HsOuterExplicit{hso_bndrs = qtvs}) =
956 forAllLit <+> interppSP qtvs <> dot
957
958 -- | Prints the outermost @forall@ in a type signature if one is written.
959 -- If there is no outermost @forall@, nothing is printed.
960 pprHsOuterSigTyVarBndrs :: OutputableBndrId p
961 => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc
962 pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty
963 pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =
964 pprHsForAll (mkHsForAllInvisTele noAnn bndrs) Nothing
965
966 -- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@
967 -- only when @-dppr-debug@ is enabled.
968 pprHsForAll :: forall p. OutputableBndrId p
969 => HsForAllTelescope (GhcPass p)
970 -> Maybe (LHsContext (GhcPass p)) -> SDoc
971 pprHsForAll tele cxt
972 = pp_tele tele <+> pprLHsContext cxt
973 where
974 pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc
975 pp_tele tele = case tele of
976 HsForAllVis { hsf_vis_bndrs = qtvs } -> pp_forall (space <> arrow) qtvs
977 HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs
978
979 pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p)
980 => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc
981 pp_forall separator qtvs
982 | null qtvs = whenPprDebug (forAllLit <> separator)
983 -- Note: to fix the PprRecordDotSyntax1 ppr roundtrip test, the <>
984 -- below needs to be <+>. But it means 94 other test results need to
985 -- be updated to match.
986 | otherwise = forAllLit <+> interppSP qtvs <> separator
987
988 pprLHsContext :: (OutputableBndrId p)
989 => Maybe (LHsContext (GhcPass p)) -> SDoc
990 pprLHsContext Nothing = empty
991 pprLHsContext (Just lctxt) = pprLHsContextAlways lctxt
992
993 -- For use in a HsQualTy, which always gets printed if it exists.
994 pprLHsContextAlways :: (OutputableBndrId p)
995 => LHsContext (GhcPass p) -> SDoc
996 pprLHsContextAlways (L _ ctxt)
997 = case ctxt of
998 [] -> parens empty <+> darrow
999 [L _ ty] -> ppr_mono_ty ty <+> darrow
1000 _ -> parens (interpp'SP ctxt) <+> darrow
1001
1002 pprConDeclFields :: OutputableBndrId p
1003 => [LConDeclField (GhcPass p)] -> SDoc
1004 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
1005 where
1006 ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
1007 cd_fld_doc = doc }))
1008 = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
1009
1010 ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc
1011 ppr_names [n] = pprPrefixOcc n
1012 ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))
1013
1014 {-
1015 Note [Printing KindedTyVars]
1016 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1017 #3830 reminded me that we should really only print the kind
1018 signature on a KindedTyVar if the kind signature was put there by the
1019 programmer. During kind inference GHC now adds a PostTcKind to UserTyVars,
1020 rather than converting to KindedTyVars as before.
1021
1022 (As it happens, the message in #3830 comes out a different way now,
1023 and the problem doesn't show up; but having the flag on a KindedTyVar
1024 seems like the Right Thing anyway.)
1025 -}
1026
1027 -- Printing works more-or-less as for Types
1028
1029 pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
1030 pprHsType ty = ppr_mono_ty ty
1031
1032 ppr_mono_lty :: OutputableBndrId p
1033 => LHsType (GhcPass p) -> SDoc
1034 ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
1035
1036 ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
1037 ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })
1038 = sep [pprHsForAll tele Nothing, ppr_mono_lty ty]
1039
1040 ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
1041 = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]
1042
1043 ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
1044 ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
1045 ppr_mono_ty (HsTyVar _ prom (L _ name))
1046 | isPromoted prom = quote (pprPrefixOcc name)
1047 | otherwise = pprPrefixOcc name
1048 ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2
1049 ppr_mono_ty (HsTupleTy _ con tys)
1050 -- Special-case unary boxed tuples so that they are pretty-printed as
1051 -- `Solo x`, not `(x)`
1052 | [ty] <- tys
1053 , BoxedTuple <- std_con
1054 = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]
1055 | otherwise
1056 = tupleParens std_con (pprWithCommas ppr tys)
1057 where std_con = case con of
1058 HsUnboxedTuple -> UnboxedTuple
1059 _ -> BoxedTuple
1060 ppr_mono_ty (HsSumTy _ tys)
1061 = tupleParens UnboxedTuple (pprWithBars ppr tys)
1062 ppr_mono_ty (HsKindSig _ ty kind)
1063 = ppr_mono_lty ty <+> dcolon <+> ppr kind
1064 ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty)
1065 ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
1066 ppr_mono_ty (HsSpliceTy _ s) = pprSplice s
1067 ppr_mono_ty (HsExplicitListTy _ prom tys)
1068 | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)
1069 | otherwise = brackets (interpp'SP tys)
1070 ppr_mono_ty (HsExplicitTupleTy _ tys)
1071 -- Special-case unary boxed tuples so that they are pretty-printed as
1072 -- `'Solo x`, not `'(x)`
1073 | [ty] <- tys
1074 = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]
1075 | otherwise
1076 = quote $ parens (maybeAddSpace tys $ interpp'SP tys)
1077 ppr_mono_ty (HsTyLit _ t) = ppr t
1078 ppr_mono_ty (HsWildCardTy {}) = char '_'
1079
1080 ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*')
1081
1082 ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
1083 = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
1084 ppr_mono_ty (HsAppKindTy _ ty k)
1085 = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k
1086 ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
1087 = sep [ ppr_mono_lty ty1
1088 , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
1089
1090 ppr_mono_ty (HsParTy _ ty)
1091 = parens (ppr_mono_lty ty)
1092 -- Put the parens in where the user did
1093 -- But we still use the precedence stuff to add parens because
1094 -- toHsType doesn't put in any HsParTys, so we may still need them
1095
1096 ppr_mono_ty (HsDocTy _ ty doc)
1097 -- AZ: Should we add parens? Should we introduce "-- ^"?
1098 = ppr_mono_lty ty <+> ppr (unLoc doc)
1099 -- we pretty print Haddock comments on types as if they were
1100 -- postfix operators
1101
1102 ppr_mono_ty (XHsType t) = ppr t
1103
1104 --------------------------
1105 ppr_fun_ty :: (OutputableBndrId p)
1106 => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
1107 ppr_fun_ty mult ty1 ty2
1108 = let p1 = ppr_mono_lty ty1
1109 p2 = ppr_mono_lty ty2
1110 arr = pprHsArrow mult
1111 in
1112 sep [p1, arr <+> p2]
1113
1114 --------------------------
1115 -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
1116 -- under precedence @p@.
1117 hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool
1118 hsTypeNeedsParens p = go_hs_ty
1119 where
1120 go_hs_ty (HsForAllTy{}) = p >= funPrec
1121 go_hs_ty (HsQualTy{}) = p >= funPrec
1122 go_hs_ty (HsBangTy{}) = p > topPrec
1123 go_hs_ty (HsRecTy{}) = False
1124 go_hs_ty (HsTyVar{}) = False
1125 go_hs_ty (HsFunTy{}) = p >= funPrec
1126 -- Special-case unary boxed tuple applications so that they are
1127 -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
1128 -- See Note [One-tuples] in GHC.Builtin.Types
1129 go_hs_ty (HsTupleTy _ con [_])
1130 = case con of
1131 HsBoxedOrConstraintTuple -> p >= appPrec
1132 HsUnboxedTuple -> False
1133 go_hs_ty (HsTupleTy{}) = False
1134 go_hs_ty (HsSumTy{}) = False
1135 go_hs_ty (HsKindSig{}) = p >= sigPrec
1136 go_hs_ty (HsListTy{}) = False
1137 go_hs_ty (HsIParamTy{}) = p > topPrec
1138 go_hs_ty (HsSpliceTy{}) = False
1139 go_hs_ty (HsExplicitListTy{}) = False
1140 -- Special-case unary boxed tuple applications so that they are
1141 -- parenthesized as `Proxy ('Solo x)`, not `Proxy 'Solo x` (#18612)
1142 -- See Note [One-tuples] in GHC.Builtin.Types
1143 go_hs_ty (HsExplicitTupleTy _ [_])
1144 = p >= appPrec
1145 go_hs_ty (HsExplicitTupleTy{}) = False
1146 go_hs_ty (HsTyLit{}) = False
1147 go_hs_ty (HsWildCardTy{}) = False
1148 go_hs_ty (HsStarTy{}) = p >= starPrec
1149 go_hs_ty (HsAppTy{}) = p >= appPrec
1150 go_hs_ty (HsAppKindTy{}) = p >= appPrec
1151 go_hs_ty (HsOpTy{}) = p >= opPrec
1152 go_hs_ty (HsParTy{}) = False
1153 go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t
1154 go_hs_ty (XHsType ty) = go_core_ty ty
1155
1156 go_core_ty (TyVarTy{}) = False
1157 go_core_ty (AppTy{}) = p >= appPrec
1158 go_core_ty (TyConApp _ args)
1159 | null args = False
1160 | otherwise = p >= appPrec
1161 go_core_ty (ForAllTy{}) = p >= funPrec
1162 go_core_ty (FunTy{}) = p >= funPrec
1163 go_core_ty (LitTy{}) = False
1164 go_core_ty (CastTy t _) = go_core_ty t
1165 go_core_ty (CoercionTy{}) = False
1166
1167 maybeAddSpace :: [LHsType (GhcPass p)] -> SDoc -> SDoc
1168 -- See Note [Printing promoted type constructors]
1169 -- in GHC.Iface.Type. This code implements the same
1170 -- logic for printing HsType
1171 maybeAddSpace tys doc
1172 | (ty : _) <- tys
1173 , lhsTypeHasLeadingPromotionQuote ty = space <> doc
1174 | otherwise = doc
1175
1176 lhsTypeHasLeadingPromotionQuote :: LHsType (GhcPass p) -> Bool
1177 lhsTypeHasLeadingPromotionQuote ty
1178 = goL ty
1179 where
1180 goL (L _ ty) = go ty
1181
1182 go (HsForAllTy{}) = False
1183 go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})
1184 | (L _ (c:_)) <- ctxt = goL c
1185 | otherwise = goL body
1186 go (HsBangTy{}) = False
1187 go (HsRecTy{}) = False
1188 go (HsTyVar _ p _) = isPromoted p
1189 go (HsFunTy _ _ arg _) = goL arg
1190 go (HsListTy{}) = False
1191 go (HsTupleTy{}) = False
1192 go (HsSumTy{}) = False
1193 go (HsOpTy _ t1 _ _) = goL t1
1194 go (HsKindSig _ t _) = goL t
1195 go (HsIParamTy{}) = False
1196 go (HsSpliceTy{}) = False
1197 go (HsExplicitListTy _ p _) = isPromoted p
1198 go (HsExplicitTupleTy{}) = True
1199 go (HsTyLit{}) = False
1200 go (HsWildCardTy{}) = False
1201 go (HsStarTy{}) = False
1202 go (HsAppTy _ t _) = goL t
1203 go (HsAppKindTy _ t _) = goL t
1204 go (HsParTy{}) = False
1205 go (HsDocTy _ t _) = goL t
1206 go (XHsType{}) = False
1207
1208 -- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
1209 -- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
1210 -- returns @ty@.
1211 parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
1212 parenthesizeHsType p lty@(L loc ty)
1213 | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty)
1214 | otherwise = lty
1215
1216 -- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint
1217 -- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@
1218 -- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply
1219 -- returns @ctxt@ unchanged.
1220 parenthesizeHsContext :: PprPrec
1221 -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
1222 parenthesizeHsContext p lctxt@(L loc ctxt) =
1223 case ctxt of
1224 [c] -> L loc [parenthesizeHsType p c]
1225 _ -> lctxt -- Other contexts are already "parenthesized" by virtue of
1226 -- being tuples.
1227 {-
1228 ************************************************************************
1229 * *
1230 \subsection{Anno instances}
1231 * *
1232 ************************************************************************
1233 -}
1234
1235 type instance Anno (BangType (GhcPass p)) = SrcSpanAnnA
1236 type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC
1237 type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA
1238 type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA
1239 type instance Anno (HsKind (GhcPass p)) = SrcSpanAnnA
1240
1241 type instance Anno (HsTyVarBndr _flag (GhcPass _)) = SrcSpanAnnA
1242 -- Explicit pass Anno instances needed because of the NoGhcTc field
1243 type instance Anno (HsTyVarBndr _flag GhcPs) = SrcSpanAnnA
1244 type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA
1245 type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA
1246
1247 type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA
1248 type instance Anno HsIPName = SrcAnn NoEpAnns
1249 type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA
1250
1251 type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns
1252 type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns