{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Haddock.GhcUtils
-- Copyright   :  (c) David Waern 2006-2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Utils for dealing with types from the GHC API
module Haddock.GhcUtils where

import Control.Arrow
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import Data.Char (isSpace)
import Data.Foldable (toList)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import GHC
import GHC.Builtin.Types (liftedRepTy)
import GHC.Core.TyCo.Rep (Type (..))
import GHC.Core.Type (binderVar, isRuntimeRepVar)
import GHC.Data.StringBuffer (StringBuffer)
import qualified GHC.Data.StringBuffer as S
import GHC.Driver.Session
import GHC.HsToCore.Docs hiding (sigNameNoLoc)
import GHC.Platform (Platform (..))
import GHC.Types.Name
import GHC.Types.SrcLoc (advanceSrcLoc)
import GHC.Types.Var
  ( Specificity
  , TyVarBinder
  , VarBndr (..)
  , isInvisibleForAllTyFlag
  , tyVarKind
  , updateTyVarKind
  )
import GHC.Types.Var.Env (TyVarEnv, elemVarEnv, emptyVarEnv, extendVarEnv)
import GHC.Types.Var.Set (VarSet, emptyVarSet)
import GHC.Utils.FV as FV
import GHC.Utils.Outputable (Outputable, SDocContext, ppr)
import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (panic)

import Haddock.Types (DocName, DocNameI, Interface (..), XRecCond)

moduleString :: Module -> String
moduleString :: Module -> String
moduleString = ModuleName -> String
moduleNameString (ModuleName -> String)
-> (Module -> ModuleName) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName

isNameSym :: Name -> Bool
isNameSym :: Name -> Bool
isNameSym = OccName -> Bool
isSymOcc (OccName -> Bool) -> (Name -> OccName) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName

-- Useful when there is a signature with multiple names, e.g.
--   foo, bar :: Types..
-- but only one of the names is exported and we have to change the
-- type signature to only include the exported names.
filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p))
filterLSigNames :: forall (p :: Pass).
(IdP (GhcPass p) -> Bool)
-> LSig (GhcPass p) -> Maybe (LSig (GhcPass p))
filterLSigNames IdP (GhcPass p) -> Bool
p (L SrcSpanAnnA
loc Sig (GhcPass p)
sig) = SrcSpanAnnA
-> Sig (GhcPass p) -> GenLocated SrcSpanAnnA (Sig (GhcPass p))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Sig (GhcPass p) -> GenLocated SrcSpanAnnA (Sig (GhcPass p)))
-> Maybe (Sig (GhcPass p))
-> Maybe (GenLocated SrcSpanAnnA (Sig (GhcPass p)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((IdP (GhcPass p) -> Bool)
-> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall (p :: Pass).
(IdP (GhcPass p) -> Bool)
-> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
filterSigNames IdP (GhcPass p) -> Bool
p Sig (GhcPass p)
sig)

filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
filterSigNames :: forall (p :: Pass).
(IdP (GhcPass p) -> Bool)
-> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
filterSigNames IdP (GhcPass p) -> Bool
p orig :: Sig (GhcPass p)
orig@(SpecSig XSpecSig (GhcPass p)
_ LIdP (GhcPass p)
n [LHsSigType (GhcPass p)]
_ InlinePragma
_) = Bool -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall name. Bool -> name -> Maybe name
ifTrueJust (IdP (GhcPass p) -> Bool
p (IdP (GhcPass p) -> Bool) -> IdP (GhcPass p) -> Bool
forall a b. (a -> b) -> a -> b
$ GenLocated (Anno (IdGhcP p)) (IdP (GhcPass p)) -> IdP (GhcPass p)
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass p)
GenLocated (Anno (IdGhcP p)) (IdP (GhcPass p))
n) Sig (GhcPass p)
orig
filterSigNames IdP (GhcPass p) -> Bool
p orig :: Sig (GhcPass p)
orig@(InlineSig XInlineSig (GhcPass p)
_ LIdP (GhcPass p)
n InlinePragma
_) = Bool -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall name. Bool -> name -> Maybe name
ifTrueJust (IdP (GhcPass p) -> Bool
p (IdP (GhcPass p) -> Bool) -> IdP (GhcPass p) -> Bool
forall a b. (a -> b) -> a -> b
$ GenLocated (Anno (IdGhcP p)) (IdP (GhcPass p)) -> IdP (GhcPass p)
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass p)
GenLocated (Anno (IdGhcP p)) (IdP (GhcPass p))
n) Sig (GhcPass p)
orig
filterSigNames IdP (GhcPass p) -> Bool
p (FixSig XFixSig (GhcPass p)
_ (FixitySig XFixitySig (GhcPass p)
ns_spec [LIdP (GhcPass p)]
ns Fixity
ty)) =
  case (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> Bool)
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
IdGhcP p -> Bool
p (IdGhcP p -> Bool)
-> (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p)
-> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p
forall l e. GenLocated l e -> e
unLoc) [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
ns of
    [] -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just (XFixSig (GhcPass p) -> FixitySig (GhcPass p) -> Sig (GhcPass p)
forall pass. XFixSig pass -> FixitySig pass -> Sig pass
FixSig ((EpaLocation, Maybe EpaLocation), SourceText)
XFixSig (GhcPass p)
forall a. NoAnn a => a
noAnn (XFixitySig (GhcPass p)
-> [LIdP (GhcPass p)] -> Fixity -> FixitySig (GhcPass p)
forall pass.
XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass
FixitySig XFixitySig (GhcPass p)
ns_spec [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered Fixity
ty))
filterSigNames IdP (GhcPass p) -> Bool
_ orig :: Sig (GhcPass p)
orig@(MinimalSig XMinimalSig (GhcPass p)
_ LBooleanFormula (GhcPass p)
_) = Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just Sig (GhcPass p)
orig
filterSigNames IdP (GhcPass p) -> Bool
p (TypeSig XTypeSig (GhcPass p)
_ [LIdP (GhcPass p)]
ns LHsSigWcType (GhcPass p)
ty) =
  case (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> Bool)
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
IdGhcP p -> Bool
p (IdGhcP p -> Bool)
-> (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p)
-> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p
forall l e. GenLocated l e -> e
unLoc) [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
ns of
    [] -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just (XTypeSig (GhcPass p)
-> [LIdP (GhcPass p)]
-> LHsSigWcType (GhcPass p)
-> Sig (GhcPass p)
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig (GhcPass p)
AnnSig
forall a. NoAnn a => a
noAnn [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered LHsSigWcType (GhcPass p)
ty)
filterSigNames IdP (GhcPass p) -> Bool
p (ClassOpSig XClassOpSig (GhcPass p)
_ Bool
is_default [LIdP (GhcPass p)]
ns LHsSigType (GhcPass p)
ty) =
  case (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> Bool)
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
IdGhcP p -> Bool
p (IdGhcP p -> Bool)
-> (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p)
-> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p
forall l e. GenLocated l e -> e
unLoc) [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
ns of
    [] -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just (XClassOpSig (GhcPass p)
-> Bool
-> [LIdP (GhcPass p)]
-> LHsSigType (GhcPass p)
-> Sig (GhcPass p)
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig (GhcPass p)
AnnSig
forall a. NoAnn a => a
noAnn Bool
is_default [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered LHsSigType (GhcPass p)
ty)
filterSigNames IdP (GhcPass p) -> Bool
p (PatSynSig XPatSynSig (GhcPass p)
_ [LIdP (GhcPass p)]
ns LHsSigType (GhcPass p)
ty) =
  case (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> Bool)
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
-> [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
IdGhcP p -> Bool
p (IdGhcP p -> Bool)
-> (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p)
-> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> IdGhcP p
forall l e. GenLocated l e -> e
unLoc) [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
ns of
    [] -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just (XPatSynSig (GhcPass p)
-> [LIdP (GhcPass p)] -> LHsSigType (GhcPass p) -> Sig (GhcPass p)
forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig XPatSynSig (GhcPass p)
AnnSig
forall a. NoAnn a => a
noAnn [LIdP (GhcPass p)]
[GenLocated (Anno (IdGhcP p)) (IdGhcP p)]
filtered LHsSigType (GhcPass p)
ty)
filterSigNames IdP (GhcPass p) -> Bool
_ Sig (GhcPass p)
_ = Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing

ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust :: forall name. Bool -> name -> Maybe name
ifTrueJust Bool
True = name -> Maybe name
forall a. a -> Maybe a
Just
ifTrueJust Bool
False = Maybe name -> name -> Maybe name
forall a b. a -> b -> a
const Maybe name
forall a. Maybe a
Nothing

sigName :: LSig GhcRn -> [IdP GhcRn]
sigName :: LSig GhcRn -> [IdP GhcRn]
sigName (L SrcSpanAnnA
_ Sig GhcRn
sig) = OccEnv (ZonkAny 1) -> Sig GhcRn -> [IdP GhcRn]
forall pass w. UnXRec pass => w -> Sig pass -> [IdP pass]
sigNameNoLoc' OccEnv (ZonkAny 1)
forall a. OccEnv a
emptyOccEnv Sig GhcRn
sig

sigNameNoLoc' :: forall pass w. UnXRec pass => w -> Sig pass -> [IdP pass]
sigNameNoLoc' :: forall pass w. UnXRec pass => w -> Sig pass -> [IdP pass]
sigNameNoLoc' w
_ (TypeSig XTypeSig pass
_ [LIdP pass]
ns LHsSigWcType pass
_) = (LIdP pass -> IdP pass) -> [LIdP pass] -> [IdP pass]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc' w
_ (ClassOpSig XClassOpSig pass
_ Bool
_ [LIdP pass]
ns LHsSigType pass
_) = (LIdP pass -> IdP pass) -> [LIdP pass] -> [IdP pass]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc' w
_ (PatSynSig XPatSynSig pass
_ [LIdP pass]
ns LHsSigType pass
_) = (LIdP pass -> IdP pass) -> [LIdP pass] -> [IdP pass]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc' w
_ (SpecSig XSpecSig pass
_ LIdP pass
n [LHsSigType pass]
_ InlinePragma
_) = [forall p a. UnXRec p => XRec p a -> a
unXRec @pass LIdP pass
n]
sigNameNoLoc' w
_ (InlineSig XInlineSig pass
_ LIdP pass
n InlinePragma
_) = [forall p a. UnXRec p => XRec p a -> a
unXRec @pass LIdP pass
n]
sigNameNoLoc' w
_ (FixSig XFixSig pass
_ (FixitySig XFixitySig pass
_ [LIdP pass]
ns Fixity
_)) = (LIdP pass -> IdP pass) -> [LIdP pass] -> [IdP pass]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc' w
_ Sig pass
_ = []

-- | Was this signature given by the user?
isUserLSig :: forall p. UnXRec p => LSig p -> Bool
isUserLSig :: forall p. UnXRec p => LSig p -> Bool
isUserLSig = Sig p -> Bool
forall name. Sig name -> Bool
isUserSig (Sig p -> Bool)
-> (XRec p (Sig p) -> Sig p) -> XRec p (Sig p) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. UnXRec p => XRec p a -> a
unXRec @p

isClassD :: HsDecl a -> Bool
isClassD :: forall a. HsDecl a -> Bool
isClassD (TyClD XTyClD a
_ TyClDecl a
d) = TyClDecl a -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl TyClDecl a
d
isClassD HsDecl a
_ = Bool
False

pretty :: Outputable a => SDocContext -> a -> String
pretty :: forall a. Outputable a => SDocContext -> a -> String
pretty SDocContext
sDocContext a
thing = SDocContext -> SDoc -> String
Outputable.renderWithContext SDocContext
sDocContext (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
thing)

-- ---------------------------------------------------------------------

-- These functions are duplicated from the GHC API, as they must be
-- instantiated at DocNameI instead of (GhcPass _).

hsTyVarNameI :: HsTyVarBndr flag DocNameI -> Maybe DocName
hsTyVarNameI :: forall flag. HsTyVarBndr flag DocNameI -> Maybe DocName
hsTyVarNameI (HsTvb { tvb_var :: forall flag pass. HsTyVarBndr flag pass -> HsBndrVar pass
tvb_var = HsBndrVar DocNameI
bvar }) = case HsBndrVar DocNameI
bvar of
  HsBndrWildCard XBndrWildCard DocNameI
_    -> Maybe DocName
forall a. Maybe a
Nothing
  HsBndrVar XBndrVar DocNameI
_ (L SrcSpanAnnN
_ DocName
n) -> DocName -> Maybe DocName
forall a. a -> Maybe a
Just DocName
n

hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> Maybe DocName
hsLTyVarNameI :: forall flag. LHsTyVarBndr flag DocNameI -> Maybe DocName
hsLTyVarNameI = HsTyVarBndr flag DocNameI -> Maybe DocName
forall flag. HsTyVarBndr flag DocNameI -> Maybe DocName
hsTyVarNameI (HsTyVarBndr flag DocNameI -> Maybe DocName)
-> (GenLocated SrcSpanAnnA (HsTyVarBndr flag DocNameI)
    -> HsTyVarBndr flag DocNameI)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag DocNameI)
-> Maybe DocName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsTyVarBndr flag DocNameI)
-> HsTyVarBndr flag DocNameI
forall l e. GenLocated l e -> e
unLoc

getConNamesI :: ConDecl DocNameI -> NonEmpty (LocatedN DocName)
getConNamesI :: ConDecl DocNameI -> NonEmpty (GenLocated SrcSpanAnnN DocName)
getConNamesI ConDeclH98{con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = LIdP DocNameI
name} = GenLocated SrcSpanAnnN DocName
-> NonEmpty (GenLocated SrcSpanAnnN DocName)
forall a. a -> NonEmpty a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure LIdP DocNameI
GenLocated SrcSpanAnnN DocName
name
getConNamesI ConDeclGADT{con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names = NonEmpty (LIdP DocNameI)
names} = NonEmpty (LIdP DocNameI)
NonEmpty (GenLocated SrcSpanAnnN DocName)
names

hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
hsSigTypeI = HsSigType DocNameI -> LHsType DocNameI
HsSigType DocNameI -> GenLocated SrcSpanAnnA (HsType DocNameI)
forall pass. HsSigType pass -> LHsType pass
sig_body (HsSigType DocNameI -> GenLocated SrcSpanAnnA (HsType DocNameI))
-> (GenLocated SrcSpanAnnA (HsSigType DocNameI)
    -> HsSigType DocNameI)
-> GenLocated SrcSpanAnnA (HsSigType DocNameI)
-> GenLocated SrcSpanAnnA (HsType DocNameI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsSigType DocNameI) -> HsSigType DocNameI
forall l e. GenLocated l e -> e
unLoc

dropWildCardsI :: LHsSigWcType DocNameI -> LHsSigType DocNameI
-- Drop the wildcard part of a LHsSigWcType
dropWildCardsI :: LHsSigWcType DocNameI -> LHsSigType DocNameI
dropWildCardsI LHsSigWcType DocNameI
sig_ty = HsWildCardBndrs
  DocNameI (GenLocated SrcSpanAnnA (HsSigType DocNameI))
-> GenLocated SrcSpanAnnA (HsSigType DocNameI)
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType DocNameI
HsWildCardBndrs
  DocNameI (GenLocated SrcSpanAnnA (HsSigType DocNameI))
sig_ty

mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
-- Dubious, because the implicit binders are empty even
-- though the type might have free variables
mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
mkEmptySigType lty :: LHsType GhcRn
lty@(L SrcSpanAnnA
loc HsType GhcRn
ty) = SrcSpanAnnA
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$ case HsType GhcRn
ty of
  HsForAllTy
    { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllInvis{hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcRn]
bndrs}
    , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
body
    } ->
      HsSig
        { sig_ext :: XHsSig GhcRn
sig_ext = XHsSig GhcRn
NoExtField
noExtField
        , sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs =
            HsOuterExplicit
              { hso_xexplicit :: XHsOuterExplicit GhcRn Specificity
hso_xexplicit = XHsOuterExplicit GhcRn Specificity
NoExtField
noExtField
              , hso_bndrs :: [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
hso_bndrs = [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
[LHsTyVarBndr Specificity GhcRn]
bndrs
              }
        , sig_body :: LHsType GhcRn
sig_body = LHsType GhcRn
body
        }
  HsType GhcRn
_ ->
    HsSig
      { sig_ext :: XHsSig GhcRn
sig_ext = XHsSig GhcRn
NoExtField
noExtField
      , sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs = HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcRn
hso_ximplicit = []}
      , sig_body :: LHsType GhcRn
sig_body = LHsType GhcRn
lty
      }

mkHsForAllInvisTeleI
  :: [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
mkHsForAllInvisTeleI :: [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
mkHsForAllInvisTeleI [LHsTyVarBndr Specificity DocNameI]
invis_bndrs =
  HsForAllInvis{hsf_xinvis :: XHsForAllInvis DocNameI
hsf_xinvis = XHsForAllInvis DocNameI
NoExtField
noExtField, hsf_invis_bndrs :: [LHsTyVarBndr Specificity DocNameI]
hsf_invis_bndrs = [LHsTyVarBndr Specificity DocNameI]
invis_bndrs}

mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI
mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI
mkHsImplicitSigTypeI LHsType DocNameI
body =
  HsSig
    { sig_ext :: XHsSig DocNameI
sig_ext = XHsSig DocNameI
NoExtField
noExtField
    , sig_bndrs :: HsOuterSigTyVarBndrs DocNameI
sig_bndrs = HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit DocNameI
hso_ximplicit = XHsOuterImplicit DocNameI
NoExtField
noExtField}
    , sig_body :: LHsType DocNameI
sig_body = LHsType DocNameI
body
    }

getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
-- The full type of a GADT data constructor We really only get this in
-- order to pretty-print it, and currently only in Haddock's code.  So
-- we are cavalier about locations and extensions, hence the
-- 'undefined's
getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
getGADTConType
  ( ConDeclGADT
      { con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
_ HsOuterSigTyVarBndrs DocNameI
outer_bndrs
      , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext DocNameI)
mcxt
      , con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = HsConDeclGADTDetails DocNameI
args
      , con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsType DocNameI
res_ty
      }
    ) =
    HsSigType DocNameI -> GenLocated SrcSpanAnnA (HsSigType DocNameI)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA
      ( HsSig
          { sig_ext :: XHsSig DocNameI
sig_ext = XHsSig DocNameI
NoExtField
noExtField
          , sig_bndrs :: HsOuterSigTyVarBndrs DocNameI
sig_bndrs = HsOuterSigTyVarBndrs DocNameI
outer_bndrs
          , sig_body :: LHsType DocNameI
sig_body = LHsType DocNameI
GenLocated SrcSpanAnnA (HsType DocNameI)
theta_ty
          }
      )
    where
      theta_ty :: GenLocated SrcSpanAnnA (HsType DocNameI)
theta_ty
        | Just LHsContext DocNameI
theta <- Maybe (LHsContext DocNameI)
mcxt =
            HsType DocNameI -> GenLocated SrcSpanAnnA (HsType DocNameI)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsQualTy{hst_xqual :: XQualTy DocNameI
hst_xqual = XQualTy DocNameI
forall a. NoAnn a => a
noAnn, hst_ctxt :: LHsContext DocNameI
hst_ctxt = LHsContext DocNameI
theta, hst_body :: LHsType DocNameI
hst_body = LHsType DocNameI
tau_ty})
        | Bool
otherwise =
            LHsType DocNameI
GenLocated SrcSpanAnnA (HsType DocNameI)
tau_ty

      --  tau_ty :: LHsType DocNameI
      tau_ty :: LHsType DocNameI
tau_ty = case HsConDeclGADTDetails DocNameI
args of
        RecConGADT XRecConGADT DocNameI
_ XRec DocNameI [LConDeclField DocNameI]
flds -> LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
mkFunTy (HsType DocNameI -> GenLocated SrcSpanAnnA (HsType DocNameI)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XRecTy DocNameI -> [LConDeclField DocNameI] -> HsType DocNameI
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy XRecTy DocNameI
EpAnn NoEpAnns
forall a. NoAnn a => a
noAnn (GenLocated SrcSpan [GenLocated SrcSpan (ConDeclField DocNameI)]
-> [GenLocated SrcSpan (ConDeclField DocNameI)]
forall l e. GenLocated l e -> e
unLoc XRec DocNameI [LConDeclField DocNameI]
GenLocated SrcSpan [GenLocated SrcSpan (ConDeclField DocNameI)]
flds))) LHsType DocNameI
res_ty
        PrefixConGADT XPrefixConGADT DocNameI
_ [HsScaled DocNameI (LHsType DocNameI)]
pos_args -> (GenLocated SrcSpanAnnA (HsType DocNameI)
 -> GenLocated SrcSpanAnnA (HsType DocNameI)
 -> GenLocated SrcSpanAnnA (HsType DocNameI))
-> GenLocated SrcSpanAnnA (HsType DocNameI)
-> [GenLocated SrcSpanAnnA (HsType DocNameI)]
-> GenLocated SrcSpanAnnA (HsType DocNameI)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
GenLocated SrcSpanAnnA (HsType DocNameI)
-> GenLocated SrcSpanAnnA (HsType DocNameI)
-> GenLocated SrcSpanAnnA (HsType DocNameI)
mkFunTy LHsType DocNameI
GenLocated SrcSpanAnnA (HsType DocNameI)
res_ty ((HsScaled DocNameI (GenLocated SrcSpanAnnA (HsType DocNameI))
 -> GenLocated SrcSpanAnnA (HsType DocNameI))
-> [HsScaled DocNameI (GenLocated SrcSpanAnnA (HsType DocNameI))]
-> [GenLocated SrcSpanAnnA (HsType DocNameI)]
forall a b. (a -> b) -> [a] -> [b]
map HsScaled DocNameI (GenLocated SrcSpanAnnA (HsType DocNameI))
-> GenLocated SrcSpanAnnA (HsType DocNameI)
forall pass a. HsScaled pass a -> a
hsScaledThing [HsScaled DocNameI (LHsType DocNameI)]
[HsScaled DocNameI (GenLocated SrcSpanAnnA (HsType DocNameI))]
pos_args)

      mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
      mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
mkFunTy LHsType DocNameI
a LHsType DocNameI
b = HsType DocNameI -> GenLocated SrcSpanAnnA (HsType DocNameI)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XFunTy DocNameI
-> HsArrow DocNameI
-> LHsType DocNameI
-> LHsType DocNameI
-> HsType DocNameI
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy DocNameI
EpAnn NoEpAnns
forall a. NoAnn a => a
noAnn (XUnrestrictedArrow
  (GenLocated SrcSpanAnnA (HsType DocNameI)) DocNameI
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType DocNameI)) DocNameI
forall mult pass.
XUnrestrictedArrow mult pass -> HsArrowOf mult pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow
  (GenLocated SrcSpanAnnA (HsType DocNameI)) DocNameI
