{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# 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.Maybe ( mapMaybe )

import Haddock.Types( DocName, DocNameI )

import BasicTypes ( PromotionFlag(..) )
import Exception
import FV
import Outputable ( Outputable, panic, showPpr )
import Name
import NameSet
import Module
import HscTypes
import GHC
import Class
import DynFlags
import SrcLoc    ( advanceSrcLoc )
import Var       ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
                   isInvisibleArgFlag )
import VarSet    ( VarSet, emptyVarSet )
import VarEnv    ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
import TyCoRep   ( Type(..) )
import Type      ( isRuntimeRepVar )
import TysWiredIn( liftedRepDataConTyCon )

import           StringBuffer ( StringBuffer )
import qualified StringBuffer             as S

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

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
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

getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder (TyClD XTyClD (GhcPass p)
_ TyClDecl (GhcPass p)
d) = [TyClDecl (GhcPass p) -> IdP (GhcPass p)
forall (p :: Pass). TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl (GhcPass p)
d]
getMainDeclBinder (ValD XValD (GhcPass p)
_ HsBind (GhcPass p)
d) =
  case HsBind (GhcPass p) -> [IdP (GhcPass p)]
forall p idR.
(SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p)) =>
HsBindLR p idR -> [IdP p]
collectHsBindBinders HsBind (GhcPass p)
d of
    []       -> []
    (IdP (GhcPass p)
name:[IdP (GhcPass p)]
_) -> [IdP (GhcPass p)
name]
getMainDeclBinder (SigD XSigD (GhcPass p)
_ Sig (GhcPass p)
d) = Sig (GhcPass p) -> [IdP (GhcPass p)]
forall name. Sig name -> [IdP name]
sigNameNoLoc Sig (GhcPass p)
d
getMainDeclBinder (ForD XForD (GhcPass p)
_ (ForeignImport XForeignImport (GhcPass p)
_ Located (IdP (GhcPass p))
name LHsSigType (GhcPass p)
_ ForeignImport
_)) = [Located (IdP (GhcPass p))
-> SrcSpanLess (Located (IdP (GhcPass p)))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP (GhcPass p))
name]
getMainDeclBinder (ForD XForD (GhcPass p)
_ (ForeignExport XForeignExport (GhcPass p)
_ Located (IdP (GhcPass p))
_ LHsSigType (GhcPass p)
_ ForeignExport
_)) = []
getMainDeclBinder HsDecl (GhcPass p)
_ = []

-- Extract the source location where an instance is defined. This is used
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
getInstLoc (ClsInstD XClsInstD (GhcPass p)
_ (ClsInstDecl { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType (GhcPass p)
ty })) = LHsType (GhcPass p) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigType (GhcPass p) -> LHsType (GhcPass p)
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType LHsSigType (GhcPass p)
ty)
getInstLoc (DataFamInstD XDataFamInstD (GhcPass p)
_ (DataFamInstDecl
  { dfid_eqn :: forall pass.
DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn = HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> Located (IdP pass)
feqn_tycon = L SrcSpan
l IdP (GhcPass p)
_ }}})) = SrcSpan
l
getInstLoc (TyFamInstD XTyFamInstD (GhcPass p)
_ (TyFamInstDecl
  -- Since CoAxioms' Names refer to the whole line for type family instances
  -- in particular, we need to dig a bit deeper to pull out the entire
  -- equation. This does not happen for data family instances, for some reason.
  { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn { feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = L SrcSpan
l HsType (GhcPass p)
_ }}})) = SrcSpan
l
getInstLoc (ClsInstD XClsInstD (GhcPass p)
_ (XClsInstDecl XXClsInstDecl (GhcPass p)
nec)) = NoExtCon -> SrcSpan
forall a. NoExtCon -> a
noExtCon NoExtCon
XXClsInstDecl (GhcPass p)
nec
getInstLoc (DataFamInstD XDataFamInstD (GhcPass p)
_ (DataFamInstDecl (HsIB XHsIB (GhcPass p) (FamEqn (GhcPass p) (HsDataDefn (GhcPass p)))
_ (XFamEqn XXFamEqn (GhcPass p) (HsDataDefn (GhcPass p))
nec)))) = NoExtCon -> SrcSpan
forall a. NoExtCon -> a
noExtCon NoExtCon
XXFamEqn (GhcPass p) (HsDataDefn (GhcPass p))
nec
getInstLoc (TyFamInstD XTyFamInstD (GhcPass p)
_ (TyFamInstDecl (HsIB XHsIB (GhcPass p) (FamEqn (GhcPass p) (LHsType (GhcPass p)))
_ (XFamEqn XXFamEqn (GhcPass p) (LHsType (GhcPass p))
nec)))) = NoExtCon -> SrcSpan
forall a. NoExtCon -> a
noExtCon NoExtCon
XXFamEqn (GhcPass p) (LHsType (GhcPass p))
nec
getInstLoc (XInstDecl XXInstDecl (GhcPass p)
nec) = NoExtCon -> SrcSpan
forall a. NoExtCon -> a
noExtCon NoExtCon
XXInstDecl (GhcPass p)
nec
getInstLoc (DataFamInstD XDataFamInstD (GhcPass p)
_ (DataFamInstDecl (XHsImplicitBndrs XXHsImplicitBndrs
  (GhcPass p) (FamEqn (GhcPass p) (HsDataDefn (GhcPass p)))
nec))) = NoExtCon -> SrcSpan
forall a. NoExtCon -> a
noExtCon NoExtCon
XXHsImplicitBndrs
  (GhcPass p) (FamEqn (GhcPass p) (HsDataDefn (GhcPass p)))
nec
getInstLoc (TyFamInstD XTyFamInstD (GhcPass p)
_ (TyFamInstDecl (XHsImplicitBndrs XXHsImplicitBndrs
  (GhcPass p) (FamEqn (GhcPass p) (LHsType (GhcPass p)))
nec))) = NoExtCon -> SrcSpan
forall a. NoExtCon -> a
noExtCon NoExtCon
XXHsImplicitBndrs
  (GhcPass p) (FamEqn (GhcPass p) (LHsType (GhcPass p)))
nec



