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