noExtField) LHsType DocNameI
a LHsType DocNameI
b)
getGADTConType (ConDeclH98{}) = String -> GenLocated SrcSpanAnnA (HsSigType DocNameI)
forall a. HasCallStack => String -> a
panic String
"getGADTConType"

-- Should only be called on ConDeclGADT

getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]
getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]
getMainDeclBinderI (TyClD XTyClD DocNameI
_ TyClDecl DocNameI
d) = [TyClDecl DocNameI -> DocName
tcdNameI TyClDecl DocNameI
d]
getMainDeclBinderI (ValD XValD DocNameI
_ HsBind DocNameI
d) =
  case CollectFlag DocNameI -> HsBind DocNameI -> [IdP DocNameI]
forall p idR.
CollectPass p =>
CollectFlag p -> HsBindLR p idR -> [IdP p]
collectHsBindBinders CollectFlag DocNameI
forall p. CollectFlag p
CollNoDictBinders HsBind DocNameI
d of
    [] -> []
    (IdP DocNameI
name : [IdP DocNameI]
_) -> [IdP DocNameI
name]
getMainDeclBinderI (SigD XSigD DocNameI
_ Sig DocNameI
d) = OccEnv (ZonkAny 0) -> Sig DocNameI -> [IdP DocNameI]
forall pass w. UnXRec pass => w -> Sig pass -> [IdP pass]
sigNameNoLoc' OccEnv (ZonkAny 0)
forall a. OccEnv a
emptyOccEnv Sig DocNameI
d
getMainDeclBinderI (ForD XForD DocNameI
_ (ForeignImport XForeignImport DocNameI
_ LIdP DocNameI
name LHsSigType DocNameI
_ ForeignImport DocNameI
_)) = [GenLocated SrcSpanAnnN DocName -> DocName
forall l e. GenLocated l e -> e
unLoc LIdP DocNameI
GenLocated SrcSpanAnnN DocName
name]
getMainDeclBinderI (ForD XForD DocNameI
_ (ForeignExport XForeignExport DocNameI
_ LIdP DocNameI
_ LHsSigType DocNameI
_ ForeignExport DocNameI
_)) = []
getMainDeclBinderI HsDecl DocNameI
_ = []

familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName
familyDeclLNameI :: FamilyDecl DocNameI -> GenLocated SrcSpanAnnN DocName
familyDeclLNameI (FamilyDecl{fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = LIdP DocNameI
n}) = LIdP DocNameI
GenLocated SrcSpanAnnN DocName
n

tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName
tyClDeclLNameI :: TyClDecl DocNameI -> GenLocated SrcSpanAnnN DocName
tyClDeclLNameI (FamDecl{tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl DocNameI
fd}) = FamilyDecl DocNameI -> GenLocated SrcSpanAnnN DocName
familyDeclLNameI FamilyDecl DocNameI
fd
tyClDeclLNameI (SynDecl{tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP DocNameI
ln}) = LIdP DocNameI
GenLocated SrcSpanAnnN DocName
ln
tyClDeclLNameI (DataDecl{tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP DocNameI
ln}) = LIdP DocNameI
GenLocated SrcSpanAnnN DocName
ln
tyClDeclLNameI (ClassDecl{tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP DocNameI
ln}) = LIdP DocNameI
GenLocated SrcSpanAnnN DocName
ln

tcdNameI :: TyClDecl DocNameI -> DocName
tcdNameI :: TyClDecl DocNameI -> DocName
tcdNameI = GenLocated SrcSpanAnnN DocName -> DocName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN DocName -> DocName)
-> (TyClDecl DocNameI -> GenLocated SrcSpanAnnN DocName)
-> TyClDecl DocNameI
-> DocName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl DocNameI -> GenLocated SrcSpanAnnN DocName
tyClDeclLNameI

addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
-- Add the class context to a class-op signature
addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
addClassContext Name
cls LHsQTyVars GhcRn
tvs0 (L SrcSpanAnnA
pos (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [LIdP GhcRn]
lname LHsSigType GhcRn
ltype)) =
  SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos (XTypeSig GhcRn -> [LIdP GhcRn] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn [LIdP GhcRn]
lname (GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> GenLocated SrcSpanAnnA (HsSigType GhcRn)
go_sig_ty LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
ltype)))
  where
    go_sig_ty :: GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> GenLocated SrcSpanAnnA (HsSigType GhcRn)
go_sig_ty (L SrcSpanAnnA
loc (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
ty})) =
      SrcSpanAnnA
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L
        SrcSpanAnnA
loc
        ( HsSig
            { sig_ext :: XHsSig GhcRn
sig_ext = XHsSig GhcRn
NoExtField
noExtField
            , sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
bndrs
            , sig_body :: LHsType GhcRn
sig_body = GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
go_ty LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
            }
        )

    go_ty :: GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
go_ty (L SrcSpanAnnA
loc (HsForAllTy{hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcRn
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty})) =
      SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L
        SrcSpanAnnA
loc
        ( HsForAllTy
            { hst_xforall :: XForAllTy GhcRn
hst_xforall = XForAllTy GhcRn
NoExtField
noExtField
            , hst_tele :: HsForAllTelescope GhcRn
hst_tele = HsForAllTelescope GhcRn
tele
            , hst_body :: LHsType GhcRn
hst_body = GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
go_ty LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
            }
        )
    go_ty (L SrcSpanAnnA
loc (HsQualTy{hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcRn
ctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty})) =
      SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L
        SrcSpanAnnA
loc
        ( HsQualTy
            { hst_xqual :: XQualTy GhcRn
hst_xqual = XQualTy GhcRn
NoExtField
noExtField
            , hst_ctxt :: LHsContext GhcRn
hst_ctxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
add_ctxt LHsContext GhcRn
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
ctxt
            , hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
ty
            }
        )
    go_ty (L SrcSpanAnnA
loc HsType GhcRn
ty) =
      SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L
        SrcSpanAnnA
loc
        ( HsQualTy
            { hst_xqual :: XQualTy GhcRn
hst_xqual = XQualTy GhcRn
NoExtField
noExtField
            , hst_ctxt :: LHsContext GhcRn
hst_ctxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
add_ctxt ([GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [])
            , hst_body :: LHsType GhcRn
hst_body = SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsType GhcRn
ty
            }
        )

    extra_pred :: LHsType GhcRn
extra_pred = PromotionFlag
-> LexicalFixity
-> IdP GhcRn
-> [LHsTypeArg GhcRn]
-> LHsType GhcRn
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag
-> LexicalFixity
-> IdP (GhcPass p)
-> [LHsTypeArg (GhcPass p)]
-> LHsType (GhcPass p)
nlHsTyConApp PromotionFlag
NotPromoted LexicalFixity
Prefix IdP GhcRn
Name
cls (LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes LHsQTyVars GhcRn
tvs0)

    add_ctxt :: GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
add_ctxt (L SrcSpanAnnC
loc [GenLocated SrcSpanAnnA (HsType GhcRn)]
preds) = SrcSpanAnnC
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
loc (LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
extra_pred GenLocated SrcSpanAnnA (HsType GhcRn)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsType GhcRn)]
preds)
addClassContext Name
_ LHsQTyVars GhcRn
_ LSig GhcRn
sig = LSig GhcRn
sig -- E.g. a MinimalSig is fine

lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes LHsQTyVars GhcRn
tvs =
  [ XValArg GhcRn
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
     GhcRn
     (GenLocated SrcSpanAnnA (HsType GhcRn))
     (GenLocated SrcSpanAnnA (HsType GhcRn))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcRn
noExtField (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
     GhcRn
     (GenLocated SrcSpanAnnA (HsType GhcRn))
     (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a b. (a -> b) -> a -> b
$ HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (case LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> Maybe (IdP GhcRn)
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p))
hsLTyVarName LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
tv of
      Maybe (IdP GhcRn)
Nothing -> XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy XWildCardTy GhcRn
NoExtField
noExtField
      Just IdP GhcRn
nm -> XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcRn
EpToken "'"
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA IdP GhcRn
Name
nm))
  | GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
tv <- LHsQTyVars GhcRn -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn]
forall pass.
LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]
hsQTvExplicit LHsQTyVars GhcRn
tvs
  ]

--------------------------------------------------------------------------------

-- * Making abstract declarations

--------------------------------------------------------------------------------

restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo [Name]
names (L SrcSpanAnnA
loc HsDecl GhcRn
decl) = SrcSpanAnnA
-> HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ case HsDecl GhcRn
decl of
  TyClD XTyClD GhcRn
x TyClDecl GhcRn
d
    | DataDecl { tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
dd } <- TyClDecl GhcRn
d
    -> XTyClD GhcRn -> TyClDecl GhcRn -> HsDecl GhcRn
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcRn
x (TyClDecl GhcRn
d {tcdDataDefn = restrictDataDefn names dd})
  TyClD XTyClD GhcRn
x TyClDecl GhcRn
d
    | ClassDecl { tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats } <- TyClDecl GhcRn
d
    -> XTyClD GhcRn -> TyClDecl GhcRn -> HsDecl GhcRn
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcRn
x (TyClDecl GhcRn
d { tcdSigs = restrictDecls names sigs
                  , tcdATs = restrictATs names ats } )
  HsDecl GhcRn
_ -> HsDecl GhcRn
decl

restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
restrictDataDefn [Name]
names HsDataDefn GhcRn
d = HsDataDefn GhcRn
d{dd_cons = restrictDataDefnCons names (dd_cons d)}

restrictDataDefnCons :: [Name] -> DataDefnCons (LConDecl GhcRn) -> DataDefnCons (LConDecl GhcRn)
restrictDataDefnCons :: [Name]
-> DataDefnCons (LConDecl GhcRn) -> DataDefnCons (LConDecl GhcRn)
restrictDataDefnCons [Name]
names = \case
  DataTypeCons Bool