-- 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 :: (IdP (GhcPass p) -> Bool)
-> LSig (GhcPass p) -> Maybe (LSig (GhcPass p))
filterLSigNames IdP (GhcPass p) -> Bool
p (L SrcSpan
loc Sig (GhcPass p)
sig) = SrcSpan -> Sig (GhcPass p) -> LSig (GhcPass p)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Sig (GhcPass p) -> LSig (GhcPass p))
-> Maybe (Sig (GhcPass p)) -> Maybe (LSig (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 :: (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)
_ Located (IdP (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
$ Located (IdP (GhcPass p))
-> SrcSpanLess (Located (IdP (GhcPass p)))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP (GhcPass p))
n) Sig (GhcPass p)
orig
filterSigNames IdP (GhcPass p) -> Bool
p orig :: Sig (GhcPass p)
orig@(InlineSig XInlineSig (GhcPass p)
_ Located (IdP (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
$ Located (IdP (GhcPass p))
-> SrcSpanLess (Located (IdP (GhcPass p)))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP (GhcPass p))
n) Sig (GhcPass p)
orig
filterSigNames IdP (GhcPass p) -> Bool
p (FixSig XFixSig (GhcPass p)
_ (FixitySig XFixitySig (GhcPass p)
_ [Located (IdP (GhcPass p))]
ns Fixity
ty)) =
  case (Located (IdP (GhcPass p)) -> Bool)
-> [Located (IdP (GhcPass p))] -> [Located (IdP (GhcPass p))]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
p (IdP (GhcPass p) -> Bool)
-> (Located (IdP (GhcPass p)) -> IdP (GhcPass p))
-> Located (IdP (GhcPass p))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (IdP (GhcPass p)) -> IdP (GhcPass p)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located (IdP (GhcPass p))]
ns of
    []       -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [Located (IdP (GhcPass 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 NoExtField
XFixSig (GhcPass p)
noExtField (XFixitySig (GhcPass p)
-> [Located (IdP (GhcPass p))] -> Fixity -> FixitySig (GhcPass p)
forall pass.
XFixitySig pass -> [Located (IdP pass)] -> Fixity -> FixitySig pass
FixitySig NoExtField
XFixitySig (GhcPass p)
noExtField [Located (IdP (GhcPass p))]
filtered Fixity
ty))
filterSigNames IdP (GhcPass p) -> Bool
_ orig :: Sig (GhcPass p)
orig@(MinimalSig XMinimalSig (GhcPass p)
_ SourceText
_ LBooleanFormula (Located (IdP (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)
_ [Located (IdP (GhcPass p))]
ns LHsSigWcType (GhcPass p)
ty) =
  case (Located (IdP (GhcPass p)) -> Bool)
-> [Located (IdP (GhcPass p))] -> [Located (IdP (GhcPass p))]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
p (IdP (GhcPass p) -> Bool)
-> (Located (IdP (GhcPass p)) -> IdP (GhcPass p))
-> Located (IdP (GhcPass p))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (IdP (GhcPass p)) -> IdP (GhcPass p)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located (IdP (GhcPass p))]
ns of
    []       -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [Located (IdP (GhcPass p))]
filtered -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just (XTypeSig (GhcPass p)
-> [Located (IdP (GhcPass p))]
-> LHsSigWcType (GhcPass p)
-> Sig (GhcPass p)
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig (GhcPass p)
noExtField [Located (IdP (GhcPass p))]
filtered LHsSigWcType (GhcPass p)
ty)
filterSigNames IdP (GhcPass p) -> Bool
p (ClassOpSig XClassOpSig (GhcPass p)
_ Bool
is_default [Located (IdP (GhcPass p))]
ns LHsSigType (GhcPass p)
ty) =
  case (Located (IdP (GhcPass p)) -> Bool)
-> [Located (IdP (GhcPass p))] -> [Located (IdP (GhcPass p))]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
p (IdP (GhcPass p) -> Bool)
-> (Located (IdP (GhcPass p)) -> IdP (GhcPass p))
-> Located (IdP (GhcPass p))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (IdP (GhcPass p)) -> IdP (GhcPass p)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located (IdP (GhcPass p))]
ns of
    []       -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [Located (IdP (GhcPass p))]
filtered -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just (XClassOpSig (GhcPass p)
-> Bool
-> [Located (IdP (GhcPass p))]
-> LHsSigType (GhcPass p)
-> Sig (GhcPass p)
forall pass.
XClassOpSig pass
-> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
ClassOpSig NoExtField
XClassOpSig (GhcPass p)
noExtField Bool
is_default [Located (IdP (GhcPass p))]
filtered LHsSigType (GhcPass p)
ty)
filterSigNames IdP (GhcPass p) -> Bool
p (PatSynSig XPatSynSig (GhcPass p)
_ [Located (IdP (GhcPass p))]
ns LHsSigType (GhcPass p)
ty) =
  case (Located (IdP (GhcPass p)) -> Bool)
-> [Located (IdP (GhcPass p))] -> [Located (IdP (GhcPass p))]
forall a. (a -> Bool) -> [a] -> [a]
filter (IdP (GhcPass p) -> Bool
p (IdP (GhcPass p) -> Bool)
-> (Located (IdP (GhcPass p)) -> IdP (GhcPass p))
-> Located (IdP (GhcPass p))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (IdP (GhcPass p)) -> IdP (GhcPass p)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located (IdP (GhcPass p))]
ns of
    []       -> Maybe (Sig (GhcPass p))
forall a. Maybe a
Nothing
    [Located (IdP (GhcPass p))]
filtered -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
forall a. a -> Maybe a
Just (XPatSynSig (GhcPass p)
-> [Located (IdP (GhcPass p))]
-> LHsSigType (GhcPass p)
-> Sig (GhcPass p)
forall pass.
XPatSynSig pass
-> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
PatSynSig NoExtField
XPatSynSig (GhcPass p)
noExtField [Located (IdP (GhcPass 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 :: 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 name -> [IdP name]
sigName :: LSig name -> [IdP name]
sigName (L SrcSpan
_ Sig name
sig) = Sig name -> [IdP name]
forall name. Sig name -> [IdP name]
sigNameNoLoc Sig name
sig

sigNameNoLoc :: Sig name -> [IdP name]
sigNameNoLoc :: Sig name -> [IdP name]
sigNameNoLoc (TypeSig    XTypeSig name
_   [Located (IdP name)]
ns LHsSigWcType name
_)         = (Located (IdP name) -> IdP name)
-> [Located (IdP name)] -> [IdP name]
forall a b. (a -> b) -> [a] -> [b]
map Located (IdP name) -> IdP name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP name)]
ns
sigNameNoLoc (ClassOpSig XClassOpSig name
_ Bool
_ [Located (IdP name)]
ns LHsSigType name
_)         = (Located (IdP name) -> IdP name)
-> [Located (IdP name)] -> [IdP name]
forall a b. (a -> b) -> [a] -> [b]
map Located (IdP name) -> IdP name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP name)]
ns
sigNameNoLoc (PatSynSig  XPatSynSig name
_   [Located (IdP name)]
ns LHsSigType name
_)         = (Located (IdP name) -> IdP name)
-> [Located (IdP name)] -> [IdP name]
forall a b. (a -> b) -> [a] -> [b]
map Located (IdP name) -> IdP name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP name)]
ns
sigNameNoLoc (SpecSig    XSpecSig name
_   Located (IdP name)
n [LHsSigType name]
_ InlinePragma
_)        = [Located (IdP name) -> SrcSpanLess (Located (IdP name))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP name)
n]
sigNameNoLoc (InlineSig  XInlineSig name
_   Located (IdP name)
n InlinePragma
_)          = [Located (IdP name) -> SrcSpanLess (Located (IdP name))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP name)
n]
sigNameNoLoc (FixSig XFixSig name
_ (FixitySig XFixitySig name
_ [Located (IdP name)]
ns Fixity
_)) = (Located (IdP name) -> IdP name)
-> [Located (IdP name)] -> [IdP name]
forall a b. (a -> b) -> [a] -> [b]
map Located (IdP name) -> IdP name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP name)]
ns
sigNameNoLoc Sig name
_                             = []

-- | Was this signature given by the user?
isUserLSig :: LSig name -> Bool
isUserLSig :: LSig name -> Bool
isUserLSig (L SrcSpan
_ (TypeSig {}))    = Bool
True
isUserLSig (L SrcSpan
_ (ClassOpSig {})) = Bool
True
isUserLSig (L SrcSpan
_ (PatSynSig {}))  = Bool
True
isUserLSig LSig name
_                     = Bool
False


isClassD :: HsDecl a -> Bool
isClassD :: 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

isValD :: HsDecl a -> Bool
isValD :: HsDecl a -> Bool
isValD (ValD XValD a
_ HsBind a
_) = Bool
True
isValD HsDecl a
_ = Bool
False

pretty :: Outputable a => DynFlags -> a -> String
pretty :: DynFlags -> a -> String
pretty = DynFlags -> a -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr

nubByName :: (a -> Name) -> [a] -> [a]
nubByName :: (a -> Name) -> [a] -> [a]
nubByName a -> Name
f [a]
ns = NameSet -> [a] -> [a]
go NameSet
emptyNameSet [a]
ns
  where
    go :: NameSet -> [a] -> [a]
go !NameSet
_ [] = []
    go !NameSet
s (a
x:[a]
xs)
      | Name
y Name -> NameSet -> Bool
`elemNameSet` NameSet
s = NameSet -> [a] -> [a]
go NameSet
s [a]
xs
      | Bool
otherwise         = let !s' :: NameSet
s' = NameSet -> Name -> NameSet
extendNameSet NameSet
s Name
y
                            in a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: NameSet -> [a] -> [a]
go NameSet
s' [a]
xs
      where
        y :: Name
y = a -> Name
f a
x


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

-- 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 :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n
hsTyVarBndrName :: HsTyVarBndr n -> IdP n
hsTyVarBndrName (UserTyVar XUserTyVar n
_ Located (IdP n)
name) = Located (IdP n) -> SrcSpanLess (Located (IdP n))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP n)
name
hsTyVarBndrName (KindedTyVar XKindedTyVar n
_ (L SrcSpan
_ IdP n
name) LHsKind n
_) = IdP n
name
hsTyVarBndrName (XTyVarBndr XXTyVarBndr n
nec) = NoExtCon -> IdP n
forall a. NoExtCon -> a
noExtCon NoExtCon
XXTyVarBndr n
nec

getConNamesI :: ConDecl DocNameI -> [Located DocName]
getConNamesI :: ConDecl DocNameI -> [Located DocName]
getConNamesI ConDeclH98  {con_name :: forall pass. ConDecl pass -> Located (IdP pass)
con_name  = Located (IdP DocNameI)
name}  = [Located (IdP DocNameI)
Located DocName
name]
getConNamesI ConDeclGADT {con_names :: forall pass. ConDecl pass -> [Located (IdP pass)]
con_names = [Located (IdP DocNameI)]
names} = [Located (IdP DocNameI)]
[Located DocName]
names
getConNamesI (XConDecl XXConDecl DocNameI
nec) = NoExtCon -> [Located DocName]
forall a. NoExtCon -> a
noExtCon NoExtCon
XXConDecl DocNameI
nec

hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing
hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing
hsImplicitBodyI (HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = thing
body }) = thing
body
hsImplicitBodyI (XHsImplicitBndrs XXHsImplicitBndrs DocNameI thing
nec) = NoExtCon -> thing
forall a. NoExtCon -> a
noExtCon NoExtCon
XXHsImplicitBndrs DocNameI thing
nec

hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
hsSigTypeI = LHsSigType DocNameI -> LHsType DocNameI
forall thing. HsImplicitBndrs DocNameI thing -> thing
hsImplicitBodyI

getGADTConType :: ConDecl DocNameI -> LHsType 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 -> LHsType DocNameI
getGADTConType (ConDeclGADT { con_forall :: forall pass. ConDecl pass -> Located Bool
con_forall = L SrcSpan
_ Bool
has_forall
                            , con_qvars :: forall pass. ConDecl pass -> LHsQTyVars pass
con_qvars = LHsQTyVars DocNameI
qtvs
                            , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext DocNameI)
mcxt, con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = HsConDeclDetails DocNameI
args
                            , con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsType DocNameI
res_ty })
 | Bool
has_forall = SrcSpanLess (LHsType DocNameI) -> LHsType DocNameI
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsForAllTy :: forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy { hst_fvf :: ForallVisFlag
hst_fvf = ForallVisFlag
ForallInvis
                                  , hst_xforall :: XForAllTy DocNameI
hst_xforall = NoExtField
XForAllTy DocNameI
noExtField
                                  , hst_bndrs :: [LHsTyVarBndr DocNameI]
hst_bndrs = LHsQTyVars DocNameI -> [LHsTyVarBndr DocNameI]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars DocNameI
qtvs
                                  , hst_body :: LHsType DocNameI
hst_body  = LHsType DocNameI
theta_ty })
 | Bool
otherwise  = LHsType DocNameI
theta_ty
 where
   theta_ty :: LHsType DocNameI
theta_ty | Just LHsContext DocNameI
theta <- Maybe (LHsContext DocNameI)
mcxt
            = SrcSpanLess (LHsType DocNameI) -> LHsType DocNameI
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy DocNameI
hst_xqual = NoExtField
XQualTy DocNameI
noExtField, hst_ctxt :: LHsContext DocNameI
hst_ctxt = LHsContext DocNameI
theta, hst_body :: LHsType DocNameI
hst_body = LHsType DocNameI
tau_ty })
            | Bool
otherwise
            = LHsType DocNameI
tau_ty

   tau_ty :: LHsType DocNameI
tau_ty = case HsConDeclDetails DocNameI
args of
              RecCon Located [LConDeclField DocNameI]
flds -> SrcSpanLess (LHsType DocNameI) -> LHsType DocNameI
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XFunTy DocNameI
-> LHsType DocNameI -> LHsType DocNameI -> HsType DocNameI
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy DocNameI
noExtField (SrcSpanLess (LHsType DocNameI) -> LHsType DocNameI
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XRecTy DocNameI -> [LConDeclField DocNameI] -> HsType DocNameI
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy NoExtField
XRecTy DocNameI
noExtField (Located [LConDeclField DocNameI]
-> SrcSpanLess (Located [LConDeclField DocNameI])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [LConDeclField DocNameI]
flds))) LHsType DocNameI
res_ty)
              PrefixCon [LHsType DocNameI]
pos_args -> (LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI)
-> LHsType DocNameI -> [LHsType DocNameI] -> LHsType DocNameI
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
forall a pass.
(HasSrcSpan a, XFunTy pass ~ NoExtField,
 SrcSpanLess a ~ HsType pass) =>
LHsType pass -> LHsType pass -> a
mkFunTy LHsType DocNameI
res_ty [LHsType DocNameI]
pos_args
              InfixCon LHsType DocNameI
arg1 LHsType DocNameI
arg2 -> LHsType DocNameI
arg1 LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
forall a pass.
(HasSrcSpan a, XFunTy pass ~ NoExtField,
 SrcSpanLess a ~ HsType pass) =>
LHsType pass -> LHsType pass -> a
`mkFunTy` (LHsType DocNameI
arg2 LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
forall a pass.
(HasSrcSpan a, XFunTy pass ~ NoExtField,
 SrcSpanLess a ~ HsType pass) =>
LHsType pass -> LHsType pass -> a
`mkFunTy` LHsType DocNameI
res_ty)

   mkFunTy :: LHsType pass -> LHsType pass -> a
mkFunTy LHsType pass
a LHsType pass
b = SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy pass
noExtField LHsType pass
a LHsType pass
b)

getGADTConType (ConDeclH98 {}) = String -> LHsType DocNameI
forall a. String -> a
panic String
"getGADTConType"
  -- Should only be called on ConDeclGADT
