{-# LANGUAGE CPP #-}

-- | Thin shim around the GHC API
--
-- For the typechecker part we have the excellent @ghc-tcplugin-api@ library;
-- unfortunately, we have no such library for source plugins. We could reuse a
-- small part of @ghc-tcplugin-api@ here, but there isn't too much point: source
-- plugins need quite a different subset of the GHC API than typechecker plugins
-- do.
module Data.Record.Anon.Internal.Plugin.Source.GhcShim (
    -- * Extensions
    HasDefaultExt(..)

#if __GLASGOW_HASKELL__ < 902
    -- * Exact-print annotations
  , reLoc, reLocA
#endif

    -- * Names
  , lookupName

    -- * NameCache
  , NameCacheIO
  , hscNameCacheIO
  , takeUniqFromNameCacheIO

    -- * Miscellaneous
  , importDecl
  , issueWarning
  , mkLabel
#if __GLASGOW_HASKELL__ < 900
  , mkHsApps
#endif

    -- * Re-exports
#if __GLASGOW_HASKELL__ < 900
  , module BasicTypes
  , module FastString
  , module GHC
  , module HscMain
  , module HscTypes
  , module Name
  , module OccName
  , module Outputable
  , module RdrName
  , module UniqSupply
#else
  , module GHC
  , module GHC.Data.FastString
  , module GHC.Driver.Main
  , module GHC.Types.Name
  , module GHC.Types.Name.Occurrence
  , module GHC.Types.Name.Reader
  , module GHC.Types.Unique.Supply
  , module GHC.Utils.Outputable

#if __GLASGOW_HASKELL__ < 902
  , module GHC.Driver.Types
#else
  , module GHC.Driver.Errors
  , module GHC.Driver.Env.Types
  , module GHC.Types.SourceText
#endif
#endif
  ) where

import GHC.Stack

#if __GLASGOW_HASKELL__ < 900

import Data.IORef
import Data.List (foldl')

import GHC hiding (lookupName)

import Bag (Bag, listToBag)
import BasicTypes (Origin(Generated), PromotionFlag(NotPromoted), SourceText(NoSourceText))
import DynFlags (getDynFlags)
import ErrUtils (mkWarnMsg)
import FastString (FastString)
import Finder (findImportedModule)
import HscMain (getHscEnv)
import HscTypes
import IfaceEnv (lookupOrigIO)
import MonadUtils
import Name (mkInternalName)
import NameCache (NameCache(nsUniqs))
import OccName
import Outputable
import RdrName (RdrName(Exact), rdrNameOcc, mkRdrQual, mkRdrUnqual)
import UniqSupply (takeUniqFromSupply)
import Unique (Unique)

#else

import GHC hiding (lookupName)

import GHC.Data.Bag (listToBag, Bag)
import GHC.Data.FastString (FastString)
import GHC.Driver.Main (getHscEnv)
import GHC.Driver.Session (getDynFlags)
import GHC.Types.Name (mkInternalName)
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader (RdrName(Exact), rdrNameOcc, mkRdrQual, mkRdrUnqual)
import GHC.Types.SrcLoc (LayoutInfo(NoLayoutInfo))
import GHC.Types.Unique (Unique)
import GHC.Types.Unique.Supply (takeUniqFromSupply)
import GHC.Utils.Monad
import GHC.Utils.Outputable

#if __GLASGOW_HASKELL__ >= 902
import GHC.Driver.Env.Types
import GHC.Driver.Errors
import GHC.Types.SourceText (SourceText(NoSourceText))
import GHC.Unit.Finder (findImportedModule, FindResult(Found))
import GHC.Unit.Types (IsBootInterface(NotBoot))
#else
import GHC.Driver.Finder (findImportedModule)
import GHC.Driver.Types
import GHC.Types.Basic (SourceText(NoSourceText))
#endif

#if __GLASGOW_HASKELL__ < 904
import Data.IORef

import GHC.Iface.Env (lookupOrigIO)
import GHC.Types.Name.Cache (NameCache(nsUniqs))
import GHC.Utils.Error (mkWarnMsg)
#else
import GHC.Driver.Config.Diagnostic (initDiagOpts)
import GHC.Driver.Errors.Types (GhcMessage(..))
import GHC.Iface.Env (lookupNameCache)
import GHC.Rename.Names (renamePkgQual)
import GHC.Types.Error (MsgEnvelope(..), mkMessages)
import GHC.Types.Name.Cache (NameCache, takeUniqFromNameCache)
import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual))
import GHC.Utils.Error (mkPlainError)
#endif

