{-# LANGUAGE CPP #-}

module Pollock.CompatGHC
  ( readIORef
  , TcGblEnv
    ( tcg_exports
    , tcg_insts
    , tcg_fam_insts
    , tcg_warns
    , tcg_th_docs
    , tcg_semantic_mod
    , tcg_rdr_env
    , tcg_doc_hdr
    , tcg_rn_imports
    , tcg_rn_decls
    , tcg_rn_exports
    )
  , getSrcSpan
  , nameIsLocalOrFrom
  , emptyOccEnv
  , lookupNameEnv
  , GlobalRdrEnv
  , Warnings
  , WarningTxt
  , declTypeDocs
  , extractTHDocs
  , getInstLoc
  , getMainDeclBinder
  , isValD
  , nubByName
  , subordinates
  , topDecls
  -- GHC
  , DynFlags (generalFlags)
  , GenLocated (L)
  , HsDocString
  , Name
  , renderHsDocString
  , GhcRn
  , IdP
  , LHsDecl
  , Module
  , HsDecl (InstD, DerivD, ValD, SigD, DocD)
  , feqn_tycon
  , InstDecl
    ( TyFamInstD
    )
  , TyFamInstDecl (TyFamInstDecl)
  , ModuleName
  , SrcSpanAnnA
  , collectHsBindBinders
  , getLocA
  , nameModule
  , ExtractedTHDocs (ExtractedTHDocs, ethd_mod_header)
  , HsDoc
  , WithHsDocIdentifiers (hsDocString)
  , IE (IEModuleContents, IEGroup, IEDoc, IEDocNamed)
  , ImportDecl
  , ideclName
  , ideclAs
  , ideclImportList
  , ImportListInterpretation (Exactly, EverythingBut)
  , CollectFlag (CollNoDictBinders)
  , SrcSpanAnn' (SrcSpanAnn)
  , RealSrcSpan
  , SrcSpan (RealSrcSpan)
  , DocDecl (DocCommentNamed, DocGroup)
  , Located
  , HscEnv (hsc_dflags)
  -- GHC.Plugins
  , GeneralFlag (Opt_Haddock)
  , lookupSrcSpan
  , getName
  , unLoc
  -- GHC.Types.Avail
  , AvailInfo
  , Avails
  , availExportsDecl
  , availName
  , availNames
  , availSubordinateNames
  , availsToNameEnv
  , nubAvails
  -- GHC.Types.SourceText
  , StringLiteral
  -- compatability shims defined here
  , processWarnSome
  , mapWarningTxtMsg
  -- helpers defined here
  , nonDetEltUniqMapToMap
  , insertEnumSet
  , stringLiteralToString
  ) where

import qualified Control.Arrow as Arrow
import qualified Control.Monad as M
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe

import GHC
  ( CollectFlag (CollNoDictBinders)
  , DocDecl (DocCommentNamed, DocGroup)
  , DynFlags (generalFlags)
  , ExtractedTHDocs (ExtractedTHDocs, ethd_mod_header)
  , FamEqn (feqn_tycon)
  , GenLocated (L)
  , GeneralFlag (Opt_Haddock)
  , GhcRn
  , HsDecl (DerivD, DocD, InstD, SigD, ValD)
  , HsDoc
  , HsDocString
  , HscEnv
  , IE (IEDoc, IEDocNamed, IEGroup, IEModuleContents)
  , IdP
  , InstDecl (TyFamInstD)
  , LHsDecl
  , Located
  , Module
  , ModuleName
  , Name
  , NamedThing (getName)
  , RealSrcSpan
  , SrcSpan (RealSrcSpan)
  , SrcSpanAnn' (SrcSpanAnn)
  , SrcSpanAnnA
  , TyFamInstDecl (TyFamInstDecl)
  , WithHsDocIdentifiers (hsDocString)
  , collectHsBindBinders
  , getLocA
  , nameModule
  , renderHsDocString
  , unLoc
  )
import GHC.Plugins
  ( GlobalRdrElt
  , GlobalRdrEnv
  , HscEnv (hsc_dflags)
  , OccEnv
  , OccName
  , emptyOccEnv
  , getSrcSpan
  , lookupNameEnv
  , lookupOccEnv
  , lookupSrcSpan
  , nameIsLocalOrFrom
  , unpackFS
  )

import qualified GHC.Data.EnumSet as EnumSet
import GHC.HsToCore.Docs
  ( declTypeDocs
  , extractTHDocs
  , getInstLoc
  , getMainDeclBinder
  , isValD
  , nubByName
  , subordinates
  , topDecls
  )
import GHC.IORef (readIORef)
import GHC.Tc.Types
  ( TcGblEnv
      ( tcg_doc_hdr
      , tcg_exports
      , tcg_fam_insts
      , tcg_insts
      , tcg_rdr_env
      , tcg_rn_decls
      , tcg_rn_exports
      , tcg_rn_imports
      , tcg_semantic_mod
      , tcg_th_docs
      , tcg_warns
      )
  )
import GHC.Types.SourceText (StringLiteral, sl_fs)
import qualified GHC.Types.Unique.Map as UniqMap
import GHC.Unit.Module.Warnings (WarningTxt (DeprecatedTxt, WarningTxt), Warnings (WarnSome))

#if __GLASGOW_HASKELL__ == 908
import GHC (ImportDecl, ideclImportList, ideclAs, ideclName, ImportListInterpretation (Exactly, EverythingBut))
import GHC.Plugins (GlobalRdrEltX, greName)
import GHC.Types.Avail
  ( AvailInfo
  , Avails
  , availExportsDecl
  , availName
  , availNames
  , availSubordinateNames
  , availsToNameEnv
  , nubAvails
  )
import GHC.Types.Unique.Map (nonDetUniqMapToList)

#elif __GLASGOW_HASKELL__ == 906
import GHC (ImportDecl, ideclImportList, ideclAs, ideclName,  ImportListInterpretation (Exactly, EverythingBut))
import GHC.Plugins (greMangledName)
import GHC.Types.Avail
  ( AvailInfo
  , Avails
  , availExportsDecl
  , availName
  , availNames
  , availSubordinateGreNames
  , availsToNameEnv
  , greNameMangledName
  , nubAvails
  )
import GHC.Types.Unique.Map (nonDetEltsUniqMap)

#elif __GLASGOW_HASKELL__ == 904
import GHC (ImportDecl(ideclHiding, ideclAs, ideclName),       XRec)
import GHC.Plugins (greMangledName)
import GHC.Types.Avail
  ( AvailInfo
  , Avails
  , availExportsDecl
  , availName
  , availNamesWithSelectors
  , availSubordinateGreNames
  , availsToNameEnv
  , greNameMangledName
  , nubAvails
  )
import GHC.Types.Unique.Map (nonDetEltsUniqMap)
#endif

#if __GLASGOW_HASKELL__ == 908
lookupOccName :: OccEnv [GlobalRdrEltX info] -> OccName -> [Name]
lookupOccName env = fmap greName . lookupOcc env

processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome warnings gre names =
  case warnings of
    WarnSome ws exports ->
      let
        keepByName :: [(Name,b)] -> [(Name,b)]
        keepByName = filter (\x -> (fst x) `elem` names)

        keepOnlyKnownNameWarnings = keepByName . mappend exports . M.join . fmap (explodeSnd . Arrow.first (lookupOccName gre))

        explodeSnd :: Functor f => (f a, b) -> f (a, b)
        explodeSnd (as,b) = fmap ((flip (,) b)) as
      in
        keepOnlyKnownNameWarnings ws
    _ ->
      -- Note we want to catch all here so we can limit imports that vary for different GHC versions.
      mempty

-- | Compatability helper to let us get at the deprecated and warning messages consistently
mapWarningTxtMsg ::
  ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
  -> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
  -> WarningTxt pass
  -> t
mapWarningTxtMsg deprecatedFn warnFn warnTxt =
  case warnTxt of
    DeprecatedTxt _ msgs -> deprecatedFn msgs
    WarningTxt _ _ msgs -> warnFn msgs

#elif __GLASGOW_HASKELL__ == 906
-- | Shim for using the GHC 9.8 api
availSubordinateNames :: AvailInfo -> [Name]
availSubordinateNames = fmap greNameMangledName . availSubordinateGreNames

lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName env = fmap greMangledName . lookupOcc env

processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome warnings gre names =
  case warnings of
    WarnSome ws ->
      let
        keepByName :: [(Name,b)] -> [(Name,b)]
        keepByName = filter (\x -> (fst x) `elem` names)

        keepOnlyKnownNameWarnings :: [(OccName, b)] -> [(Name, b)]
        keepOnlyKnownNameWarnings = keepByName . M.join . fmap (explodeSnd . Arrow.first (lookupOccName gre))

        explodeSnd :: Functor f => (f a, b) -> f (a, b)
        explodeSnd (as,b) = fmap ((flip (,) b)) as
      in
        keepOnlyKnownNameWarnings ws
    _ ->
      -- Note we want to catch all here so we can limit imports that vary for different GHC versions.
      mempty

-- | Shim for using the GHC 9.8 api, note the previous name was somewhat confusing as it does result
-- in a list not a map!
nonDetUniqMapToList :: UniqMap.UniqMap k a -> [(k, a)]
nonDetUniqMapToList = nonDetEltsUniqMap

-- | Compatability helper to let us get at the deprecated and warning messages consistently
mapWarningTxtMsg ::
  ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
  -> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
  -> WarningTxt pass
  -> t
mapWarningTxtMsg deprecatedFn warnFn warnTxt =
  case warnTxt of
    DeprecatedTxt _ msgs -> deprecatedFn msgs
    WarningTxt _ msgs -> warnFn msgs

#elif __GLASGOW_HASKELL__ == 904

-- | Compatibility shim as this datatype was added in GHC 9.6, along with 'ideclImportList'
data ImportListInterpretation = Exactly | EverythingBut

-- | Compatibility shim as GHC 9.4 used 'ideclHiding', but later changed to 'ideclImportList'.
ideclImportList :: ImportDecl pass -> Maybe (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
ideclImportList :: forall pass.
ImportDecl pass
-> Maybe
     (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
ideclImportList ImportDecl pass
idecl =
  case ImportDecl pass -> Maybe (Bool, XRec pass [XRec pass (IE pass)])
forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding ImportDecl pass
idecl of
    Maybe (Bool, XRec pass [XRec pass (IE pass)])
Nothing -> Maybe (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
forall a. Maybe a
Nothing
    Just (Bool
True, XRec pass [XRec pass (IE pass)]
n) -> (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
-> Maybe
     (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
forall a. a -> Maybe a
Just (ImportListInterpretation
EverythingBut,XRec pass [XRec pass (IE pass)]
n)
    Just (Bool
False,XRec pass [XRec pass (IE pass)]
n) -> (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
-> Maybe
     (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
forall a. a -> Maybe a
Just (ImportListInterpretation
Exactly,XRec pass [XRec pass (IE pass)]
n)

-- | availNames was changed to include the selectors, it would seem, so we create a shim for 9.4 to
-- have an api more like later versions
availNames :: AvailInfo -> [Name]
availNames :: AvailInfo -> [Name]
availNames = AvailInfo -> [Name]
availNamesWithSelectors

-- | Shim for using the GHC 9.8 api
availSubordinateNames :: AvailInfo -> [Name]
availSubordinateNames :: AvailInfo -> [Name]
availSubordinateNames = (GreName -> Name) -> [GreName] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GreName -> Name
greNameMangledName ([GreName] -> [Name])
-> (AvailInfo -> [GreName]) -> AvailInfo -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvailInfo -> [GreName]
availSubordinateGreNames

lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName OccEnv [GlobalRdrElt]
env = (GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrElt -> Name
greMangledName ([GlobalRdrElt] -> [Name])
-> (OccName -> [GlobalRdrElt]) -> OccName -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccEnv [GlobalRdrElt] -> OccName -> [GlobalRdrElt]
forall a. OccEnv [a] -> OccName -> [a]
lookupOcc OccEnv [GlobalRdrElt]
env

processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome :: forall pass.
Warnings pass
-> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome Warnings pass
warnings OccEnv [GlobalRdrElt]
gre [Name]
names =
  case Warnings pass
warnings of
    WarnSome [(OccName, WarningTxt pass)]
ws ->
      let
        keepByName :: [(Name,b)] -> [(Name,b)]
        keepByName :: forall b. [(Name, b)] -> [(Name, b)]
keepByName = ((Name, b) -> Bool) -> [(Name, b)] -> [(Name, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name, b)
x -> ((Name, b) -> Name
forall a b. (a, b) -> a
fst (Name, b)
x) Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names)

        keepOnlyKnownNameWarnings :: [(OccName, b)] -> [(Name, b)]
        keepOnlyKnownNameWarnings :: forall b. [(OccName, b)] -> [(Name, b)]
keepOnlyKnownNameWarnings = [(Name, b)] -> [(Name, b)]
forall b. [(Name, b)] -> [(Name, b)]
keepByName ([(Name, b)] -> [(Name, b)])
-> ([(OccName, b)] -> [(Name, b)]) -> [(OccName, b)] -> [(Name, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Name, b)]] -> [(Name, b)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
M.join ([[(Name, b)]] -> [(Name, b)])
-> ([(OccName, b)] -> [[(Name, b)]])
-> [(OccName, b)]
-> [(Name, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((OccName, b) -> [(Name, b)]) -> [(OccName, b)] -> [[(Name, b)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Name], b) -> [(Name, b)]
forall (f :: * -> *) a b. Functor f => (f a, b) -> f (a, b)
explodeSnd (([Name], b) -> [(Name, b)])
-> ((OccName, b) -> ([Name], b)) -> (OccName, b) -> [(Name, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> [Name]) -> (OccName, b) -> ([Name], b)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arrow.first (OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName OccEnv [GlobalRdrElt]
gre))

        explodeSnd :: Functor f => (f a, b) -> f (a, b)
        explodeSnd :: forall (f :: * -> *) a b. Functor f => (f a, b) -> f (a, b)
explodeSnd (f a
as,b
b) = (a -> (a, b)) -> f a -> f (a, b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a -> b -> (a, b)) -> b -> a -> (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
b)) f a
as
      in
        [(OccName, WarningTxt pass)] -> [(Name, WarningTxt pass)]
forall b. [(OccName, b)] -> [(Name, b)]
keepOnlyKnownNameWarnings [(OccName, WarningTxt pass)]
ws
    Warnings pass
_ ->
      -- Note we want to catch all here so we can limit imports that vary for different GHC versions.
      [(Name, WarningTxt pass)]
forall a. Monoid a => a
mempty

-- | Shim for using the GHC 9.8 api, note the previous name was somewhat confusing as it does result
-- in a list not a map!
nonDetUniqMapToList :: UniqMap.UniqMap k a -> [(k, a)]
nonDetUniqMapToList :: forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList = UniqMap k a -> [(k, a)]
forall k a. UniqMap k a -> [(k, a)]
nonDetEltsUniqMap

-- | Compatability helper to let us get at the deprecated and warning messages consistently
mapWarningTxtMsg ::
  ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
  -> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
  -> WarningTxt pass
  -> t
mapWarningTxtMsg :: forall pass t.
([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> WarningTxt pass
-> t
mapWarningTxtMsg [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
deprecatedFn [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
warnFn WarningTxt pass
warnTxt =
  case WarningTxt pass
warnTxt of
    DeprecatedTxt Located SourceText
_ [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs -> [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
deprecatedFn [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs
    WarningTxt Located SourceText
_ [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs -> [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
warnFn [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs

#endif

-- | Simple helper used above but definable consistently across GHC versions.
lookupOcc :: OccEnv [a] -> OccName -> [a]
lookupOcc :: forall a. OccEnv [a] -> OccName -> [a]
lookupOcc OccEnv [a]
env =
  [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
Maybe.fromMaybe [a]
forall a. Monoid a => a
mempty (Maybe [a] -> [a]) -> (OccName -> Maybe [a]) -> OccName -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccEnv [a] -> OccName -> Maybe [a]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv [a]
env

-- | Helper to convert from UniqMap to Map in a consistent fashion.
nonDetEltUniqMapToMap :: (Ord k) => UniqMap.UniqMap k a -> Map.Map k a
nonDetEltUniqMapToMap :: forall k a. Ord k => UniqMap k a -> Map k a
nonDetEltUniqMapToMap = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, a)] -> Map k a)
-> (UniqMap k a -> [(k, a)]) -> UniqMap k a -> Map k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqMap k a -> [(k, a)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList

-- | A Helper to keep the interface clean avoiding any potential conflicts with 'insert'.
insertEnumSet :: (Enum a) => a -> EnumSet.EnumSet a -> EnumSet.EnumSet a
insertEnumSet :: forall a. Enum a => a -> EnumSet a -> EnumSet a
insertEnumSet = a -> EnumSet a -> EnumSet a
forall a. Enum a => a -> EnumSet a -> EnumSet a
EnumSet.insert

stringLiteralToString :: StringLiteral -> String
stringLiteralToString :: StringLiteral -> String
stringLiteralToString = FastString -> String
unpackFS (FastString -> String)
-> (StringLiteral -> FastString) -> StringLiteral -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringLiteral -> FastString
sl_fs