getGADTConType (XConDecl XXConDecl DocNameI
nec) = NoExtCon -> LHsType DocNameI
forall a. NoExtCon -> a
noExtCon NoExtCon
XXConDecl DocNameI
nec

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 HsBind DocNameI -> [IdP DocNameI]
forall p idR.
(SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p)) =>
HsBindLR p idR -> [IdP p]
collectHsBindBinders HsBind DocNameI
d of
    []       -> []
    (IdP DocNameI
name:[IdP DocNameI]
_) -> [IdP DocNameI
name]
getMainDeclBinderI (SigD XSigD DocNameI
_ Sig DocNameI
d) = Sig DocNameI -> [IdP DocNameI]
forall name. Sig name -> [IdP name]
sigNameNoLoc Sig DocNameI
d
getMainDeclBinderI (ForD XForD DocNameI
_ (ForeignImport XForeignImport DocNameI
_ Located (IdP DocNameI)
name LHsSigType DocNameI
_ ForeignImport
_)) = [Located DocName -> SrcSpanLess (Located DocName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP DocNameI)
Located DocName
name]
getMainDeclBinderI (ForD XForD DocNameI
_ (ForeignExport XForeignExport DocNameI
_ Located (IdP DocNameI)
_ LHsSigType DocNameI
_ ForeignExport
_)) = []
getMainDeclBinderI HsDecl DocNameI
_ = []

familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName
familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName
familyDeclLNameI (FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName = Located (IdP DocNameI)
n }) = Located (IdP DocNameI)
Located DocName
n
familyDeclLNameI (XFamilyDecl XXFamilyDecl DocNameI
nec) = NoExtCon -> Located DocName
forall a. NoExtCon -> a
noExtCon NoExtCon
XXFamilyDecl DocNameI
nec

tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName
tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName
tyClDeclLNameI (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl DocNameI
fd })     = FamilyDecl DocNameI -> Located DocName
familyDeclLNameI FamilyDecl DocNameI
fd
tyClDeclLNameI (SynDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = Located (IdP DocNameI)
ln })   = Located (IdP DocNameI)
Located DocName
ln
tyClDeclLNameI (DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = Located (IdP DocNameI)
ln })  = Located (IdP DocNameI)
Located DocName
ln
tyClDeclLNameI (ClassDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = Located (IdP DocNameI)
ln }) = Located (IdP DocNameI)
Located DocName
ln
tyClDeclLNameI (XTyClDecl XXTyClDecl DocNameI
nec) = NoExtCon -> Located DocName
forall a. NoExtCon -> a
noExtCon NoExtCon
XXTyClDecl DocNameI
nec

tcdNameI :: TyClDecl DocNameI -> DocName
tcdNameI :: TyClDecl DocNameI -> DocName
tcdNameI = Located DocName -> DocName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located DocName -> DocName)
-> (TyClDecl DocNameI -> Located DocName)
-> TyClDecl DocNameI
-> DocName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl DocNameI -> Located DocName
tyClDeclLNameI

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

getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)
-- 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
getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)
getGADTConTypeG (ConDeclGADT { con_forall :: forall pass. ConDecl pass -> Located Bool
con_forall = L SrcSpan
_ Bool
has_forall
                            , con_qvars :: forall pass. ConDecl pass -> LHsQTyVars pass
con_qvars = LHsQTyVars (GhcPass p)
qtvs
                            , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext (GhcPass p))
mcxt, con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = HsConDeclDetails (GhcPass p)
args
                            , con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsType (GhcPass p)
res_ty })
 | Bool
has_forall = SrcSpanLess (LHsType (GhcPass p)) -> LHsType (GhcPass p)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsForAllTy :: forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy { hst_fvf :: ForallVisFlag
hst_fvf = ForallVisFlag
ForallInvis
                                  , hst_xforall :: XForAllTy (GhcPass p)
hst_xforall = NoExtField
XForAllTy (GhcPass p)
noExtField
                                  , hst_bndrs :: [LHsTyVarBndr (GhcPass p)]
hst_bndrs = LHsQTyVars (GhcPass p) -> [LHsTyVarBndr (GhcPass p)]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars (GhcPass p)
qtvs
                                  , hst_body :: LHsType (GhcPass p)
hst_body  = LHsType (GhcPass p)
theta_ty })
 | Bool
otherwise  = LHsType (GhcPass p)
theta_ty
 where
   theta_ty :: LHsType (GhcPass p)
theta_ty | Just LHsContext (GhcPass p)
theta <- Maybe (LHsContext (GhcPass p))
mcxt
            = SrcSpanLess (LHsType (GhcPass p)) -> LHsType (GhcPass p)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy (GhcPass p)
hst_xqual = NoExtField
XQualTy (GhcPass p)
noExtField, hst_ctxt :: LHsContext (GhcPass p)
hst_ctxt = LHsContext (GhcPass p)
theta, hst_body :: LHsType (GhcPass p)
hst_body = LHsType (GhcPass p)
tau_ty })
            | Bool
otherwise
            = LHsType (GhcPass p)
tau_ty

   tau_ty :: LHsType (GhcPass p)
tau_ty = case HsConDeclDetails (GhcPass p)
args of
              RecCon Located [LConDeclField (GhcPass p)]
flds -> SrcSpanLess (LHsType (GhcPass p)) -> LHsType (GhcPass p)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XFunTy (GhcPass p)
-> LHsType (GhcPass p) -> LHsType (GhcPass p) -> HsType (GhcPass p)
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy (GhcPass p)
noExtField (SrcSpanLess (LHsType (GhcPass p)) -> LHsType (GhcPass p)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XRecTy (GhcPass p)
-> [LConDeclField (GhcPass p)] -> HsType (GhcPass p)
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy NoExtField
XRecTy (GhcPass p)
noExtField (Located [LConDeclField (GhcPass p)]
-> SrcSpanLess (Located [LConDeclField (GhcPass p)])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [LConDeclField (GhcPass p)]
flds))) LHsType (GhcPass p)
res_ty)
              PrefixCon [LHsType (GhcPass p)]
pos_args -> (LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p))
-> LHsType (GhcPass p)
-> [LHsType (GhcPass p)]
-> LHsType (GhcPass p)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
forall a pass.
(HasSrcSpan a, XFunTy pass ~ NoExtField,
 SrcSpanLess a ~ HsType pass) =>
LHsType pass -> LHsType pass -> a
mkFunTy LHsType (GhcPass p)
res_ty [LHsType (GhcPass p)]
pos_args
              InfixCon LHsType (GhcPass p)
arg1 LHsType (GhcPass p)
arg2 -> LHsType (GhcPass p)
arg1 LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
forall a pass.
(HasSrcSpan a, XFunTy pass ~ NoExtField,
 SrcSpanLess a ~ HsType pass) =>
LHsType pass -> LHsType pass -> a
`mkFunTy` (LHsType (GhcPass p)
arg2 LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
forall a pass.
(HasSrcSpan a, XFunTy pass ~ NoExtField,
 SrcSpanLess a ~ HsType pass) =>
LHsType pass -> LHsType pass -> a
`mkFunTy` LHsType (GhcPass p)
res_ty)

   mkFunTy :: LHsType pass -> LHsType pass -> a
mkFunTy LHsType pass
a LHsType pass
b = SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy pass
noExtField LHsType pass
a LHsType pass
b)

getGADTConTypeG (ConDeclH98 {}) = String -> LHsType (GhcPass p)
forall a. String -> a
panic String
"getGADTConTypeG"
  -- Should only be called on ConDeclGADT
getGADTConTypeG (XConDecl XXConDecl (GhcPass p)
nec) = NoExtCon -> LHsType (GhcPass p)
forall a. NoExtCon -> a
noExtCon NoExtCon
XXConDecl (GhcPass p)
nec


mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
-- Dubious, because the implicit binders are empty even
-- though the type might have free varaiables
mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
mkEmptySigWcType LHsType GhcRn
ty = HsImplicitBndrs GhcRn (LHsType GhcRn) -> LHsSigWcType GhcRn
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (LHsType GhcRn -> HsImplicitBndrs GhcRn (LHsType GhcRn)
forall thing. thing -> HsImplicitBndrs GhcRn thing
mkEmptyImplicitBndrs LHsType GhcRn
ty)


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 SrcSpan
pos (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [Located (IdP GhcRn)]
lname HsImplicitBndrs GhcRn (LHsType GhcRn)
ltype))
  = SrcSpan -> Sig GhcRn -> LSig GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
