{-# LANGUAGE BangPatterns, FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonadComprehensions #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# 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.Char ( isSpace )
import Data.Foldable ( toList, foldl' )
import Data.List.NonEmpty ( NonEmpty )
import Data.Maybe ( mapMaybe, fromMaybe )
import qualified Data.Set as Set

import Haddock.Types( DocName, DocNameI, XRecCond )

import GHC
import GHC.Builtin.Names
import GHC.Data.FastString
import GHC.Driver.Ppr (showPpr )
import GHC.Driver.Session
import GHC.Types.Name
import GHC.Utils.FV as FV
import GHC.Utils.Outputable ( Outputable )
import GHC.Utils.Panic ( panic )
import GHC.Types.SrcLoc  ( advanceSrcLoc )
import GHC.Types.Var     ( Specificity, VarBndr(..), TyVarBinder
                         , tyVarKind, updateTyVarKind, isInvisibleForAllTyFlag )
import GHC.Types.Var.Set ( VarSet, emptyVarSet )
import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
import GHC.Core.TyCo.Rep ( Type(..) )
import GHC.Core.Type     ( isRuntimeRepVar, binderVar )
import GHC.Builtin.Types( liftedRepTy )

import           GHC.Data.StringBuffer ( StringBuffer )
import qualified GHC.Data.StringBuffer             as S

import           Data.ByteString ( ByteString )
import qualified Data.ByteString          as BS
import qualified Data.ByteString.Internal as BS

import GHC.HsToCore.Docs hiding (sigNameNoLoc)

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 :: * -> *) 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)) (IdGhcP p) -> IdGhcP p
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass p)
GenLocated (Anno (IdGhcP p)) (IdGhcP 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)) (IdGhcP p) -> IdGhcP p
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass p)
GenLocated (Anno (IdGhcP p)) (IdGhcP 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 [AddEpAnn]
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 (LIdP (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 => DynFlags -> a -> String
pretty :: forall a. Outputable a => DynFlags -> a -> String
pretty = DynFlags -> a -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr

dataListModule :: Module
dataListModule :: Module
dataListModule = FastString -> Module
mkBaseModule (String -> FastString
fsLit String
"Data.List")

dataTupleModule :: Module
dataTupleModule :: Module
dataTupleModule = FastString -> Module
mkBaseModule (String -> FastString
fsLit String
"Data.Tuple")

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

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

-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)
hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ DataConCantHappen, UnXRec n)
                => HsTyVarBndr flag n -> IdP n
hsTyVarBndrName :: forall flag n.
(XXTyVarBndr n ~ DataConCantHappen, UnXRec n) =>
HsTyVarBndr flag n -> IdP n
hsTyVarBndrName (UserTyVar XUserTyVar n
_ flag
_ LIdP n
name) = forall p a. UnXRec p => XRec p a -> a
unXRec @n LIdP n
name
hsTyVarBndrName (KindedTyVar XKindedTyVar n
_ flag
_ LIdP n
name LHsKind n
_) = forall p a. UnXRec p => XRec p a -> a
unXRec @n LIdP n
name

hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName
hsTyVarNameI :: forall flag. HsTyVarBndr flag DocNameI -> DocName
hsTyVarNameI (UserTyVar XUserTyVar DocNameI
_ flag
_ (L SrcSpanAnnN
_ DocName
n))     = DocName
n
hsTyVarNameI (KindedTyVar XKindedTyVar DocNameI
_ flag
_ (L SrcSpanAnnN
_ DocName
n) LHsKind DocNameI
_) = DocName
n

hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName
hsLTyVarNameI :: forall flag. LHsTyVarBndr flag DocNameI -> DocName
hsLTyVarNameI = HsTyVarBndr flag DocNameI -> DocName
forall flag. HsTyVarBndr flag DocNameI -> DocName
hsTyVarNameI (HsTyVarBndr flag DocNameI -> DocName)
-> (GenLocated SrcSpanAnnA (HsTyVarBndr flag DocNameI)
    -> HsTyVarBndr flag DocNameI)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag DocNameI)