#endif

{-------------------------------------------------------------------------------
  Names
-------------------------------------------------------------------------------}

lookupName ::
     HasCallStack
  => ModuleName
  -> Maybe FastString -- ^ Optional package name
  -> String -> Hsc Name
lookupName :: HasCallStack =>
ModuleName -> Maybe FastString -> String -> Hsc Name
lookupName ModuleName
modl Maybe FastString
pkg = HasCallStack =>
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modl Maybe FastString
pkg forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkVarOcc

lookupOccName ::
     HasCallStack
  => ModuleName
  -> Maybe FastString -- ^ Optional package name
  -> OccName -> Hsc Name
lookupOccName :: HasCallStack =>
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modlName Maybe FastString
mPkgName OccName
name = do
    HscEnv
env <- Hsc HscEnv
getHscEnv

#if __GLASGOW_HASKELL__ >= 904
    let pkgq :: PkgQual
        pkgq = renamePkgQual (hsc_unit_env env) modlName mPkgName
#else
    let pkgq :: Maybe FastString
        pkgq :: Maybe FastString
pkgq = Maybe FastString
mPkgName
#endif

    FindResult
mModl <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
env ModuleName
modlName Maybe FastString
pkgq
    case FindResult
mModl of
      Found ModLocation
_ Module
modl -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> OccName -> IO Name
lookupOrigIO HscEnv
env Module
modl OccName
name
      FindResult
_otherwise   -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"lookupName: name not found"

#if __GLASGOW_HASKELL__ >= 904
lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
lookupOrigIO env modl occ = lookupNameCache (hsc_NC env) modl occ
#endif

{-------------------------------------------------------------------------------
  NameCache
-------------------------------------------------------------------------------}

#if __GLASGOW_HASKELL__ < 904
type NameCacheIO = IORef NameCache

takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique
takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique
takeUniqFromNameCacheIO = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef NameCache -> (NameCache, Unique)
aux
  where
    aux :: NameCache -> (NameCache, Unique)
    aux :: NameCache -> (NameCache, Unique)
