{-# LANGUAGE AllowAmbiguousTypes #-} -- for pprIfTc, etc. {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax import GHC.Prelude import GHC.TypeLits (KnownSymbol, symbolVal) import Data.Data hiding ( Fixity ) import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Utils.Outputable hiding ((<>)) import GHC.Types.SrcLoc (GenLocated(..), unLoc) import GHC.Utils.Panic import GHC.Parser.Annotation {- Note [IsPass] ~~~~~~~~~~~~~ One challenge with the Trees That Grow approach is that we sometimes have different information in different passes. For example, we have type instance XViaStrategy GhcPs = LHsSigType GhcPs type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type This means that printing a DerivStrategy (which contains an XViaStrategy) might need to print a LHsSigType, or it might need to print a type. Yet we want one Outputable instance for a DerivStrategy, instead of one per pass. We could have a large constraint, including e.g. (Outputable (XViaStrategy p), Outputable (XViaStrategy GhcTc)), and pass that around in every context where we might output a DerivStrategy. But a simpler alternative is to pass a witness to whichever pass we're in. When we pattern-match on that (GADT) witness, we learn the pass identity and can then print away. To wit, we get the definition of GhcPass and the functions isPass. These allow us to do away with big constraints, passing around all manner of dictionaries we might or might not use. It does mean that we have to manually use isPass when printing, but these places are few. See Note [NoGhcTc] about the superclass constraint to IsPass. Note [NoGhcTc] ~~~~~~~~~~~~~~ An expression is parsed into HsExpr GhcPs, renamed into HsExpr GhcRn, and then type-checked into HsExpr GhcTc. Not so for types! These get parsed into HsType GhcPs, renamed into HsType GhcRn, and then type-checked into Type. We never build an HsType GhcTc. Why do this? Because we need to be able to compare type-checked types for equality, and we don't want to do this with HsType. This causes wrinkles within the AST, where we normally think that the whole AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc. For example, this is used in ExprWithTySig: | ExprWithTySig (XExprWithTySig p) (LHsExpr p) (LHsSigWcType (NoGhcTc p)) If we have (e :: ty), we still want to be able to print that (with the :: ty) after type-checking. So we retain the LHsSigWcType GhcRn, even in an HsExpr GhcTc. That's what NoGhcTc does. When we're printing the type annotation, we need to know (Outputable (LHsSigWcType GhcRn)), even though we've assumed only that (OutputableBndrId GhcTc). We thus must be able to prove OutputableBndrId (NoGhcTc p) from OutputableBndrId p. The extra constraints in OutputableBndrId and the superclass constraints of IsPass allow this. Note that the superclass constraint of IsPass is *recursive*: it asserts that IsPass (NoGhcTcPass p) holds. For this to make sense, we need -XUndecidableSuperClasses and the other constraint, saying that NoGhcTcPass is idempotent. -} -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation type instance XRec (GhcPass p) a = GenLocated (Anno a) a type instance Anno RdrName = SrcSpanAnnN type instance Anno Name = SrcSpanAnnN type instance Anno Id = SrcSpanAnnN type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), IsPass p) instance UnXRec (GhcPass p) where unXRec :: forall a. XRec (GhcPass p) a -> a unXRec = XRec (GhcPass p) a -> a GenLocated (Anno a) a -> a forall l e. GenLocated l e -> e unLoc instance MapXRec (GhcPass p) where mapXRec :: forall a b. (Anno a ~ Anno b) => (a -> b) -> XRec (GhcPass p) a -> XRec (GhcPass p) b mapXRec = (a -> b) -> XRec (GhcPass p) a -> XRec (GhcPass p) b (a -> b) -> GenLocated (Anno b) a -> GenLocated (Anno b) b forall a b. (a -> b) -> GenLocated (Anno b) a -> GenLocated (Anno b) b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap -- instance WrapXRec (GhcPass p) a where -- wrapXRec = noLocA {- Note [DataConCantHappen and strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, any unused TTG extension constructor will generally look like the following: type instance XXHsDecl (GhcPass _) = DataConCantHappen data HsDecl p = ... | XHsDecl !(XXHsDecl p) The field of type `XXHsDecl p` is strict for a good reason: it allows the pattern-match coverage checker to conclude that any matches against XHsDecl are unreachable whenever `p ~ GhcPass _`. To see why this is the case, consider the following function which consumes an HsDecl: ex :: HsDecl GhcPs -> HsDecl GhcRn ... ex (XHsDecl nec) = dataConCantHappen nec Because `p` equals GhcPs (i.e., GhcPass 'Parsed), XHsDecl's field has the type DataConCantHappen. But since (1) the field is strict and (2) DataConCantHappen is an empty data type, there is no possible way to reach the right-hand side of the XHsDecl case. As a result, the coverage checker concludes that the XHsDecl case is inaccessible, so it can be removed. (See Note [Strict argument type constraints] in GHC.HsToCore.Pmc.Solver for more on how this works.) Bottom line: if you add a TTG extension constructor that uses DataConCantHappen, make sure that any uses of it as a field are strict. -} -- | Used as a data type index for the hsSyn AST; also serves -- as a singleton type for Pass data GhcPass (c :: Pass) where GhcPs :: GhcPass 'Parsed GhcRn :: GhcPass 'Renamed GhcTc :: GhcPass 'Typechecked -- This really should never be entered, but the data-deriving machinery -- needs the instance to exist. instance Typeable p => Data (GhcPass p) where gunfold :: forall (c :: * -> *). (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c (GhcPass p) gunfold forall b r. Data b => c (b -> r) -> c r _ forall r. r -> c r _ Constr _ = String -> c (GhcPass p) forall a. HasCallStack => String -> a panic String "instance Data GhcPass" toConstr :: GhcPass p -> Constr toConstr GhcPass p _ = String -> Constr forall a. HasCallStack => String -> a panic String "instance Data GhcPass" dataTypeOf :: GhcPass p -> DataType dataTypeOf GhcPass p _ = String -> DataType forall a. HasCallStack => String -> a panic String "instance Data GhcPass" data Pass = Parsed | Renamed | Typechecked deriving (Typeable Pass Typeable Pass => (forall (c :: * -> *). (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> Pass -> c Pass) -> (forall (c :: * -> *). (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c Pass) -> (Pass -> Constr) -> (Pass -> DataType) -> (forall (t :: * -> *) (c :: * -> *). Typeable t => (forall d. Data d => c (t d)) -> Maybe (c Pass)) -> (forall (t :: * -> * -> *) (c :: * -> *). Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Pass)) -> ((forall b. Data b => b -> b) -> Pass -> Pass) -> (forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r) -> (forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r) -> (forall u. (forall d. Data d => d -> u) -> Pass -> [u]) -> (forall u. Int -> (forall d. Data d => d -> u) -> Pass -> u) -> (forall (m :: * -> *). Monad m => (forall d. Data d => d -> m d) -> Pass -> m Pass) -> (forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> Pass -> m Pass) -> (forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> Pass -> m Pass) -> Data Pass Pass -> Constr Pass -> DataType (forall b. Data b => b -> b) -> Pass -> Pass forall a. Typeable a => (forall (c :: * -> *). (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> a -> c a) -> (forall (c :: * -> *). (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a) -> (a -> Constr) -> (a -> DataType) -> (forall (t :: * -> *) (c :: * -> *). Typeable t => (forall d. Data d => c (t d)) -> Maybe (c a)) -> (forall (t :: * -> * -> *) (c :: * -> *). Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a)) -> ((forall b. Data b => b -> b) -> a -> a) -> (forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r) -> (forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r) -> (forall u. (forall d. Data d => d -> u) -> a -> [u]) -> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u) -> (forall (m :: * -> *). Monad m => (forall d. Data d => d -> m d) -> a -> m a) -> (forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a) -> (forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a) -> Data a forall u. Int -> (forall d. Data d => d -> u) -> Pass -> u forall u. (forall d. Data d => d -> u) -> Pass -> [u] forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r forall (m :: * -> *). Monad m => (forall d. Data d => d -> m d) -> Pass -> m Pass forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> Pass -> m Pass forall (c :: * -> *). (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c Pass forall (c :: * -> *). (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> Pass -> c Pass forall (t :: * -> *) (c :: * -> *). Typeable t => (forall d. Data d => c (t d)) -> Maybe (c Pass) forall (t :: * -> * -> *) (c :: * -> *). Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Pass) $cgfoldl :: forall (c :: * -> *). (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> Pass -> c Pass gfoldl :: forall (c :: * -> *). (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> Pass -> c Pass $cgunfold :: forall (c :: * -> *). (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c Pass gunfold :: forall (c :: * -> *). (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c Pass $ctoConstr :: Pass -> Constr toConstr :: Pass -> Constr $cdataTypeOf :: Pass -> DataType dataTypeOf :: Pass -> DataType $cdataCast1 :: forall (t :: * -> *) (c :: * -> *). Typeable t => (forall d. Data d => c (t d)) -> Maybe (c Pass) dataCast1 :: forall (t :: * -> *) (c :: * -> *). Typeable t => (forall d. Data d => c (t d)) -> Maybe (c Pass) $cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *). Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Pass) dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *). Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Pass) $cgmapT :: (forall b. Data b => b -> b) -> Pass -> Pass gmapT :: (forall b. Data b => b -> b) -> Pass -> Pass $cgmapQl :: forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r gmapQl :: forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r $cgmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r gmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Pass -> r $cgmapQ :: forall u. (forall d. Data d => d -> u) -> Pass -> [u] gmapQ :: forall u. (forall d. Data d => d -> u) -> Pass -> [u] $cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Pass -> u gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Pass -> u $cgmapM :: forall (m :: * -> *). Monad m => (forall d. Data d => d -> m d) -> Pass -> m Pass gmapM :: forall (m :: * -> *). Monad m => (forall d. Data d => d -> m d) -> Pass -> m Pass $cgmapMp :: forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> Pass -> m Pass gmapMp :: forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> Pass -> m Pass $cgmapMo :: forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> Pass -> m Pass gmapMo :: forall (m :: * -> *). MonadPlus m => (forall d. Data d => d -> m d) -> Pass -> m Pass Data) -- Type synonyms as a shorthand for tagging type GhcPs = GhcPass 'Parsed -- Output of parser type GhcRn = GhcPass 'Renamed -- Output of renamer type GhcTc = GhcPass 'Typechecked -- Output of typechecker -- | Allows us to check what phase we're in at GHC's runtime. -- For example, this class allows us to write -- > f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah -- > f e = case ghcPass @p of -- > GhcPs -> ... in this RHS we have HsExpr GhcPs... -- > GhcRn -> ... in this RHS we have HsExpr GhcRn... -- > GhcTc -> ... in this RHS we have HsExpr GhcTc... -- which is very useful, for example, when pretty-printing. -- See Note [IsPass]. class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p , IsPass (NoGhcTcPass p) ) => IsPass p where ghcPass :: GhcPass p instance IsPass 'Parsed where ghcPass :: GhcPass 'Parsed ghcPass = GhcPass 'Parsed GhcPs instance IsPass 'Renamed where ghcPass :: GhcPass 'Renamed ghcPass = GhcPass 'Renamed GhcRn instance IsPass 'Typechecked where ghcPass :: GhcPass 'Typechecked ghcPass = GhcPass 'Typechecked GhcTc type instance IdP (GhcPass p) = IdGhcP p -- | Maps the "normal" id type for a given GHC pass type family IdGhcP pass where IdGhcP 'Parsed = RdrName IdGhcP 'Renamed = Name IdGhcP 'Typechecked = Id -- | Marks that a field uses the GhcRn variant even when the pass -- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because -- HsType GhcTc should never occur. -- See Note [NoGhcTc] -- Breaking it up this way, GHC can figure out that the result is a GhcPass type instance NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) type family NoGhcTcPass (p :: Pass) :: Pass where NoGhcTcPass 'Typechecked = 'Renamed NoGhcTcPass other = other -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. type OutputableBndrId pass = ( OutputableBndr (IdGhcP pass) , OutputableBndr (IdGhcP (NoGhcTcPass pass)) , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass)) , Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass))) , IsPass pass ) -- useful helper functions: pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc pprIfPs :: forall (p :: Pass). IsPass p => ((p ~ 'Parsed) => SDoc) -> SDoc pprIfPs (p ~ 'Parsed) => SDoc pp = case forall (p :: Pass). IsPass p => GhcPass p ghcPass @p of GhcPass p GhcPs -> SDoc (p ~ 'Parsed) => SDoc pp GhcPass p _ -> SDoc forall doc. IsOutput doc => doc empty pprIfRn :: forall p. IsPass p => (p ~ 'Renamed => SDoc) -> SDoc pprIfRn :: forall (p :: Pass). IsPass p => ((p ~ 'Renamed) => SDoc) -> SDoc pprIfRn (p ~ 'Renamed) => SDoc pp = case forall (p :: Pass). IsPass p => GhcPass p ghcPass @p of GhcPass p GhcRn -> SDoc (p ~ 'Renamed) => SDoc pp GhcPass p _ -> SDoc forall doc. IsOutput doc => doc empty pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc pprIfTc :: forall (p :: Pass). IsPass p => ((p ~ 'Typechecked) => SDoc) -> SDoc pprIfTc (p ~ 'Typechecked) => SDoc pp = case forall (p :: Pass). IsPass p => GhcPass p ghcPass @p of GhcPass p GhcTc -> SDoc (p ~ 'Typechecked) => SDoc pp GhcPass p _ -> SDoc forall doc. IsOutput doc => doc empty type instance Anno (HsToken tok) = TokenLocation noHsTok :: GenLocated TokenLocation (HsToken tok) noHsTok :: forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok) noHsTok = TokenLocation -> HsToken tok -> GenLocated TokenLocation (HsToken tok) forall l e. l -> e -> GenLocated l e L TokenLocation NoTokenLoc HsToken tok forall (tok :: Symbol). HsToken tok HsTok type instance Anno (HsUniToken tok utok) = TokenLocation noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok) noHsUniTok :: forall (tok :: Symbol) (utok :: Symbol). GenLocated TokenLocation (HsUniToken tok utok) noHsUniTok = TokenLocation -> HsUniToken tok utok -> GenLocated TokenLocation (HsUniToken tok utok) forall l e. l -> e -> GenLocated l e L TokenLocation NoTokenLoc HsUniToken tok utok forall (tok :: Symbol) (utok :: Symbol). HsUniToken tok utok HsNormalTok --- Outputable instance Outputable NoExtField where ppr :: NoExtField -> SDoc ppr NoExtField _ = String -> SDoc forall doc. IsLine doc => String -> doc text String "NoExtField" instance Outputable DataConCantHappen where ppr :: DataConCantHappen -> SDoc ppr = DataConCantHappen -> SDoc forall a. DataConCantHappen -> a dataConCantHappen instance KnownSymbol tok => Outputable (HsToken tok) where ppr :: HsToken tok -> SDoc ppr HsToken tok _ = String -> SDoc forall doc. IsLine doc => String -> doc text (Proxy tok -> String forall (n :: Symbol) (proxy :: Symbol -> *). KnownSymbol n => proxy n -> String symbolVal (Proxy tok forall {k} (t :: k). Proxy t Proxy :: Proxy tok)) instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where ppr :: HsUniToken tok utok -> SDoc ppr HsUniToken tok utok HsNormalTok = String -> SDoc forall doc. IsLine doc => String -> doc text (Proxy tok -> String forall (n :: Symbol) (proxy :: Symbol -> *). KnownSymbol n => proxy n -> String symbolVal (Proxy tok forall {k} (t :: k). Proxy t Proxy :: Proxy tok)) ppr HsUniToken tok utok HsUnicodeTok = String -> SDoc forall doc. IsLine doc => String -> doc text (Proxy utok -> String forall (n :: Symbol) (proxy :: Symbol -> *). KnownSymbol n => proxy n -> String symbolVal (Proxy utok forall {k} (t :: k). Proxy t Proxy :: Proxy utok)) deriving instance Typeable p => Data (LayoutInfo (GhcPass p))