-> 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 :: * -> *) 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 -> LHsKind DocNameI
hsSigTypeI = HsSigType DocNameI -> LHsKind 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

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 :: LHsKind DocNameI -> HsSigType DocNameI
mkHsImplicitSigTypeI LHsKind 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 :: LHsKind DocNameI
sig_body  = LHsKind 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 = LHsKind 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 :: LHsKind DocNameI
sig_body  = LHsKind 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 :: LHsKind DocNameI
hst_body = LHsKind DocNameI
tau_ty })
            | Bool
otherwise
            = LHsKind DocNameI
GenLocated SrcSpanAnnA (HsType DocNameI)
tau_ty

--  tau_ty :: LHsType DocNameI
   tau_ty :: LHsKind DocNameI
tau_ty = case HsConDeclGADTDetails DocNameI
args of
              RecConGADT XRecConGADT DocNameI
_ XRec DocNameI [LConDeclField DocNameI]
flds -> LHsKind DocNameI -> LHsKind DocNameI -> LHsKind 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 [AddEpAnn]
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))) LHsKind DocNameI
res_ty
              PrefixConGADT XPrefixConGADT DocNameI
_ [HsScaled DocNameI (LHsKind 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 :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsKind DocNameI -> LHsKind DocNameI -> LHsKind DocNameI
GenLocated SrcSpanAnnA (HsType DocNameI)
-> GenLocated SrcSpanAnnA (HsType DocNameI)
-> GenLocated SrcSpanAnnA (HsType DocNameI)
mkFunTy LHsKind 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 (LHsKind DocNameI)]
[HsScaled DocNameI (GenLocated SrcSpanAnnA (HsType DocNameI))]
pos_args)

   mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
   mkFunTy :: LHsKind DocNameI -> LHsKind DocNameI -> LHsKind DocNameI
mkFunTy LHsKind DocNameI
a LHsKind DocNameI
b = HsType DocNameI -> GenLocated SrcSpanAnnA (HsType DocNameI)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XFunTy DocNameI
-> HsArrow DocNameI
-> LHsKind DocNameI
-> LHsKind DocNameI
-> HsType DocNameI
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy DocNameI
EpAnn [AddEpAnn]
forall a. NoAnn a => a
noAnn (XUnrestrictedArrow DocNameI -> HsArrow DocNameI
forall pass. XUnrestrictedArrow pass -> HsArrow pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow DocNameI
noExtField) LHsKind DocNameI
a LHsKind 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 (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> IdP GhcRn
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
tv)))
    | 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 | TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isDataDecl 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 (tcdDataDefn d) })
  TyClD XTyClD GhcRn
x TyClDecl GhcRn
d | TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl 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 (tcdSigs d),
               tcdATs = restrictATs names (tcdATs d) })
  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 :: * -> *).
MonadFail m =>
[Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn)
restrictCons [Name]
names [LConDecl GhcRn]
cons)
    NewTypeCon LConDecl GhcRn
con -> DataDefnCons (LConDecl GhcRn)
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn)
    -> DataDefnCons (LConDecl GhcRn))
-> Maybe (GenLocated SrcSpanAnnA (ConDecl 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 []) GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> DataDefnCons (LConDecl GhcRn)
GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall a. a -> DataDefnCons a
NewTypeCon (Maybe (GenLocated SrcSpanAnnA (ConDecl GhcRn))
 -> DataDefnCons (LConDecl GhcRn))
-> Maybe (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> DataDefnCons (LConDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe (LConDecl GhcRn) -> Maybe (LConDecl GhcRn)
forall (m :: * -> *).
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 :: * -> *).
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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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) })
              -- see above
      where
        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 :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\GenLocated SrcSpanAnnA (FieldOcc GhcRn)