is_type_data [LConDecl GhcRn]
cons -> Bool
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
is_type_data ([Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
forall (m :: Type -> Type).
MonadFail m =>
[Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn)
restrictCons [Name]
names [LConDecl GhcRn]
cons)
  NewTypeCon LConDecl GhcRn
con -> DataDefnCons (LConDecl GhcRn)
-> (LConDecl GhcRn -> DataDefnCons (LConDecl GhcRn))
-> Maybe (LConDecl GhcRn)
-> DataDefnCons (LConDecl GhcRn)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
False []) LConDecl GhcRn -> DataDefnCons (LConDecl GhcRn)
forall a. a -> DataDefnCons a
NewTypeCon (Maybe (LConDecl GhcRn) -> DataDefnCons (LConDecl GhcRn))
-> Maybe (LConDecl GhcRn) -> DataDefnCons (LConDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe (LConDecl GhcRn) -> Maybe (LConDecl GhcRn)
forall (m :: Type -> Type).
MonadFail m =>
[Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn)
restrictCons [Name]
names (GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> Maybe (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall a. a -> Maybe a
Just LConDecl GhcRn
GenLocated SrcSpanAnnA (ConDecl GhcRn)
con)

restrictCons :: MonadFail m => [Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn)
restrictCons :: forall (m :: Type -> Type).
MonadFail m =>
[Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn)
restrictCons [Name]
names m (LConDecl GhcRn)
decls = [SrcSpanAnnA
-> ConDecl GhcRn -> GenLocated SrcSpanAnnA (ConDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
p ConDecl GhcRn
d | L SrcSpanAnnA
p (Just ConDecl GhcRn
d) <- (ConDecl GhcRn -> Maybe (ConDecl GhcRn))
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (Maybe (ConDecl GhcRn))
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ConDecl GhcRn -> Maybe (ConDecl GhcRn)
keep (GenLocated SrcSpanAnnA (ConDecl GhcRn)
 -> GenLocated SrcSpanAnnA (Maybe (ConDecl GhcRn)))
-> m (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> m (GenLocated SrcSpanAnnA (Maybe (ConDecl GhcRn)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LConDecl GhcRn)
m (GenLocated SrcSpanAnnA (ConDecl GhcRn))
decls]
  where
    keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn)
    keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn)
keep ConDecl GhcRn
d
      | (Name -> Bool) -> [Name] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Name]
names) (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames ConDecl GhcRn
d) =
          case ConDecl GhcRn
d of
            ConDeclH98{con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcRn
con_args'} -> case HsConDeclH98Details GhcRn
con_args' of
              PrefixCon{} -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just ConDecl GhcRn
d
              RecCon XRec GhcRn [LConDeclField GhcRn]
fields
                | (GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all LConDeclField GhcRn -> Bool
GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> Bool
field_avail (GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall l e. GenLocated l e -> e
unLoc XRec GhcRn [LConDeclField GhcRn]
GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
fields) -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just ConDecl GhcRn
d
                | Bool
otherwise -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just (ConDecl GhcRn
d{con_args = PrefixCon [] (field_types $ unLoc fields)})
              -- if we have *all* the field names available, then
              -- keep the record declaration.  Otherwise degrade to
              -- a constructor declaration.  This isn't quite right, but
              -- it's the best we can do.
              InfixCon HsScaled GhcRn (LHsType GhcRn)
_ HsScaled GhcRn (LHsType GhcRn)
_ -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just ConDecl GhcRn
d
            ConDeclGADT{con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = HsConDeclGADTDetails GhcRn
con_args'} -> case HsConDeclGADTDetails GhcRn
con_args' of
              PrefixConGADT{} -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just ConDecl GhcRn
d
              RecConGADT XRecConGADT GhcRn
_ XRec GhcRn [LConDeclField GhcRn]
fields
                | (GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all LConDeclField GhcRn -> Bool
GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> Bool
field_avail (GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall l e. GenLocated l e -> e
unLoc XRec GhcRn [LConDeclField GhcRn]
GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
fields) -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just ConDecl GhcRn
d
                | Bool
otherwise -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just (ConDecl GhcRn
d{con_g_args = PrefixConGADT noExtField (field_types $ unLoc fields)})
      where
        -- see above

        field_avail :: LConDeclField GhcRn -> Bool
        field_avail :: LConDeclField GhcRn -> Bool
field_avail (L SrcSpanAnnA
_ (ConDeclField XConDeclField GhcRn
_ [LFieldOcc GhcRn]
fs LHsType GhcRn
_ Maybe (LHsDoc GhcRn)
_)) =
          (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\GenLocated SrcSpanAnnA (FieldOcc GhcRn)
f -> (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn)
    -> GenLocated SrcSpanAnnN Name)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc GhcRn -> LIdP GhcRn
FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. FieldOcc pass -> LIdP pass
foLabel (FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> GenLocated SrcSpanAnnN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> Name)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> Name
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (FieldOcc GhcRn)
f) Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Name]
names) [LFieldOcc GhcRn]
[GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
fs

        field_types :: m (GenLocated l (ConDeclField pass))
-> m (HsScaled (GhcPass p) (XRec pass (BangType pass)))
field_types m (GenLocated l (ConDeclField pass))
flds = [XRec pass (BangType pass)
-> HsScaled (GhcPass p) (XRec pass (BangType pass))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsUnrestricted XRec pass (BangType pass)
t | L l
_ (ConDeclField XConDeclField pass
_ [LFieldOcc pass]
_ XRec pass (BangType pass)
t Maybe (LHsDoc pass)
_) <- m (GenLocated l (ConDeclField pass))
flds]
    keep ConDecl GhcRn
_ = Maybe (ConDecl GhcRn)
forall a. Maybe a
Nothing

restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
restrictDecls [Name]
names = (GenLocated SrcSpanAnnA (Sig GhcRn)
 -> Maybe (GenLocated SrcSpanAnnA (Sig GhcRn)))
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((IdP GhcRn -> Bool) -> LSig GhcRn -> Maybe (LSig GhcRn)
forall (p :: Pass).
(IdP (GhcPass p) -> Bool)
-> LSig (GhcPass p) -> Maybe (LSig (GhcPass p))
filterLSigNames (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Name]
names))

restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
restrictATs [Name]
names [LFamilyDecl GhcRn]
ats = [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at | GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at <- [LFamilyDecl GhcRn]
[GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats, GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (FamilyDecl GhcRn -> LIdP GhcRn
forall pass. FamilyDecl pass -> LIdP pass
fdLName (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at)) Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Name]
names]

-------------------------------------------------------------------------------

-- * Parenthesization

-------------------------------------------------------------------------------

-- | Precedence level (inside the 'HsType' AST).
data Precedence
  = -- | precedence of 'type' production in GHC's parser
    PREC_TOP
  | -- | explicit type signature
    PREC_SIG
  | -- | Used for single contexts, eg. ctx => type
    -- (as opposed to (ctx1, ctx2) => type)
    PREC_CTX
  | -- | precedence of 'btype' production in GHC's parser
    -- (used for LH arg of (->))
    PREC_FUN
  | -- | arg of any infix operator
    -- (we don't keep have fixity info)
    PREC_OP
  | -- | arg of type application: always parenthesize unless atomic
    PREC_CON
  deriving (Precedence -> Precedence -> Bool
(Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool) -> Eq Precedence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Precedence -> Precedence -> Bool
== :: Precedence -> Precedence -> Bool
$c/= :: Precedence -> Precedence -> Bool
/= :: Precedence -> Precedence -> Bool
Eq, Eq Precedence
Eq Precedence =>
(Precedence -> Precedence -> Ordering)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Precedence)
-> (Precedence -> Precedence -> Precedence)
-> Ord Precedence
Precedence -> Precedence -> Bool
Precedence -> Precedence -> Ordering
Precedence -> Precedence -> Precedence
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Precedence -> Precedence -> Ordering
compare :: Precedence -> Precedence -> Ordering
$c< :: Precedence -> Precedence -> Bool
< :: Precedence -> Precedence -> Bool
$c<= :: Precedence -> Precedence -> Bool
<= :: Precedence -> Precedence -> Bool
$c> :: Precedence -> Precedence -> Bool
> :: Precedence -> Precedence -> Bool
$c>= :: Precedence -> Precedence -> Bool
>= :: Precedence -> Precedence -> Bool
$cmax :: Precedence -> Precedence -> Precedence
max :: Precedence -> Precedence -> Precedence
$cmin :: Precedence -> Precedence -> Precedence
min :: Precedence -> Precedence -> Precedence
Ord)

-- | Add in extra 'HsParTy' where needed to ensure that what would be printed
-- out using 'ppr' has enough parentheses to be re-parsed properly.
--
-- We cannot add parens that may be required by fixities because we do not have
-- any fixity information to work with in the first place :(.
reparenTypePrec
  :: forall a
   . XRecCond a
  => Precedence
  -> HsType a
  -> HsType a
reparenTypePrec :: forall a. XRecCond a => Precedence -> HsType a -> HsType a
reparenTypePrec = Precedence -> HsType a -> HsType a
go
  where
    -- Shorter name for 'reparenType'
    go :: Precedence -> HsType a -> HsType a
    go :: Precedence -> HsType a -> HsType a
go Precedence
_ (HsBangTy XBangTy a
x HsBang
b XRec a (HsType a)
ty) = XBangTy a -> HsBang -> XRec a (HsType a) -> HsType a
forall pass. XBangTy pass -> HsBang -> LHsType pass -> HsType pass
HsBangTy XBangTy a
x HsBang
b (XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType XRec a (HsType a)
ty)
    go Precedence
_ (HsTupleTy XTupleTy a
x HsTupleSort
con [XRec a (HsType a)]
tys) = XTupleTy a -> HsTupleSort -> [XRec a (HsType a)] -> HsType a
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy a
x HsTupleSort
con ((XRec a (HsType a) -> XRec a (HsType a))
-> [XRec a (HsType a)] -> [XRec a (HsType a)]
forall a b. (a -> b) -> [a] -> [b]
map XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType [XRec a (HsType a)]
tys)
    go Precedence
_ (HsSumTy XSumTy a
x [XRec a (HsType a)]
tys) = XSumTy a -> [XRec a (HsType a)] -> HsType a
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy XSumTy a
x ((XRec a (HsType a) -> XRec a (HsType a))
-> [XRec a (HsType a)] -> [XRec a (HsType a)]
forall a b. (a -> b) -> [a] -> [b]
map XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType [XRec a (HsType a)]
tys)
    go Precedence
_ (HsListTy XListTy a
x XRec a (HsType a)
ty) = XListTy a -> XRec a (HsType a) -> HsType a
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy a
x (XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType XRec a (HsType a)
ty)
    go Precedence
_ (HsRecTy XRecTy a
x [LConDeclField a]
flds) = XRecTy a -> [LConDeclField a] -> HsType a
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy XRecTy a
x ((LConDeclField a -> LConDeclField a)
-> [LConDeclField a] -> [LConDeclField a]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @a ConDeclField a -> ConDeclField a
forall a. XRecCond a => ConDeclField a -> ConDeclField a
reparenConDeclField) [LConDeclField a]
flds)
    go Precedence
p (HsDocTy XDocTy a
x XRec a (HsType a)
ty LHsDoc a
d) = XDocTy a -> XRec a (HsType a) -> LHsDoc a -> HsType a
forall pass.
XDocTy pass -> LHsType pass -> LHsDoc pass -> HsType pass
HsDocTy XDocTy a
x (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
p XRec a (HsType a)
ty) LHsDoc a
d
    go Precedence
_ (HsExplicitListTy XExplicitListTy a
x PromotionFlag
p [XRec a (HsType a)]
tys) = XExplicitListTy a
-> PromotionFlag -> [XRec a (HsType a)] -> HsType a
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy XExplicitListTy a
x PromotionFlag
p ((XRec a (HsType a) -> XRec a (HsType a))
-> [XRec a (HsType a)] -> [XRec a (HsType a)]
forall a b. (a -> b) -> [a] -> [b]
map XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType [XRec a (HsType a)]
tys)
    go Precedence
_ (HsExplicitTupleTy XExplicitTupleTy a
x [XRec a (HsType a)]
tys) = XExplicitTupleTy a -> [XRec a (HsType a)] -> HsType a
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy XExplicitTupleTy a
x ((XRec a (HsType a) -> XRec a (HsType a))
-> [XRec a (HsType a)] -> [XRec a (HsType a)]
forall a b. (a -> b) -> [a] -> [b]
map XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType [XRec a (HsType a)]
tys)
    go Precedence
p (HsKindSig XKindSig a
x XRec a (HsType a)
ty XRec a (HsType a)
kind) =
      Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_SIG (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XKindSig a -> XRec a (HsType a) -> XRec a (HsType a) -> HsType a
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig XKindSig a
x (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_SIG XRec a (HsType a)
ty) (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_SIG XRec a (HsType a)
kind)
    go Precedence
p (HsIParamTy XIParamTy a
x XRec a HsIPName
n XRec a (HsType a)
ty) =
      Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_SIG (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XIParamTy a -> XRec a HsIPName -> XRec a (HsType a) -> HsType a
forall pass.
XIParamTy pass -> XRec pass HsIPName -> LHsType pass -> HsType pass
HsIParamTy XIParamTy a
x XRec a HsIPName
n (XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType XRec a (HsType a)
ty)
    go Precedence
p (HsForAllTy XForAllTy a
x HsForAllTelescope a
tele XRec a (HsType a)
ty) =
      Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_CTX (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XForAllTy a -> HsForAllTelescope a -> XRec a (HsType a) -> HsType a
forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy XForAllTy a
x (HsForAllTelescope a -> HsForAllTelescope a
forall a. XRecCond a => HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope HsForAllTelescope a
tele) (XRec a (HsType a) -> XRec a (HsType a)
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType XRec a (HsType a)
ty)
    go Precedence
p (HsQualTy XQualTy a
x LHsContext a
ctxt XRec a (HsType a)
ty) =
      let p' :: [a] -> Precedence
p' [a
_] = Precedence
PREC_CTX
          p' [a]
_ = Precedence
PREC_TOP -- parens will get added anyways later...
          ctxt' :: LHsContext a
ctxt' = forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @a (\[XRec a (HsType a)]
xs -> (XRec a (HsType a) -> XRec a (HsType a))
-> [XRec a (HsType a)] -> [XRec a (HsType a)]
forall a b. (a -> b) -> [a] -> [b]
map (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL ([XRec a (HsType a)] -> Precedence
forall {a}. [a] -> Precedence
p' [XRec a (HsType a)]
xs)) [XRec a (HsType a)]
xs) LHsContext a
ctxt
       in Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_CTX (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XQualTy a -> LHsContext a -> XRec a (HsType a) -> HsType a
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy XQualTy a
x LHsContext a
ctxt' (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_TOP XRec a (HsType a)
ty)
    go Precedence
p (HsFunTy XFunTy a
x HsArrow a
w XRec a (HsType a)
ty1 XRec a (HsType a)
ty2) =
      Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_FUN (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XFunTy a
-> HsArrow a -> XRec a (HsType a) -> XRec a (HsType a) -> HsType a
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy a
x HsArrow a
w (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_FUN XRec a (HsType a)
ty1) (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_TOP XRec a (HsType a)
ty2)
    go Precedence
p (HsAppTy XAppTy a
x XRec a (HsType a)
fun_ty XRec a (HsType a)
arg_ty) =
      Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_CON (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XAppTy a -> XRec a (HsType a) -> XRec a (HsType a) -> HsType a
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy a
x (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_FUN XRec a (HsType a)
fun_ty) (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_CON XRec a (HsType a)
arg_ty)
    go Precedence
p (HsAppKindTy XAppKindTy a
x XRec a (HsType a)
fun_ty XRec a (HsType a)
arg_ki) =
      Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_CON (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XAppKindTy a -> XRec a (HsType a) -> XRec a (HsType a) -> HsType a
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy XAppKindTy a
x (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_FUN XRec a (HsType a)
fun_ty) (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_CON XRec a (HsType a)
arg_ki)
    go Precedence
p (HsOpTy XOpTy a
x PromotionFlag
prom XRec a (HsType a)
ty1 LIdP a
op XRec a (HsType a)
ty2) =
      Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
p Precedence
PREC_FUN (HsType a -> HsType a) -> HsType a -> HsType a
forall a b. (a -> b) -> a -> b
$ XOpTy a
-> PromotionFlag
-> XRec a (HsType a)
-> LIdP a
-> XRec a (HsType a)
-> HsType a
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy XOpTy a
x PromotionFlag
prom (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_OP XRec a (HsType a)
ty1) LIdP a
op (Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
PREC_OP XRec a (HsType a)
ty2)
    go Precedence
p (HsParTy XParTy a
_ XRec a (HsType a)
t) = forall p a. UnXRec p => XRec p a -> a
unXRec @a (XRec a (HsType a) -> HsType a) -> XRec a (HsType a) -> HsType a
forall a b. (a -> b) -> a -> b
$ Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
p XRec a (HsType a)
t -- pretend the paren doesn't exist - it will be added back if needed
    go Precedence
_ t :: HsType a
t@HsTyVar{} = HsType a
t
    go Precedence
_ t :: HsType a
t@HsStarTy{} = HsType a
t
    go Precedence
_ t :: HsType a
t@HsSpliceTy{} = HsType a
t
    go Precedence
_ t :: HsType a
t@HsTyLit{} = HsType a
t
    go Precedence
_ t :: HsType a
t@HsWildCardTy{} = HsType a
t
    go Precedence
_ t :: HsType a
t@XHsType{} = HsType a
t

    -- Located variant of 'go'
    goL :: Precedence -> LHsType a -> LHsType a
    goL :: Precedence -> XRec a (HsType a) -> XRec a (HsType a)
goL Precedence
ctxt_prec = forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @a (Precedence -> HsType a -> HsType a
go Precedence
ctxt_prec)

    -- Optionally wrap a type in parens
    paren
      :: Precedence -- Precedence of context
      -> Precedence -- Precedence of top-level operator
      -> HsType a
      -> HsType a -- Wrap in parens if (ctxt >= op)
    paren :: Precedence -> Precedence -> HsType a -> HsType a
paren Precedence
ctxt_prec Precedence
op_prec
      | Precedence
ctxt_prec Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
op_prec = XParTy a -> XRec a (HsType a) -> HsType a
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy (EpToken "(", EpToken ")")
XParTy a
forall a. NoAnn a => a
noAnn (XRec a (HsType a) -> HsType a)
-> (HsType a -> XRec a (HsType a)) -> HsType a -> HsType a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. WrapXRec p a => a -> XRec p a
wrapXRec @a
      | Bool
otherwise = HsType a -> HsType a
forall a. a -> a
id

-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
reparenType :: XRecCond a => HsType a -> HsType a
reparenType :: forall a. XRecCond a => HsType a -> HsType a
reparenType = Precedence -> HsType a -> HsType a
forall a. XRecCond a => Precedence -> HsType a -> HsType a
reparenTypePrec Precedence
PREC_TOP

-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
reparenLType :: forall a. XRecCond a => LHsType a -> LHsType a
reparenLType :: forall a. XRecCond a => LHsType a -> LHsType a
reparenLType = forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @a HsType a -> HsType a
forall a. XRecCond a => HsType a -> HsType a
reparenType

-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')
reparenSigType
  :: forall a
   . XRecCond a
  => HsSigType a
  -> HsSigType a
reparenSigType :: forall a. XRecCond a => HsSigType a -> HsSigType a
reparenSigType (HsSig XHsSig a
x HsOuterSigTyVarBndrs a
bndrs LHsType a
body) =
  XHsSig a -> HsOuterSigTyVarBndrs a -> LHsType a -> HsSigType a
forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig XHsSig a
x (HsOuterSigTyVarBndrs a -> HsOuterSigTyVarBndrs a
forall flag a.
XRecCond a =>
HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
reparenOuterTyVarBndrs HsOuterSigTyVarBndrs a
bndrs) (LHsType a -> LHsType a
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType LHsType a
body)
reparenSigType v :: HsSigType a
v@XHsSigType{} = HsSigType a
v

-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')
reparenOuterTyVarBndrs
  :: forall flag a
   . XRecCond a
  => HsOuterTyVarBndrs flag a
  -> HsOuterTyVarBndrs flag a
reparenOuterTyVarBndrs :: forall flag a.
XRecCond a =>
HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
reparenOuterTyVarBndrs imp :: HsOuterTyVarBndrs flag a
imp@HsOuterImplicit{} = HsOuterTyVarBndrs flag a
imp
reparenOuterTyVarBndrs (HsOuterExplicit XHsOuterExplicit a flag
x [LHsTyVarBndr flag (NoGhcTc a)]
exp_bndrs) =
  XHsOuterExplicit a flag
-> [LHsTyVarBndr flag (NoGhcTc a)] -> HsOuterTyVarBndrs flag a
forall flag pass.
XHsOuterExplicit pass flag
-> [LHsTyVarBndr flag (NoGhcTc pass)]
-> HsOuterTyVarBndrs flag pass
HsOuterExplicit XHsOuterExplicit a flag
x ((XRec a (HsTyVarBndr flag a) -> XRec a (HsTyVarBndr flag a))
-> [XRec a (HsTyVarBndr flag a)] -> [XRec a (HsTyVarBndr flag a)]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @(NoGhcTc a) HsTyVarBndr flag a -> HsTyVarBndr flag a
forall a flag.
XRecCond a =>
HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar) [XRec a (HsTyVarBndr flag a)]
[LHsTyVarBndr flag (NoGhcTc a)]
exp_bndrs)
reparenOuterTyVarBndrs v :: HsOuterTyVarBndrs flag a
v@XHsOuterTyVarBndrs{} = HsOuterTyVarBndrs flag a
v

-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
reparenHsForAllTelescope
  :: forall a
   . XRecCond a
  => HsForAllTelescope a
  -> HsForAllTelescope a
reparenHsForAllTelescope :: forall a. XRecCond a => HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope (HsForAllVis XHsForAllVis a
x [LHsTyVarBndr () a]
bndrs) =
  XHsForAllVis a -> [LHsTyVarBndr () a] -> HsForAllTelescope a
forall pass.
XHsForAllVis pass
-> [LHsTyVarBndr () pass] -> HsForAllTelescope pass
HsForAllVis XHsForAllVis a
x ((LHsTyVarBndr () a -> LHsTyVarBndr () a)
-> [LHsTyVarBndr () a] -> [LHsTyVarBndr () a]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @a HsTyVarBndr () a -> HsTyVarBndr () a
forall a flag.
XRecCond a =>
HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar) [LHsTyVarBndr () a]
bndrs)
reparenHsForAllTelescope (HsForAllInvis XHsForAllInvis a
x [LHsTyVarBndr Specificity a]
bndrs) =
  XHsForAllInvis a
-> [LHsTyVarBndr Specificity a] -> HsForAllTelescope a
forall pass.
XHsForAllInvis pass
-> [LHsTyVarBndr Specificity pass] -> HsForAllTelescope pass
HsForAllInvis XHsForAllInvis a
x ((LHsTyVarBndr Specificity a -> LHsTyVarBndr Specificity a)
-> [LHsTyVarBndr Specificity a] -> [LHsTyVarBndr Specificity a]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @a HsTyVarBndr Specificity a -> HsTyVarBndr Specificity a
forall a flag.
XRecCond a =>
HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar) [LHsTyVarBndr Specificity a]
bndrs)
reparenHsForAllTelescope v :: HsForAllTelescope a
v@XHsForAllTelescope{} = HsForAllTelescope a
v

-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
reparenTyVar :: XRecCond a => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar :: forall a flag.
XRecCond a =>
HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (HsTvb XTyVarBndr a
x flag
flag HsBndrVar a
n HsBndrKind a
kind) = XTyVarBndr a
-> flag -> HsBndrVar a -> HsBndrKind a -> HsTyVarBndr flag a
forall flag pass.
XTyVarBndr pass
-> flag
-> HsBndrVar pass
-> HsBndrKind pass
-> HsTyVarBndr flag pass
HsTvb XTyVarBndr a
x flag
flag HsBndrVar a
n (HsBndrKind a -> HsBndrKind a
forall a. XRecCond a => HsBndrKind a -> HsBndrKind a
reparenBndrKind HsBndrKind a
kind)
reparenTyVar v :: HsTyVarBndr flag a
v@XTyVarBndr{} = HsTyVarBndr flag a
v

reparenBndrKind :: XRecCond a => HsBndrKind a -> HsBndrKind a
reparenBndrKind :: forall a. XRecCond a => HsBndrKind a -> HsBndrKind a
reparenBndrKind (HsBndrNoKind XBndrNoKind a
x) = XBndrNoKind a -> HsBndrKind a
forall pass. XBndrNoKind pass -> HsBndrKind pass
HsBndrNoKind XBndrNoKind a
x
reparenBndrKind (HsBndrKind XBndrKind a
x LHsKind a
k) = XBndrKind a -> LHsKind a -> HsBndrKind a
forall pass. XBndrKind pass -> LHsKind pass -> HsBndrKind pass
HsBndrKind XBndrKind a
x (LHsKind a -> LHsKind a
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType LHsKind a
k)
reparenBndrKind v :: HsBndrKind a
v@XBndrKind{} = HsBndrKind a
v

-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
reparenConDeclField :: XRecCond a => ConDeclField a -> ConDeclField a
reparenConDeclField :: forall a. XRecCond a => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField XConDeclField a
x [LFieldOcc a]
n LBangType a
t Maybe (LHsDoc a)
d) = XConDeclField a
-> [LFieldOcc a]
-> LBangType a
-> Maybe (LHsDoc a)
-> ConDeclField a
forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe (LHsDoc pass)
-> ConDeclField pass
ConDeclField XConDeclField a
x [LFieldOcc a]
n (LBangType a -> LBangType a
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType LBangType a
t) Maybe (LHsDoc a)
d
reparenConDeclField c :: ConDeclField a
c@XConDeclField{} = ConDeclField a
c

-------------------------------------------------------------------------------

-- * Located

-------------------------------------------------------------------------------

unL :: GenLocated l a -> a
unL :: forall l e. GenLocated l e -> e
unL (L l
_ a
x) = a
x

reL :: a -> GenLocated l a
reL :: forall a l. a -> GenLocated l a
reL = l -> a -> GenLocated l a
forall l e. l -> e -> GenLocated l e
L l
forall a. HasCallStack => a
undefined

mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b)
mapMA :: forall (m :: Type -> Type) a b an.
Monad m =>
(a -> m b) -> LocatedAn an a -> m (Located b)
mapMA a -> m b
f (L EpAnn an
al a
a) = SrcSpan -> b -> GenLocated SrcSpan b
forall l e. l -> e -> GenLocated l e
L (EpAnn an -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn an
al) (b -> GenLocated SrcSpan b) -> m b -> m (GenLocated SrcSpan b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
a

-------------------------------------------------------------------------------

-- * NamedThing instances

-------------------------------------------------------------------------------

instance NamedThing (TyClDecl GhcRn) where
  getName :: TyClDecl GhcRn -> Name
getName = TyClDecl GhcRn -> IdP GhcRn
TyClDecl GhcRn -> Name
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName

-------------------------------------------------------------------------------

-- * Subordinates

-------------------------------------------------------------------------------

class Parent a where
  children :: a -> [Name]

instance Parent (ConDecl GhcRn) where
  children :: ConDecl GhcRn -> [Name]
children ConDecl GhcRn
con =
    case ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn])