pos (XTypeSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig GhcRn
noExtField [Located (IdP GhcRn)]
lname (LHsType GhcRn -> LHsSigWcType GhcRn
mkEmptySigWcType (LHsType GhcRn -> LHsType GhcRn
go (HsImplicitBndrs GhcRn (LHsType GhcRn) -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType HsImplicitBndrs GhcRn (LHsType GhcRn)
ltype))))
          -- The mkEmptySigWcType is suspicious
  where
    go :: LHsType GhcRn -> LHsType GhcRn
go (L SrcSpan
loc (HsForAllTy { hst_fvf :: forall pass. HsType pass -> ForallVisFlag
hst_fvf = ForallVisFlag
fvf, hst_bndrs :: forall pass. HsType pass -> [LHsTyVarBndr pass]
hst_bndrs = [LHsTyVarBndr GhcRn]
tvs, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty }))
       = SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsForAllTy :: forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy { hst_fvf :: ForallVisFlag
hst_fvf = ForallVisFlag
fvf, hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExtField
XForAllTy GhcRn
noExtField
                           , hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
tvs, hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn -> LHsType GhcRn
go LHsType GhcRn
ty })
    go (L SrcSpan
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 }))
       = SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField
                         , hst_ctxt :: LHsContext GhcRn
hst_ctxt = LHsContext GhcRn -> LHsContext GhcRn
add_ctxt LHsContext GhcRn
ctxt, hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
ty })
    go (L SrcSpan
loc HsType GhcRn
ty)
       = SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField
                         , hst_ctxt :: LHsContext GhcRn
hst_ctxt = LHsContext GhcRn -> LHsContext GhcRn
add_ctxt (SrcSpan -> [LHsType GhcRn] -> LHsContext GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc []), hst_body :: LHsType GhcRn
hst_body = SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsType GhcRn
ty })

    extra_pred :: LHsType GhcRn
extra_pred = IdP GhcRn -> [LHsType GhcRn] -> LHsType GhcRn
forall (p :: Pass).
IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp IdP GhcRn
Name
cls (LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes LHsQTyVars GhcRn
tvs0)
    add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn
add_ctxt (L SrcSpan
loc [LHsType GhcRn]
preds) = SrcSpan -> [LHsType GhcRn] -> LHsContext GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (LHsType GhcRn
extra_pred LHsType GhcRn -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a. a -> [a] -> [a]
: [LHsType GhcRn]
preds)

addClassContext Name
_ LHsQTyVars GhcRn
_ LSig GhcRn
sig = LSig GhcRn
sig   -- E.g. a MinimalSig is fine

lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes LHsQTyVars GhcRn
tvs
  = [ SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcRn
noExtField PromotionFlag
NotPromoted (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (LHsTyVarBndr GhcRn -> IdP GhcRn
forall (p :: Pass). LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr GhcRn
tv)))
    | LHsTyVarBndr GhcRn
tv <- LHsQTyVars GhcRn -> [LHsTyVarBndr GhcRn]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars GhcRn
tvs ]


--------------------------------------------------------------------------------
-- * Making abstract declarations
--------------------------------------------------------------------------------


restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo [Name]
names (L SrcSpan
loc HsDecl GhcRn
decl) = SrcSpan -> HsDecl GhcRn -> LHsDecl GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsDecl GhcRn -> LHsDecl GhcRn) -> HsDecl GhcRn -> LHsDecl 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 :: HsDataDefn GhcRn
tcdDataDefn = [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
restrictDataDefn [Name]
names (TyClDecl GhcRn -> HsDataDefn GhcRn
forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn TyClDecl GhcRn
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 :: [LSig GhcRn]
tcdSigs = [Name] -> [LSig GhcRn] -> [LSig GhcRn]
restrictDecls [Name]
names (TyClDecl GhcRn -> [LSig GhcRn]
forall pass. TyClDecl pass -> [LSig pass]
tcdSigs TyClDecl GhcRn
d),
               tcdATs :: [LFamilyDecl GhcRn]
tcdATs = [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
restrictATs [Name]
names (TyClDecl GhcRn -> [LFamilyDecl GhcRn]
forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs TyClDecl GhcRn
d) })
  HsDecl GhcRn
_ -> HsDecl GhcRn
decl

restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
restrictDataDefn [Name]
names defn :: HsDataDefn GhcRn
defn@(HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons })
  | NewOrData
DataType <- NewOrData
new_or_data
  = HsDataDefn GhcRn