f -> FieldOcc GhcRn -> XCFieldOcc GhcRn
forall pass. FieldOcc pass -> XCFieldOcc pass
foExt (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (FieldOcc GhcRn)
f) Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) 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 :: * -> *) 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 :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names ]


-------------------------------------------------------------------------------
-- * Parenthesization
-------------------------------------------------------------------------------

-- | Precedence level (inside the 'HsType' AST).
data Precedence
  = PREC_TOP  -- ^ precedence of 'type' production in GHC's parser

  | PREC_SIG  -- ^ explicit type signature

  | PREC_CTX  -- ^ Used for single contexts, eg. ctx => type
              -- (as opposed to (ctx1, ctx2) => type)

  | PREC_FUN  -- ^ precedence of 'btype' production in GHC's parser
              -- (used for LH arg of (->))

  | PREC_OP   -- ^ arg of any infix operator
              -- (we don't keep have fixity info)

  | PREC_CON  -- ^ arg of type application: always parenthesize unless atomic
  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 HsSrcBang
b XRec a (HsType a)
ty)     = XBangTy a -> HsSrcBang -> XRec a (HsType a) -> HsType a
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy a
x HsSrcBang
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 XParTy a
AnnParen
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 (UserTyVar XUserTyVar a
x flag
flag LIdP a
n) = XUserTyVar a -> flag -> LIdP a -> HsTyVarBndr flag a
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar a
x flag
flag LIdP a
n
reparenTyVar (KindedTyVar XKindedTyVar a
x flag
flag LIdP a
n LHsKind a
kind) = XKindedTyVar a -> flag -> LIdP a -> LHsKind a -> HsTyVarBndr flag a
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar a
x flag
flag LIdP a
n (LHsKind a -> LHsKind a
forall a. XRecCond a => LHsType a -> LHsType a
reparenLType LHsKind a
kind)
reparenTyVar v :: HsTyVarBndr flag a
v@XTyVarBndr{} = HsTyVarBndr flag 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 :: * -> *) 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 :: * -> *) 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 (FieldOcc GhcRn -> XCFieldOcc GhcRn
FieldOcc GhcRn -> Name
forall pass. FieldOcc pass -> XCFieldOcc pass
foExt (FieldOcc GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> 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 :: * -> *) 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
    | TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isDataDecl  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 :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([GenLocated SrcSpanAnnN Name] -> [GenLocated SrcSpanAnnN Name]
forall a. [a] -> [a]
forall (t :: * -> *) 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)
                                (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
 -> [GenLocated SrcSpanAnnN Name])
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [GenLocated SrcSpanAnnN Name]
forall a b. (a -> b) -> a -> b
$ (HsDataDefn GhcRn -> DataDefnCons (LConDecl GhcRn)
HsDataDefn GhcRn
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons (HsDataDefn GhcRn
 -> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)))
-> (TyClDecl GhcRn -> HsDataDefn GhcRn)
-> TyClDecl GhcRn
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GhcRn -> HsDataDefn GhcRn
forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn) TyClDecl GhcRn
d
    | TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl 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) (TyClDecl GhcRn -> [LFamilyDecl GhcRn]
forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs TyClDecl GhcRn
d) [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
_) <- TyClDecl GhcRn -> [LSig GhcRn]
forall pass. TyClDecl pass -> [LSig pass]
tcdSigs TyClDecl GhcRn
d, 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 :: * -> * -> *) 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 :: * -> *) 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 :: * -> *) 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
  | TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isDataDecl  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 :: * -> *) 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))
  | TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl 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 :: * -> *). 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
           }

-------------------------------------------------------------------------------
-- * '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 :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 [GenLocated SrcSpanAnnA (HsType DocNameI)]
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType DocNameI)])
-> GenLocated
     SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType 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 [GenLocated SrcSpanAnnA (HsType DocNameI)])
mctxt