getRecConArgs_maybe ConDecl GhcRn
con of
      Maybe (LocatedL [LConDeclField GhcRn])
Nothing -> []
      Just LocatedL [LConDeclField GhcRn]
flds -> (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn)
    -> GenLocated SrcSpanAnnN Name)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc GhcRn -> LIdP GhcRn
FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. FieldOcc pass -> LIdP pass
foLabel (FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> GenLocated SrcSpanAnnN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc) ([GenLocated SrcSpanAnnA (FieldOcc GhcRn)] -> [Name])
-> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)] -> [Name]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
 -> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)])
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (ConDeclField GhcRn -> [LFieldOcc GhcRn]
ConDeclField GhcRn -> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names (ConDeclField GhcRn -> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)])
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
    -> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc) (GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall l e. GenLocated l e -> e
unLoc LocatedL [LConDeclField GhcRn]
GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds)

instance Parent (TyClDecl GhcRn) where
  children :: TyClDecl GhcRn -> [Name]
children TyClDecl GhcRn
d
    | DataDecl { tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
dd } <- TyClDecl GhcRn
d
    = (GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpanAnnN Name] -> [Name])
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> a -> b
$
      (GenLocated SrcSpanAnnA (ConDecl GhcRn)
 -> [GenLocated SrcSpanAnnN Name])
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [GenLocated SrcSpanAnnN Name]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([GenLocated SrcSpanAnnN Name] -> [GenLocated SrcSpanAnnN Name]
forall a. [a] -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList ([GenLocated SrcSpanAnnN Name] -> [GenLocated SrcSpanAnnN Name])
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn)
    -> [GenLocated SrcSpanAnnN Name])
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> [GenLocated SrcSpanAnnN Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames (ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name])
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> [GenLocated SrcSpanAnnN Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) (HsDataDefn GhcRn -> DataDefnCons (LConDecl GhcRn)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons HsDataDefn GhcRn
dd)
    | ClassDecl{ tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats } <- TyClDecl GhcRn