defn { dd_cons :: [LConDecl GhcRn]
dd_cons = [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons [Name]
names [LConDecl GhcRn]
cons }
  | Bool
otherwise    -- Newtype
  = case [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons [Name]
names [LConDecl GhcRn]
cons of
      []    -> HsDataDefn GhcRn
defn { dd_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cons :: [LConDecl GhcRn]
dd_cons = [] }
      [LConDecl GhcRn
con] -> HsDataDefn GhcRn
defn { dd_cons :: [LConDecl GhcRn]
dd_cons = [LConDecl GhcRn
con] }
      [LConDecl GhcRn]
_ -> String -> HsDataDefn GhcRn
forall a. HasCallStack => String -> a
error String
"Should not happen"
restrictDataDefn [Name]
_ (XHsDataDefn XXHsDataDefn GhcRn
nec) = NoExtCon -> HsDataDefn GhcRn
forall a. NoExtCon -> a
noExtCon NoExtCon
XXHsDataDefn GhcRn
nec

restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons [Name]
names [LConDecl GhcRn]
decls = [ SrcSpan -> ConDecl GhcRn -> LConDecl GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
p ConDecl GhcRn
d | L SrcSpan
p (Just ConDecl GhcRn
d) <- (LConDecl GhcRn -> GenLocated SrcSpan (Maybe (ConDecl GhcRn)))
-> [LConDecl GhcRn] -> [GenLocated SrcSpan (Maybe (ConDecl GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map ((ConDecl GhcRn -> Maybe (ConDecl GhcRn))
-> LConDecl GhcRn -> GenLocated SrcSpan (Maybe (ConDecl GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConDecl GhcRn -> Maybe (ConDecl GhcRn)
keep) [LConDecl GhcRn]
decls ]
  where
    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
n -> Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names) ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located Name] -> [Name]) -> [Located Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConDecl GhcRn -> [Located (IdP GhcRn)]
forall (p :: Pass).
ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))]
getConNames ConDecl GhcRn
d) =
      case ConDecl GhcRn -> HsConDeclDetails GhcRn
forall pass. ConDecl pass -> HsConDeclDetails pass
con_args ConDecl GhcRn
d of
        PrefixCon [LHsType GhcRn]
_ -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just ConDecl GhcRn
d
        RecCon Located [LConDeclField GhcRn]
fields
          | (LConDeclField GhcRn -> Bool) -> [LConDeclField GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LConDeclField GhcRn -> Bool
field_avail (Located [LConDeclField GhcRn]
-> SrcSpanLess (Located [LConDeclField GhcRn])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [LConDeclField 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 :: HsConDeclDetails GhcRn
con_args = [LHsType GhcRn] -> HsConDeclDetails GhcRn
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ([ConDeclField GhcRn] -> [LHsType GhcRn]
forall pass. [ConDeclField pass] -> [LBangType pass]
field_types ((LConDeclField GhcRn -> ConDeclField GhcRn)
-> [LConDeclField GhcRn] -> [ConDeclField GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map LConDeclField GhcRn -> ConDeclField GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located [LConDeclField GhcRn]
-> SrcSpanLess (Located [LConDeclField GhcRn])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [LConDeclField GhcRn]
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 LHsType GhcRn
_ LHsType GhcRn
_ -> ConDecl GhcRn -> Maybe (ConDecl GhcRn)
forall a. a -> Maybe a
Just ConDecl GhcRn
d
      where
        field_avail :: LConDeclField GhcRn -> Bool
        field_avail :: LConDeclField GhcRn -> Bool
field_avail (L SrcSpan
_ (ConDeclField XConDeclField GhcRn
_ [LFieldOcc GhcRn]
fs LHsType GhcRn
_ Maybe LHsDocString
_))
            = (LFieldOcc GhcRn -> Bool) -> [LFieldOcc GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\LFieldOcc GhcRn
f -> FieldOcc GhcRn -> XCFieldOcc GhcRn
forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (LFieldOcc GhcRn -> SrcSpanLess (LFieldOcc GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LFieldOcc GhcRn
f) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names) [LFieldOcc GhcRn]
fs
        field_avail (L SrcSpan
_ (XConDeclField XXConDeclField GhcRn
nec)) = NoExtCon -> Bool
forall a. NoExtCon -> a
noExtCon NoExtCon
XXConDeclField GhcRn
nec
        field_types :: [ConDeclField pass] -> [LBangType pass]
field_types [ConDeclField pass]
flds = [ LBangType pass
t | ConDeclField XConDeclField pass
_ [LFieldOcc pass]
_ LBangType pass
t Maybe LHsDocString
_ <- [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 = (LSig GhcRn -> Maybe (LSig GhcRn)) -> [LSig GhcRn] -> [LSig 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 (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 = [ LFamilyDecl GhcRn
at | LFamilyDecl GhcRn
at <- [LFamilyDecl GhcRn]
ats , Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (FamilyDecl GhcRn -> Located (IdP GhcRn)
forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName (LFamilyDecl GhcRn -> SrcSpanLess (LFamilyDecl GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LFamilyDecl GhcRn
at)) Name -> [Name] -> 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
/= :: Precedence -> Precedence -> Bool
$c/= :: Precedence -> Precedence -> Bool
== :: Precedence -> Precedence -> Bool
$c== :: 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
min :: Precedence -> Precedence -> Precedence
$cmin :: Precedence -> Precedence -> Precedence
max :: Precedence -> Precedence -> Precedence
$cmax :: Precedence -> Precedence -> Precedence
>= :: Precedence -> Precedence -> Bool
$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
compare :: Precedence -> Precedence -> Ordering
$ccompare :: Precedence -> Precedence -> Ordering
$cp1Ord :: Eq 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 :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
reparenTypePrec :: Precedence -> HsType a -> HsType a
reparenTypePrec = Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> HsType a -> HsType a
go
  where

  -- Shorter name for 'reparenType'
  go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
  go :: Precedence -> HsType a -> HsType a
go Precedence
_ (HsBangTy XBangTy a
x HsSrcBang
b LHsType a
ty)     = XBangTy a -> HsSrcBang -> LHsType a -> HsType a
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy a
x HsSrcBang
b (LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType LHsType a
ty)
  go Precedence
_ (HsTupleTy XTupleTy a
x HsTupleSort
con [LHsType a]
tys) = XTupleTy a -> HsTupleSort -> [LHsType a] -> HsType a
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy a
x HsTupleSort
con ((LHsType a -> LHsType a) -> [LHsType a] -> [LHsType a]
forall a b. (a -> b) -> [a] -> [b]
map LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType [LHsType a]
tys)
  go Precedence
_ (HsSumTy XSumTy a
x [LHsType a]
tys)       = XSumTy a -> [LHsType a] -> HsType a
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy XSumTy a
x ((LHsType a -> LHsType a) -> [LHsType a] -> [LHsType a]
forall a b. (a -> b) -> [a] -> [b]
map LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType [LHsType a]
tys)
  go Precedence
_ (HsListTy XListTy a
x LHsType a
ty)       = XListTy a -> LHsType a -> HsType a
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy a
x (LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType LHsType 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 ((ConDeclField a -> ConDeclField a)
-> LConDeclField a -> LConDeclField a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConDeclField a -> ConDeclField a
forall a.
(XParTy a ~ NoExtField) =>
ConDeclField a -> ConDeclField a
reparenConDeclField) [LConDeclField a]
flds)
  go Precedence
p (HsDocTy XDocTy a
x LHsType a
ty LHsDocString
d)      = XDocTy a -> LHsType a -> LHsDocString -> HsType a
forall pass.
XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
HsDocTy XDocTy a
x (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
p LHsType a
ty) LHsDocString
d
  go Precedence
_ (HsExplicitListTy XExplicitListTy a
x PromotionFlag
p [LHsType a]
tys) = XExplicitListTy a -> PromotionFlag -> [LHsType a] -> HsType a
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy XExplicitListTy a
x PromotionFlag
p ((LHsType a -> LHsType a) -> [LHsType a] -> [LHsType a]
forall a b. (a -> b) -> [a] -> [b]
map LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType [LHsType a]
tys)
  go Precedence
_ (HsExplicitTupleTy XExplicitTupleTy a
x [LHsType a]
tys) = XExplicitTupleTy a -> [LHsType a] -> HsType a
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy XExplicitTupleTy a
x ((LHsType a -> LHsType a) -> [LHsType a] -> [LHsType a]
forall a b. (a -> b) -> [a] -> [b]
map LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType [LHsType a]
tys)
  go Precedence
p (HsKindSig XKindSig a
x LHsType a
ty LHsType a
kind)
    = Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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 -> LHsType a -> LHsType a -> HsType a
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig XKindSig a
x (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_SIG LHsType a
ty) (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_SIG LHsType a
kind)
  go Precedence
p (HsIParamTy XIParamTy a
x Located HsIPName
n LHsType a
ty)
    = Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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 -> Located HsIPName -> LHsType a -> HsType a
forall pass.
XIParamTy pass -> Located HsIPName -> LHsType pass -> HsType pass
HsIParamTy XIParamTy a
x Located HsIPName
n (LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType LHsType a
ty)
  go Precedence
p (HsForAllTy XForAllTy a
x ForallVisFlag
fvf [LHsTyVarBndr a]
tvs LHsType a
ty)
    = Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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
-> ForallVisFlag -> [LHsTyVarBndr a] -> LHsType a -> HsType a
forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy XForAllTy a
x ForallVisFlag
fvf ((LHsTyVarBndr a -> LHsTyVarBndr a)
-> [LHsTyVarBndr a] -> [LHsTyVarBndr a]
forall a b. (a -> b) -> [a] -> [b]
map ((HsTyVarBndr a -> HsTyVarBndr a)
-> LHsTyVarBndr a -> LHsTyVarBndr a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr a -> HsTyVarBndr a
forall a. (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a
reparenTyVar) [LHsTyVarBndr a]
tvs) (LHsType a -> LHsType a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType LHsType a
ty)
  go Precedence
p (HsQualTy XQualTy a
x LHsContext a
ctxt LHsType a
ty)
    = let p' :: [a] -> Precedence
p' [a
_] = Precedence
PREC_CTX
          p' [a]
_   = Precedence
PREC_TOP -- parens will get added anyways later...
      in Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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 -> LHsType a -> HsType a
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy XQualTy a
x (([LHsType a] -> [LHsType a]) -> LHsContext a -> LHsContext a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[LHsType a]
xs -> (LHsType a -> LHsType a) -> [LHsType a] -> [LHsType a]
forall a b. (a -> b) -> [a] -> [b]
map (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL ([LHsType a] -> Precedence
forall a. [a] -> Precedence
p' [LHsType a]
xs)) [LHsType a]
xs) LHsContext a
ctxt) (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_TOP LHsType a
ty)
  go Precedence
p (HsFunTy XFunTy a
x LHsType a
ty1 LHsType a
ty2)
    = Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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 -> LHsType a -> LHsType a -> HsType a
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy a
x (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_FUN LHsType a
ty1) (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_TOP LHsType a
ty2)
  go Precedence
p (HsAppTy XAppTy a
x LHsType a
fun_ty LHsType a
arg_ty)
    = Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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 -> LHsType a -> LHsType a -> HsType a
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy a
x (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_FUN LHsType a
fun_ty) (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_CON LHsType a
arg_ty)
  go Precedence
p (HsAppKindTy XAppKindTy a
x LHsType a
fun_ty LHsType a
arg_ki)
    = Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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 -> LHsType a -> LHsType a -> HsType a
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy XAppKindTy a
x (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_FUN LHsType a
fun_ty) (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_CON LHsType a
arg_ki)
  go Precedence
p (HsOpTy XOpTy a
x LHsType a
ty1 Located (IdP a)
op LHsType a
ty2)
    = Precedence -> Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
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 -> LHsType a -> Located (IdP a) -> LHsType a -> HsType a
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy XOpTy a
x (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_OP LHsType a
ty1) Located (IdP a)
op (Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
PREC_OP LHsType a
ty2)
  go Precedence
p (HsParTy XParTy a
_ LHsType a
t) = LHsType a -> SrcSpanLess (LHsType a)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsType a -> SrcSpanLess (LHsType a))
-> LHsType a -> SrcSpanLess (LHsType a)
forall a b. (a -> b) -> a -> b
$ Precedence -> LHsType a -> LHsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> LHsType a -> LHsType a
goL Precedence
p LHsType 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 :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a
  goL :: Precedence -> LHsType a -> LHsType a
goL Precedence
ctxt_prec = (HsType a -> HsType a) -> LHsType a -> LHsType a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Precedence -> HsType a -> HsType a
forall a.
(XParTy a ~ NoExtField) =>
Precedence -> HsType a -> HsType a
go Precedence
ctxt_prec)

  -- Optionally wrap a type in parens
  paren :: (XParTy a ~ NoExtField)
        => 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 -> LHsType a -> HsType a
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExtField
XParTy a
noExtField (LHsType a -> HsType a)
-> (HsType a -> LHsType a) -> HsType a -> HsType a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType a -> LHsType a
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc
                          | Bool
otherwise            = HsType a -> HsType a
forall a. a -> a
id


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

-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType :: LHsType a -> LHsType a
reparenLType = (HsType a -> HsType a) -> LHsType a -> LHsType a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsType a -> HsType a
forall a. (XParTy a ~ NoExtField) => HsType a -> HsType a
reparenType

-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a
reparenTyVar :: HsTyVarBndr a -> HsTyVarBndr a
reparenTyVar (UserTyVar XUserTyVar a
x Located (IdP a)
n) = XUserTyVar a -> Located (IdP a) -> HsTyVarBndr a
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar a
x Located (IdP a)
n
reparenTyVar (KindedTyVar XKindedTyVar a
x Located (IdP a)
n LHsKind a
kind) = XKindedTyVar a -> Located (IdP a) -> LHsKind a -> HsTyVarBndr a
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar a
x Located (IdP a)
n (LHsKind a -> LHsKind a
forall a. (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType LHsKind a
kind)
reparenTyVar v :: HsTyVarBndr a
v@XTyVarBndr{} = HsTyVarBndr a
v

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


-------------------------------------------------------------------------------
-- * NamedThing instances
-------------------------------------------------------------------------------


instance NamedThing (TyClDecl GhcRn) where
  getName :: TyClDecl GhcRn -> Name
getName = TyClDecl GhcRn -> Name
forall (p :: Pass). 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 -> HsConDeclDetails GhcRn
forall pass. ConDecl pass -> HsConDeclDetails pass
con_args ConDecl GhcRn
con of
      RecCon Located [LConDeclField GhcRn]
fields -> (LFieldOcc GhcRn -> Name) -> [LFieldOcc GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (FieldOcc GhcRn -> Name
forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (FieldOcc GhcRn -> Name)
-> (LFieldOcc GhcRn -> FieldOcc GhcRn) -> LFieldOcc GhcRn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LFieldOcc GhcRn -> FieldOcc GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) ([LFieldOcc GhcRn] -> [Name]) -> [LFieldOcc GhcRn] -> [Name]
forall a b. (a -> b) -> a -> b
$
                         (LConDeclField GhcRn -> [LFieldOcc GhcRn])
-> [LConDeclField GhcRn] -> [LFieldOcc GhcRn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConDeclField GhcRn -> [LFieldOcc GhcRn]
forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names (ConDeclField GhcRn -> [LFieldOcc GhcRn])
-> (LConDeclField GhcRn -> ConDeclField GhcRn)
-> LConDeclField GhcRn
-> [LFieldOcc GhcRn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDeclField GhcRn -> ConDeclField GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) (Located [LConDeclField GhcRn]
-> SrcSpanLess (Located [LConDeclField GhcRn])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [LConDeclField GhcRn]
fields)
      HsConDeclDetails GhcRn
_             -> []

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 = (Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located Name] -> [Name]) -> [Located Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (LConDecl GhcRn -> [Located Name])
-> [LConDecl GhcRn] -> [Located Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConDecl GhcRn -> [Located Name]
forall (p :: Pass).
ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))]
getConNames (ConDecl GhcRn -> [Located Name])
-> (LConDecl GhcRn -> ConDecl GhcRn)
-> LConDecl GhcRn
-> [Located Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDecl GhcRn -> ConDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
                              ([LConDecl GhcRn] -> [Located Name])
-> [LConDecl GhcRn] -> [Located Name]
forall a b. (a -> b) -> a -> b
$ (HsDataDefn GhcRn -> [LConDecl GhcRn]
forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons (HsDataDefn GhcRn -> [LConDecl GhcRn])
-> (TyClDecl GhcRn -> HsDataDefn GhcRn)
-> TyClDecl GhcRn
-> [LConDecl GhcRn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GhcRn -> HsDataDefn GhcRn
forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn) (TyClDecl GhcRn -> [LConDecl GhcRn])
-> TyClDecl GhcRn -> [LConDecl GhcRn]
forall a b. (a -> b) -> a -> b
$ TyClDecl GhcRn
d
    | TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl TyClDecl GhcRn
d =
        (LFamilyDecl GhcRn -> Name) -> [LFamilyDecl GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located Name -> Name)
-> (LFamilyDecl GhcRn -> Located Name) -> LFamilyDecl GhcRn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyDecl GhcRn -> Located Name
forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName (FamilyDecl GhcRn -> Located Name)
-> (LFamilyDecl GhcRn -> FamilyDecl GhcRn)
-> LFamilyDecl GhcRn
-> Located Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LFamilyDecl GhcRn -> FamilyDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) (TyClDecl GhcRn -> [LFamilyDecl GhcRn]
forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs TyClDecl GhcRn
d) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
        [ Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
n | L SrcSpan
_ (TypeSig XTypeSig GhcRn
_ [Located (IdP GhcRn)]
ns LHsSigWcType GhcRn
_) <- TyClDecl GhcRn -> [LSig GhcRn]
forall pass. TyClDecl pass -> [LSig pass]
tcdSigs TyClDecl GhcRn
d, Located Name
n <- [Located (IdP GhcRn)]
[Located Name]
ns ]
    | Bool
otherwise = []


-- | A parent and its children
family :: (NamedThing a, Parent a) => a -> (Name, [Name])
family :: a -> (Name, [Name])
family = a -> Name
forall a. NamedThing a => a -> Name
getName (a -> Name) -> (a -> [Name]) -> a -> (Name, [Name])
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 ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ConDecl GhcRn -> [Located (IdP GhcRn)]
forall (p :: Pass).
ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))]
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]
: (LConDecl GhcRn -> [(Name, [Name])])
-> [LConDecl GhcRn] -> [(Name, [Name])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConDecl GhcRn -> [(Name, [Name])]
familyConDecl (ConDecl GhcRn -> [(Name, [Name])])
-> (LConDecl GhcRn -> ConDecl GhcRn)
-> LConDecl GhcRn
-> [(Name, [Name])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDecl GhcRn -> ConDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) (HsDataDefn GhcRn -> [LConDecl GhcRn]
forall pass. HsDataDefn pass -> [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
  DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags (DynFlags -> DynFlags
f DynFlags
dflags)
  () -> Ghc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | A variant of 'gbracket' where the return value from the first computation
-- is not required.
gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
gbracket_ :: m a -> m b -> m c -> m c
gbracket_ m a
before_ m b
after m c
thing = m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket m a
before_ (m b -> a -> m b
forall a b. a -> b -> a
const m b
after) (m c -> a -> m c
forall a b. a -> b -> a
const m c
thing)

-- Extract the minimal complete definition of a Name, if one exists
minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
minimalDef :: Name -> m (Maybe ClassMinimalDef)
minimalDef Name
n = do
  Maybe TyThing
mty <- Name -> m (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName Name
n
  case Maybe TyThing
mty of
    Just (ATyCon (TyCon -> Maybe Class
tyConClass_maybe -> Just Class
c)) -> Maybe ClassMinimalDef -> m (Maybe ClassMinimalDef)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ClassMinimalDef -> m (Maybe ClassMinimalDef))
-> (ClassMinimalDef -> Maybe ClassMinimalDef)
-> ClassMinimalDef
-> m (Maybe ClassMinimalDef)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassMinimalDef -> Maybe ClassMinimalDef
forall a. a -> Maybe a
Just (ClassMinimalDef -> m (Maybe ClassMinimalDef))
-> ClassMinimalDef -> m (Maybe ClassMinimalDef)
forall a b. (a -> b) -> a -> b
$ Class -> ClassMinimalDef
classMinimalDef Class
c
    Maybe TyThing
_ -> Maybe ClassMinimalDef -> m (Maybe ClassMinimalDef)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ClassMinimalDef
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- * DynFlags
-------------------------------------------------------------------------------

-- TODO: use `setOutputDir` from GHC
setOutputDir :: FilePath -> DynFlags -> DynFlags
setOutputDir :: String -> DynFlags -> DynFlags
setOutputDir String
dir DynFlags
dynFlags =
  DynFlags
dynFlags { objectDir :: Maybe String
objectDir    = String -> Maybe String
forall a. a -> Maybe a
Just String
dir
           , hiDir :: Maybe String
hiDir        = String -> Maybe String
forall a. a -> Maybe a
Just String
dir
           , hieDir :: Maybe String
hieDir       = String -> Maybe String
forall a. a -> Maybe a
Just String
dir
           , stubDir :: Maybe String
stubDir      = String -> Maybe String
forall a. a -> Maybe a
Just String
dir
           , includePaths :: IncludeSpecs
includePaths = IncludeSpecs -> [String] -> IncludeSpecs
addGlobalInclude (DynFlags -> IncludeSpecs
includePaths DynFlags
dynFlags) [String
dir]
           , dumpDir :: Maybe String
dumpDir      = String -> Maybe String
forall a. a -> Maybe a
Just String
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 StringBuffer :: ForeignPtr Word8 -> Int -> Int -> StringBuffer
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'

-------------------------------------------------------------------------------
-- * 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])
-> (([TyVar], VarSet) -> [TyVar]) -> ([TyVar], VarSet) -> [TyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TyVar], VarSet) -> [TyVar]
forall a b. (a, b) -> a
fst (([TyVar], VarSet) -> [TyVar]) -> ([TyVar], VarSet) -> [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 Name
-- >>> import TyCoRep
-- >>> import TysPrim
-- >>> import 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 ([TyVar], VarSet)
c = (TyVar -> FV
FV.unitFV TyVar
v FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' (TyVar -> Type
tyVarKind TyVar
v)) TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c
tyCoFVsOfType' (TyConApp TyCon
_ [Type]
tys)   TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c = [Type] -> FV
tyCoFVsOfTypes' [Type]
tys TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c
tyCoFVsOfType' (LitTy {})         TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c = FV
emptyFV TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c
tyCoFVsOfType' (AppTy Type
fun Type
arg)    TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c = (Type -> FV
tyCoFVsOfType' Type
arg FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' Type
fun) TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c
tyCoFVsOfType' (FunTy AnonArgFlag
_ Type
arg Type
res)  TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c = (Type -> FV
tyCoFVsOfType' Type
res FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' Type
arg) TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c
tyCoFVsOfType' (ForAllTy TyCoVarBinder
bndr Type
ty) TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c = TyCoVarBinder -> FV -> FV
tyCoFVsBndr' TyCoVarBinder
bndr (Type -> FV
tyCoFVsOfType' Type
ty)  TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c
tyCoFVsOfType' (CastTy Type
ty KindCoercion
_)      TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c = (Type -> FV
tyCoFVsOfType' Type
ty) TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c
tyCoFVsOfType' (CoercionTy KindCoercion
_ )    TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
c = FV
emptyFV TyVar -> Bool
a VarSet
b ([TyVar], VarSet)
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 ([TyVar], VarSet)
acc = ([Type] -> FV
tyCoFVsOfTypes' [Type]
tys FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType' Type
ty) TyVar -> Bool
fv_cand VarSet
in_scope ([TyVar], VarSet)
acc
tyCoFVsOfTypes' []       TyVar -> Bool
fv_cand VarSet
in_scope ([TyVar], VarSet)
acc = FV
emptyFV TyVar -> Bool
fv_cand VarSet
in_scope ([TyVar], VarSet)
acc

-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of
-- appearance.
tyCoFVsBndr' :: TyVarBinder -> FV -> FV
tyCoFVsBndr' :: TyCoVarBinder -> FV -> FV
tyCoFVsBndr' (Bndr TyVar
tv ArgFlag
_) 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 IfaceType.hs 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 ArgFlag
flg) Type
ty)
      | TyVar -> Bool
isRuntimeRepVar TyVar
var
      , ArgFlag -> Bool
isInvisibleArgFlag ArgFlag
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
      = TyCoVarBinder -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> TyCoVarBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr ((Type -> Type) -> TyVar -> TyVar
updateTyVarKind (TyVarEnv () -> Type -> Type
go TyVarEnv ()
subs) TyVar
var) ArgFlag
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
      = TyCon -> [Type] -> Type
TyConApp TyCon
liftedRepDataConTyCon []
      | 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 AnonArgFlag
af Type
arg Type
res)
      = AnonArgFlag -> Type -> Type -> Type
FunTy AnonArgFlag
af (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