aux NameCache
nc = let (Unique
newUniq, UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
             in (NameCache
nc { nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us }, Unique
newUniq)
#else
type NameCacheIO = NameCache

takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique
takeUniqFromNameCacheIO = takeUniqFromNameCache
#endif

hscNameCacheIO :: HscEnv -> NameCacheIO
hscNameCacheIO :: HscEnv -> NameCacheIO
hscNameCacheIO = HscEnv -> NameCacheIO
hsc_NC

{-------------------------------------------------------------------------------
  Miscellaneous
-------------------------------------------------------------------------------}

-- | Optionally @qualified@ import declaration
importDecl :: Bool -> ModuleName -> LImportDecl GhcPs
importDecl :: Bool -> ModuleName -> LImportDecl GhcPs
importDecl Bool
qualified ModuleName
name = forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ ImportDecl {
      ideclExt :: XCImportDecl GhcPs
ideclExt       = forall a. HasDefaultExt a => a
defExt
    , ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText
    , ideclName :: XRec GhcPs ModuleName
ideclName      = forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall e. e -> Located e
noLoc ModuleName
name
#if __GLASGOW_HASKELL__ >= 904
    , ideclPkgQual   = NoRawPkgQual
#else
    , ideclPkgQual :: Maybe StringLiteral
ideclPkgQual   = forall a. Maybe a
Nothing
#endif
    , ideclSafe :: Bool
ideclSafe      = Bool
False
    , ideclImplicit :: Bool
ideclImplicit  = Bool
False
    , ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclAs        = forall a. Maybe a
Nothing
    , ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding    = forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ < 810
    , ideclQualified = qualified
#else
    , ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = if Bool
qualified then ImportDeclQualifiedStyle
QualifiedPre else ImportDeclQualifiedStyle
NotQualified
#endif
#if __GLASGOW_HASKELL__ < 900
    , ideclSource    = False
#else
    , ideclSource :: IsBootInterface
ideclSource    = IsBootInterface
NotBoot
#endif
    }

issueWarning :: SrcSpan -> SDoc -> Hsc ()
issueWarning :: SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l SDoc
errMsg = do
    DynFlags
dynFlags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
#if __GLASGOW_HASKELL__ == 902
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> IO ()
printOrThrowWarnings Logger
logger DynFlags
dynFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Bag a
bag forall a b. (a -> b) -> a -> b
$
      SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkWarnMsg SrcSpan
l PrintUnqualified
neverQualify SDoc
errMsg
#elif __GLASGOW_HASKELL__ >= 904
    logger <- getLogger
    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $
      MsgEnvelope {
          errMsgSpan       = l
        , errMsgContext    = neverQualify
        , errMsgDiagnostic = GhcUnknownMessage $ mkPlainError [] errMsg
        , errMsgSeverity   = SevWarning
        }
#else
    liftIO $ printOrThrowWarnings dynFlags . bag $
      mkWarnMsg dynFlags l neverQualify errMsg
#endif
  where
    bag :: a -> Bag a
    bag :: forall a. a -> Bag a
bag = forall a. [a] -> Bag a
listToBag forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])

#if __GLASGOW_HASKELL__ < 900
mkHsApps ::
     LHsExpr (GhcPass id)
  -> [LHsExpr (GhcPass id)]
  -> LHsExpr (GhcPass id)
mkHsApps = foldl' mkHsApp
#endif

{-------------------------------------------------------------------------------
  Extensions
-------------------------------------------------------------------------------}

class HasDefaultExt a where
  defExt :: a

#if __GLASGOW_HASKELL__ < 810
instance HasDefaultExt NoExt where
  defExt = noExt
#else
instance HasDefaultExt NoExtField where
  defExt :: NoExtField
defExt = NoExtField
noExtField
#endif

#if __GLASGOW_HASKELL__ >= 900
instance HasDefaultExt LayoutInfo where
  defExt :: LayoutInfo
defExt = LayoutInfo
NoLayoutInfo
#endif

#if __GLASGOW_HASKELL__ >= 902
instance HasDefaultExt (EpAnn ann) where
  defExt :: EpAnn ann
defExt = forall ann. EpAnn ann
noAnn
#endif

{-------------------------------------------------------------------------------
  Exact-print annotations
-------------------------------------------------------------------------------}

#if __GLASGOW_HASKELL__ < 902
reLoc :: Located a -> Located a
reLoc = id

reLocA :: Located a -> Located a
reLocA = id
#endif

{-------------------------------------------------------------------------------
  mkLabel
-------------------------------------------------------------------------------}

mkLabel :: SrcSpan -> FastString -> LHsExpr GhcPs
mkLabel :: SrcSpan -> FastString -> LHsExpr GhcPs
mkLabel SrcSpan
l FastString
n = forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
l
            forall a b. (a -> b) -> a -> b
$ forall p. XOverLabel p -> FastString -> HsExpr p
HsOverLabel forall a. HasDefaultExt a => a
defExt
#if __GLASGOW_HASKELL__ < 902
                 Nothing
#endif
                 FastString
n