d
    = (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
    -> GenLocated SrcSpanAnnN Name)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyDecl GhcRn -> LIdP GhcRn
FamilyDecl GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. FamilyDecl pass -> LIdP pass
fdLName (FamilyDecl GhcRn -> GenLocated SrcSpanAnnN Name)
-> (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> GenLocated SrcSpanAnnN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LFamilyDecl GhcRn]
[GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats
      [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
n | L SrcSpanAnnA
_ (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
ns LHsSigWcType GhcRn
_) <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs, GenLocated SrcSpanAnnN Name
n <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
ns]
    | Bool
otherwise = []

-- | A parent and its children
family :: (NamedThing a, Parent a) => a -> (Name, [Name])
family :: forall a. (NamedThing a, Parent a) => a -> (Name, [Name])
family = a -> Name
forall a. NamedThing a => a -> Name
getName (a -> Name) -> (a -> [Name]) -> a -> (Name, [Name])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> [Name]
forall a. Parent a => a -> [Name]
children

familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]
familyConDecl :: ConDecl GhcRn -> [(Name, [Name])]
familyConDecl ConDecl GhcRn
d = [Name] -> [[Name]] -> [(Name, [Name])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Name] -> [Name]
forall a. [a] -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames ConDecl GhcRn
d) ([Name] -> [[Name]]
forall a. a -> [a]
repeat ([Name] -> [[Name]]) -> [Name] -> [[Name]]
forall a b. (a -> b) -> a -> b
$ ConDecl GhcRn -> [Name]
forall a. Parent a => a -> [Name]
children ConDecl GhcRn
d)

-- | A mapping from the parent (main-binder) to its children and from each
-- child to its grand-children, recursively.
families :: TyClDecl GhcRn -> [(Name, [Name])]
families :: TyClDecl GhcRn -> [(Name, [Name])]
families TyClDecl GhcRn
d
  | DataDecl {}  <- TyClDecl GhcRn
