{-# LANGUAGE CPP #-}
{-# LANGUAGE DisambiguateRecordFields #-}

-- | 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.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))
#else
import GHC.Driver.Finder (findImportedModule)
import GHC.Driver.Types
import GHC.Types.Basic (SourceText(NoSourceText))
#endif

#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 906
import GHC.Unit.Types (IsBootInterface(NotBoot))
#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.Name.Cache (NameCache, takeUniqFromNameCache)
import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual))
import GHC.Utils.Error (mkPlainError)
import qualified GHC.Types.Error as Err
#endif

#endif

#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 906
import GHC.Types.SrcLoc (LayoutInfo(NoLayoutInfo))
#endif

#if __GLASGOW_HASKELL__ >= 906
import GHC.Driver.Config.Diagnostic (initPrintConfig)
#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
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modl Maybe FastString
pkg (OccName -> Hsc Name) -> (String -> OccName) -> String -> Hsc Name
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 :: PkgQual
pkgq = UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
renamePkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env) ModuleName
modlName Maybe FastString
mPkgName
#else
    let pkgq :: Maybe FastString
        pkgq = mPkgName
#endif

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

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

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

#if __GLASGOW_HASKELL__ < 904
type NameCacheIO = IORef NameCache

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

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

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

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

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

issueWarning :: SrcSpan -> SDoc -> Hsc ()
issueWarning :: SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l SDoc
errMsg = do
    DynFlags
dynFlags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
#if __GLASGOW_HASKELL__ == 902
    logger <- getLogger
    liftIO $ printOrThrowWarnings logger dynFlags . bag $
      mkWarnMsg l neverQualify errMsg
#elif __GLASGOW_HASKELL__ >= 904
    Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger

#if __GLASGOW_HASKELL__ < 906
    let printOrThrow :: Err.Messages GhcMessage -> IO ()
        printOrThrow = printOrThrowDiagnostics
                         logger
                         (initDiagOpts dynFlags)

    let msg :: Err.DiagnosticMessage
        msg = mkPlainError [] errMsg
#else
    let printOrThrow :: Err.Messages GhcMessage -> IO ()
        printOrThrow :: Messages GhcMessage -> IO ()
printOrThrow = Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics
                         Logger
logger
                         (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dynFlags)
                         (DynFlags -> DiagOpts
initDiagOpts DynFlags
dynFlags)

    let msg :: Err.UnknownDiagnostic
        msg :: UnknownDiagnostic
msg = DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
Err.UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$
                [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [] SDoc
errMsg
#endif
    IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> IO ()
printOrThrow (Messages GhcMessage -> IO ())
-> (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
Err.mkMessages (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage)
-> (MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> MsgEnvelope GhcMessage
-> Messages GhcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall a. a -> Bag a
bag (MsgEnvelope GhcMessage -> IO ())
-> MsgEnvelope GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$
      Err.MsgEnvelope {
          errMsgSpan :: SrcSpan
errMsgSpan       = SrcSpan
l
        , errMsgContext :: NamePprCtx
errMsgContext    = NamePprCtx
neverQualify
        , errMsgDiagnostic :: GhcMessage
errMsgDiagnostic = UnknownDiagnostic -> GhcMessage
GhcUnknownMessage UnknownDiagnostic
msg
        , errMsgSeverity :: Severity
errMsgSeverity   = Severity
SevWarning
        }
#else
    liftIO $ printOrThrowWarnings dynFlags . bag $
      mkWarnMsg dynFlags l neverQualify errMsg
#endif
  where
    bag :: a -> Bag a
    bag :: forall a. a -> Bag a
bag = [a] -> Bag a
forall a. [a] -> Bag a
listToBag ([a] -> Bag a) -> (a -> [a]) -> a -> Bag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
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

instance HasDefaultExt NoExtField where
  defExt :: NoExtField
defExt = NoExtField
noExtField

#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 906
instance HasDefaultExt LayoutInfo where
  defExt = NoLayoutInfo
#endif

#if __GLASGOW_HASKELL__ >= 902
instance HasDefaultExt (EpAnn ann) where
  defExt :: EpAnn ann
defExt = EpAnn ann
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 = Located (HsExpr GhcPs) -> LocatedAn AnnListItem (HsExpr GhcPs)
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (HsExpr GhcPs) -> LocatedAn AnnListItem (HsExpr GhcPs))
-> Located (HsExpr GhcPs) -> LocatedAn AnnListItem (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> Located (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l
            (HsExpr GhcPs -> Located (HsExpr GhcPs))
-> HsExpr GhcPs -> Located (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLabel GhcPs -> SourceText -> FastString -> HsExpr GhcPs
forall p. XOverLabel p -> SourceText -> FastString -> HsExpr p
HsOverLabel XOverLabel GhcPs
EpAnnCO
forall a. HasDefaultExt a => a
defExt
#if __GLASGOW_HASKELL__ < 902
                 Nothing -- RebindableSyntax
#elif __GLASGOW_HASKELL__ >= 906
                 SourceText
NoSourceText
#endif

                 FastString
n