d = TyClDecl GhcRn -> (Name, [Name])
forall a. (NamedThing a, Parent a) => a -> (Name, [Name])
family TyClDecl GhcRn
d (Name, [Name]) -> [(Name, [Name])] -> [(Name, [Name])]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> [(Name, [Name])])
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [(Name, [Name])]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (ConDecl GhcRn -> [(Name, [Name])]
familyConDecl (ConDecl GhcRn -> [(Name, [Name])])
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> [(Name, [Name])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) (HsDataDefn GhcRn -> DataDefnCons (LConDecl GhcRn)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons (TyClDecl GhcRn -> HsDataDefn GhcRn
forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn TyClDecl GhcRn
d))
  | ClassDecl {} <- TyClDecl GhcRn
d = [TyClDecl GhcRn -> (Name, [Name])
forall a. (NamedThing a, Parent a) => a -> (Name, [Name])
family TyClDecl GhcRn
d]
  | Bool
otherwise         = []

-- | A mapping from child to parent
parentMap :: TyClDecl GhcRn -> [(Name, Name)]
parentMap :: TyClDecl GhcRn -> [(Name, Name)]
parentMap TyClDecl GhcRn
d = [(Name
c, Name
p) | (Name
p, [Name]
cs) <- TyClDecl GhcRn -> [(Name, [Name])]
families TyClDecl GhcRn
d, Name
c <- [Name]
cs]

-- | The parents of a subordinate in a declaration
parents :: Name -> HsDecl GhcRn -> [Name]
parents :: Name -> HsDecl GhcRn -> [Name]
parents Name
n (TyClD XTyClD GhcRn
_ TyClDecl GhcRn
d) = [Name
p | (Name
c, Name
p) <- TyClDecl GhcRn -> [(Name, Name)]
parentMap TyClDecl GhcRn
d, Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n]
parents Name
_ HsDecl GhcRn
_ = []

-------------------------------------------------------------------------------

-- * Utils that work in monads defined by GHC

-------------------------------------------------------------------------------

modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
modifySessionDynFlags DynFlags -> DynFlags
f = do
  dflags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
getSessionDynFlags
  _ <- setSessionDynFlags (f dflags)
  return ()

-------------------------------------------------------------------------------

-- * DynFlags

-------------------------------------------------------------------------------

-- TODO: use `setOutputDir` from GHC
setOutputDir :: FilePath -> DynFlags -> DynFlags
setOutputDir :: String -> DynFlags -> DynFlags
setOutputDir String
dir DynFlags
dynFlags =
  DynFlags
dynFlags
    { objectDir = Just dir
    , hiDir = Just dir
    , hieDir = Just dir
    , stubDir = Just dir
    , includePaths = addGlobalInclude (includePaths dynFlags) [dir]
    , dumpDir = Just dir
    }

getSupportedLanguagesAndExtensions
  :: [Interface]
  -> [String]
getSupportedLanguagesAndExtensions :: [Interface] -> [String]
getSupportedLanguagesAndExtensions [] = []
getSupportedLanguagesAndExtensions (Interface
iface : [Interface]
_) = do
  let dflags :: DynFlags
dflags = Interface -> DynFlags
ifaceDynFlags Interface
iface
   in ArchOS -> [String]
supportedLanguagesAndExtensions DynFlags
dflags.targetPlatform.platformArchOS

-------------------------------------------------------------------------------

-- * 'StringBuffer' and 'ByteString'

-------------------------------------------------------------------------------
-- We get away with a bunch of these functions because 'StringBuffer' and
-- 'ByteString' have almost exactly the same structure.

-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really
-- relies on the internals of both 'ByteString' and 'StringBuffer'.
--
-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood)
stringBufferFromByteString :: ByteString -> StringBuffer
stringBufferFromByteString :: ByteString -> StringBuffer
stringBufferFromByteString ByteString
bs =
  let BS.PS ForeignPtr Word8
fp Int
off Int
len = ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Word8] -> ByteString
BS.pack [Word8
0, Word8
0, Word8
0]
   in S.StringBuffer{buf :: ForeignPtr Word8
S.buf = ForeignPtr Word8
fp, len :: Int
S.len = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3, cur :: Int
S.cur = Int
off}

-- | Take the first @n@ /bytes/ of the 'StringBuffer' and put them in a
-- 'ByteString'.
--
-- /O(1)/
takeStringBuffer :: Int -> StringBuffer -> ByteString
takeStringBuffer :: Int -> StringBuffer -> ByteString
takeStringBuffer !Int
n (S.StringBuffer ForeignPtr Word8
fp Int
_ Int
cur) = ForeignPtr Word8 -> Int -> Int -> ByteString
BS.PS ForeignPtr Word8
fp Int
cur Int
n

-- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second
-- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use
-- separate buffers.**
--
-- /O(1)/
splitStringBuffer :: StringBuffer -> StringBuffer -> ByteString
splitStringBuffer :: StringBuffer -> StringBuffer -> ByteString
splitStringBuffer StringBuffer
buf1 StringBuffer
buf2 = Int -> StringBuffer -> ByteString
takeStringBuffer Int
n StringBuffer
buf1
  where
    n :: Int
n = StringBuffer -> StringBuffer -> Int
S.byteDiff StringBuffer
buf1 StringBuffer
buf2

-- | Split the 'StringBuffer' at the next newline (or the end of the buffer).
-- Also: initial position is passed in and the updated position is returned.
--
-- /O(n)/ (but /O(1)/ space)
spanLine :: RealSrcLoc -> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
spanLine :: RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
spanLine !RealSrcLoc
loc !StringBuffer
buf = RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
go RealSrcLoc
loc StringBuffer
buf
  where
    go :: RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
go !RealSrcLoc
l !StringBuffer
b
      | Bool -> Bool
not (StringBuffer -> Bool
S.atEnd StringBuffer
b) =
          case StringBuffer -> (Char, StringBuffer)
S.nextChar StringBuffer
b of
            (Char
'\n', StringBuffer
b') -> (StringBuffer -> StringBuffer -> ByteString
splitStringBuffer StringBuffer
buf StringBuffer
b', RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
'\n', StringBuffer
b')
            (Char
c, StringBuffer
b') -> RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
go (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
c) StringBuffer
b'
      | Bool
otherwise =
          (StringBuffer -> StringBuffer -> ByteString
splitStringBuffer StringBuffer
buf StringBuffer
b, RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
'\n', StringBuffer
b)

-- | Given a start position and a buffer with that start position, split the
-- buffer at an end position.
--
-- /O(n)/ (but /O(1)/ space)
spanPosition
  :: RealSrcLoc
  -- ^ start of buffeer
  -> RealSrcLoc
  -- ^ position until which to take
  -> StringBuffer
  -- ^ buffer from which to take
  -> (ByteString, StringBuffer)
spanPosition :: RealSrcLoc
-> RealSrcLoc -> StringBuffer -> (ByteString, StringBuffer)
spanPosition !RealSrcLoc
start !RealSrcLoc
end !StringBuffer
buf = RealSrcLoc -> StringBuffer -> (ByteString, StringBuffer)
go RealSrcLoc
start StringBuffer
buf
  where
    go :: RealSrcLoc -> StringBuffer -> (ByteString, StringBuffer)
go !RealSrcLoc
l !StringBuffer
b
      | RealSrcLoc
l RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcLoc
end
      , Bool -> Bool
not (StringBuffer -> Bool
S.atEnd StringBuffer
b)
      , (Char
c, StringBuffer
b') <- StringBuffer -> (Char, StringBuffer)
S.nextChar StringBuffer
b =
          RealSrcLoc -> StringBuffer -> (ByteString, StringBuffer)
go (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
c) StringBuffer
b'
      | Bool
otherwise =
          (StringBuffer -> StringBuffer -> ByteString
splitStringBuffer StringBuffer
buf StringBuffer
b, StringBuffer
b)

-- | Try to parse a line of CPP from the from of the buffer. A \"line\" of CPP
-- consists of
--
--   * at most 10 whitespace characters, including at least one newline
--   * a @#@ character
--   * keep parsing lines until you find a line not ending in @\\@.
--
-- This is chock full of heuristics about what a line of CPP is.
--
-- /O(n)/ (but /O(1)/ space)
tryCppLine :: RealSrcLoc -> StringBuffer -> Maybe (ByteString, RealSrcLoc, StringBuffer)
tryCppLine :: RealSrcLoc
-> StringBuffer -> Maybe (ByteString, RealSrcLoc, StringBuffer)
tryCppLine !RealSrcLoc
loc !StringBuffer
buf = Bool
-> RealSrcLoc
-> StringBuffer
-> Maybe (ByteString, RealSrcLoc, StringBuffer)
spanSpace (StringBuffer -> Char -> Char
S.prevChar StringBuffer
buf Char
'\n' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') RealSrcLoc
loc StringBuffer
buf
  where
    -- Keep consuming space characters until we hit either a @#@ or something
    -- else. If we hit a @#@, start parsing CPP
    spanSpace :: Bool
-> RealSrcLoc
-> StringBuffer
-> Maybe (ByteString, RealSrcLoc, StringBuffer)
spanSpace !Bool
seenNl !RealSrcLoc
l !StringBuffer
b
      | StringBuffer -> Bool
S.atEnd StringBuffer
b =
          Maybe (ByteString, RealSrcLoc, StringBuffer)
forall a. Maybe a
Nothing
      | Bool
otherwise =
          case StringBuffer -> (Char, StringBuffer)
S.nextChar StringBuffer
b of
            (Char
'#', StringBuffer
b')
              | Bool -> Bool
not (StringBuffer -> Bool
S.atEnd StringBuffer
b')
              , (Char
'-', StringBuffer
b'') <- StringBuffer -> (Char, StringBuffer)
S.nextChar StringBuffer
b'
              , (Char
'}', StringBuffer
_) <- StringBuffer -> (Char, StringBuffer)
S.nextChar StringBuffer
b'' ->
                  Maybe (ByteString, RealSrcLoc, StringBuffer)
forall a. Maybe a
Nothing -- Edge case exception for @#-}@
              | Bool
seenNl ->
                  (ByteString, RealSrcLoc, StringBuffer)
-> Maybe (ByteString, RealSrcLoc, StringBuffer)
forall a. a -> Maybe a
Just (RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
spanCppLine (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
'#') StringBuffer
b') -- parse CPP
              | Bool
otherwise ->
                  Maybe (ByteString, RealSrcLoc, StringBuffer)
forall a. Maybe a
Nothing -- We didn't see a newline, so this can't be CPP!
            (Char
c, StringBuffer
b')
              | Char -> Bool
isSpace Char
c ->
                  Bool
-> RealSrcLoc
-> StringBuffer
-> Maybe (ByteString, RealSrcLoc, StringBuffer)
spanSpace
                    (Bool
seenNl Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')
                    (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
c)
                    StringBuffer
b'
              | Bool
otherwise -> Maybe (ByteString, RealSrcLoc, StringBuffer)
forall a. Maybe a
Nothing

    -- Consume a CPP line to its "end" (basically the first line that ends not
    -- with a @\@ character)
    spanCppLine :: RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
spanCppLine !RealSrcLoc
l !StringBuffer
b
      | StringBuffer -> Bool
S.atEnd StringBuffer
b =
          (StringBuffer -> StringBuffer -> ByteString
splitStringBuffer StringBuffer
buf StringBuffer
b, RealSrcLoc
l, StringBuffer
b)
      | Bool
otherwise =
          case StringBuffer -> (Char, StringBuffer)
S.nextChar StringBuffer
b of
            (Char
'\\', StringBuffer
b')
              | Bool -> Bool
not (StringBuffer -> Bool
S.atEnd StringBuffer
b')
              , (Char
'\n', StringBuffer
b'') <- StringBuffer -> (Char, StringBuffer)
S.nextChar StringBuffer
b' ->
                  RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
spanCppLine (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
'\\') Char
'\n') StringBuffer
b''
            (Char
'\n', StringBuffer
b') -> (StringBuffer -> StringBuffer -> ByteString
splitStringBuffer StringBuffer
buf StringBuffer
b', RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
'\n', StringBuffer
b')
            (Char
c, StringBuffer
b') -> RealSrcLoc
-> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
spanCppLine (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
l Char
c) StringBuffer
b'

-------------------------------------------------------------------------------

-- * Names in a 'Type'

-------------------------------------------------------------------------------

-- | Given a 'Type', return a set of 'Name's coming from the 'TyCon's within
-- the type.
typeNames :: Type -> Set.Set Name
typeNames :: Type -> Set Name
typeNames Type
ty = Type -> Set Name -> Set Name
go Type
ty Set Name
forall a. Set a
Set.empty
  where
    go :: Type -> Set.Set Name -> Set.Set Name
    go :: Type -> Set Name -> Set Name
go Type
t Set Name
acc =
      case Type
t of
        TyVarTy{} -> Set Name
acc
        AppTy Type
t1 Type
t2 -> Type -> Set Name -> Set Name
go Type
t2 (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Type -> Set Name -> Set Name
go Type
t1 Set Name
acc
        FunTy FunTyFlag
_ Type
_ Type
t1 Type
t2 -> Type -> Set Name -> Set Name
go Type
t2 (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Type -> Set Name -> Set Name
go Type
t1 Set Name
acc
        TyConApp TyCon
tcon [Type]
args -> (Set Name -> Type -> Set Name) -> Set Name -> [Type] -> Set Name
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Set Name
s Type
t' -> Type -> Set Name -> Set Name
go Type
t' Set Name
s) (Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tcon) Set Name
acc) [Type]
args
        ForAllTy ForAllTyBinder
bndr Type
t' -> Type -> Set Name -> Set Name
go Type
t' (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Type -> Set Name -> Set Name
go (TyVar -> Type
tyVarKind (ForAllTyBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar ForAllTyBinder
bndr)) Set Name
acc
        LitTy TyLit
_ -> Set Name
acc
        CastTy Type
t' KindCoercion
_ -> Type -> Set Name -> Set Name
go Type
t' Set Name
acc
        CoercionTy{} -> Set Name
acc

-------------------------------------------------------------------------------

-- * Free variables of a 'Type'

-------------------------------------------------------------------------------

-- | Get free type variables in a 'Type' in their order of appearance.
-- See [Ordering of implicit variables].
orderedFVs
  :: VarSet
  -- ^ free variables to ignore
  -> [Type]
  -- ^ types to traverse (in order) looking for free variables
  -> [TyVar]
  -- ^ free type variables, in the order they appear in
orderedFVs :: VarSet -> [Type] -> [TyVar]
orderedFVs VarSet
vs [Type]
tys =
  [TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse ([TyVar] -> [TyVar]) -> (VarAcc -> [TyVar]) -> VarAcc -> [TyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarAcc -> [TyVar]
forall a b. (a, b) -> a
fst (VarAcc -> [TyVar]) -> VarAcc -> [TyVar]
forall a b. (a -> b) -> a -> b
$ [Type] -> FV
tyCoFVsOfTypes' [Type]
tys (Bool -> TyVar -> Bool
forall a b. a -> b -> a
const Bool
True) VarSet
vs ([], VarSet
emptyVarSet)

-- See the "Free variables of types and coercions" section in 'TyCoRep', or
-- check out Note [Free variables of types]. The functions in this section
-- don't output type variables in the order they first appear in in the 'Type'.
--
-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type
-- of 'const :: a -> b -> a':
--
-- >>> import GHC.Types.Name
-- >>> import TyCoRep
-- >>> import GHC.Builtin.Types.Prim
-- >>> import GHC.Types.Var
-- >>> a = TyVarTy alphaTyVar
-- >>> b = TyVarTy betaTyVar
-- >>> constTy = mkFunTys [a, b] a
-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy)
-- ["b","a"]
--
-- However, we want to reuse the very optimized traversal machinery there, so
-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`.
-- All these do differently is traverse in a different order and ignore
-- coercion variables.

-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order
-- of  appearance.
tyCoFVsOfType' :: Type -> FV
tyCoFVsOfType' :: Type -> FV
tyCoFVsOfType' (TyVarTy TyVar
v) TyVar -> Bool
a VarSet
b VarAcc
c = (TyVar -> FV
FV.unitFV TyVar
v FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' (TyVar -> Type
tyVarKind TyVar
v)) TyVar -> Bool
a VarSet
b VarAcc
c
tyCoFVsOfType' (TyConApp TyCon
_ [Type]
tys) TyVar -> Bool
a VarSet
b VarAcc
c = [Type] -> FV
tyCoFVsOfTypes' [Type]
tys TyVar -> Bool
a VarSet
b VarAcc
c
tyCoFVsOfType' (LitTy{}) TyVar -> Bool
a VarSet
b VarAcc
c = FV
emptyFV TyVar -> Bool
a VarSet
b VarAcc
c
tyCoFVsOfType' (AppTy Type
fun Type
arg) TyVar -> Bool
a VarSet
b VarAcc
c = (Type -> FV
tyCoFVsOfType' Type
arg FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' Type
fun) TyVar -> Bool
a VarSet
b VarAcc
c
tyCoFVsOfType' (FunTy FunTyFlag
_ Type
w Type
arg Type
res) TyVar -> Bool
a VarSet
b VarAcc
c =
  ( Type -> FV
tyCoFVsOfType' Type
w
      FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' Type
res
      FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' Type
arg
  )
    TyVar -> Bool
a
    VarSet
b
    VarAcc
c
tyCoFVsOfType' (ForAllTy ForAllTyBinder
bndr Type
ty) TyVar -> Bool
a VarSet
b VarAcc
c = ForAllTyBinder -> FV -> FV
tyCoFVsBndr' ForAllTyBinder
bndr (Type -> FV
tyCoFVsOfType' Type
ty) TyVar -> Bool
a VarSet
b VarAcc
c
tyCoFVsOfType' (CastTy Type
ty KindCoercion
_) TyVar -> Bool
a VarSet
b VarAcc
c = (Type -> FV
tyCoFVsOfType' Type
ty) TyVar -> Bool
a VarSet
b VarAcc
c
tyCoFVsOfType' (CoercionTy KindCoercion
_) TyVar -> Bool
a VarSet
b VarAcc
c = FV
emptyFV TyVar -> Bool
a VarSet
b VarAcc
c

-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order
-- of appearance.
tyCoFVsOfTypes' :: [Type] -> FV
tyCoFVsOfTypes' :: [Type] -> FV
tyCoFVsOfTypes' (Type
ty : [Type]
tys) TyVar -> Bool
fv_cand VarSet
in_scope VarAcc
acc = ([Type] -> FV
tyCoFVsOfTypes' [Type]
tys FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' Type
ty) TyVar -> Bool
fv_cand VarSet
in_scope VarAcc
acc
tyCoFVsOfTypes' [] TyVar -> Bool
fv_cand VarSet
in_scope VarAcc
acc = FV
emptyFV TyVar -> Bool
fv_cand VarSet
in_scope VarAcc
acc

-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of
-- appearance.
tyCoFVsBndr' :: TyVarBinder -> FV -> FV
tyCoFVsBndr' :: ForAllTyBinder -> FV -> FV
tyCoFVsBndr' (Bndr TyVar
tv ForAllTyFlag
_) FV
fvs = TyVar -> FV -> FV
FV.delFV TyVar
tv FV
fvs FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' (TyVar -> Type
tyVarKind TyVar
tv)

-------------------------------------------------------------------------------

-- * Defaulting RuntimeRep variables

-------------------------------------------------------------------------------

-- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to
-- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such
-- function working over `IfaceType`'s.
defaultRuntimeRepVars :: Type -> Type
defaultRuntimeRepVars :: Type -> Type
defaultRuntimeRepVars = TyVarEnv () -> Type -> Type
go TyVarEnv ()
forall a. VarEnv a
emptyVarEnv
  where
    go :: TyVarEnv () -> Type -> Type
    go :: TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs (ForAllTy (Bndr TyVar
var ForAllTyFlag
flg) Type
ty)
      | TyVar -> Bool
isRuntimeRepVar TyVar
var
      , ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ForAllTyFlag
flg =
          let subs' :: TyVarEnv ()
subs' = TyVarEnv () -> TyVar -> () -> TyVarEnv ()
forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv TyVarEnv ()
subs TyVar
var ()
           in TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs' Type
ty
      | Bool
otherwise =
          ForAllTyBinder -> Type -> Type
ForAllTy
            (TyVar -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr ((Type -> Type) -> TyVar -> TyVar
updateTyVarKind (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs) TyVar
var) ForAllTyFlag
flg)
            (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs Type
ty)
    go TyVarEnv ()
subs (TyVarTy TyVar
tv)
      | TyVar
tv TyVar -> TyVarEnv () -> Bool
forall a. TyVar -> VarEnv a -> Bool
`elemVarEnv` TyVarEnv ()
subs =
          Type
liftedRepTy
      | Bool
otherwise =
          TyVar -> Type
TyVarTy ((Type -> Type) -> TyVar -> TyVar
updateTyVarKind (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs) TyVar
tv)
    go TyVarEnv ()
subs (TyConApp TyCon
tc [Type]
tc_args) =
      TyCon -> [Type] -> Type
TyConApp TyCon
tc ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs) [Type]
tc_args)
    go TyVarEnv ()
subs (FunTy FunTyFlag
af Type
w Type
arg Type
res) =
      FunTyFlag -> Type -> Type -> Type -> Type
FunTy FunTyFlag
af (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs Type
w) (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs Type
arg) (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs Type
res)
    go TyVarEnv ()
subs (AppTy Type
t Type
u) =
      Type -> Type -> Type
AppTy (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs Type
t) (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs Type
u)
    go TyVarEnv ()
subs (CastTy Type
x KindCoercion
co) =
      Type -> KindCoercion -> Type
CastTy (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs Type
x) KindCoercion
co
    go TyVarEnv ()
_ ty :: Type
ty@(LitTy{}) = Type
ty
    go TyVarEnv ()
_ ty :: Type
ty@(CoercionTy{}) = Type
ty

fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
fromMaybeContext Maybe (LHsContext DocNameI)
mctxt = GenLocated SrcSpanAnnC (HsContext DocNameI) -> HsContext DocNameI
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnC (HsContext DocNameI) -> HsContext DocNameI)
-> GenLocated SrcSpanAnnC (HsContext DocNameI)
-> HsContext DocNameI
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnC (HsContext DocNameI)
-> Maybe (GenLocated SrcSpanAnnC (HsContext DocNameI))
-> GenLocated SrcSpanAnnC (HsContext DocNameI)
forall a. a -> Maybe a -> a
fromMaybe ([GenLocated SrcSpanAnnA (HsType DocNameI)]
-> GenLocated
     SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType DocNameI)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA []) Maybe (LHsContext DocNameI)
Maybe (GenLocated SrcSpanAnnC (HsContext DocNameI))
mctxt