{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

module HsInspect.Workarounds where

#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
import qualified GHC.Driver.Config.Parser as GHC
import qualified GHC.Driver.Env.Types as GHC
import qualified GHC.Driver.Ppr as GHC
import qualified GHC.Types.Target as GHC
import qualified GHC.Unit.Env as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import qualified GHC.Types.Target as GHC
import qualified GHC.Driver.Config as GHC
import qualified GHC.Driver.Ppr as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Utils.Outputable as GHC
#endif

#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Driver.Pipeline as Pipeline
import qualified GHC.Driver.Session as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Parser.Header as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Parser as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Types.Name.Reader as GHC
import qualified GHC.Data.StringBuffer as GHC
#else
import qualified DriverPipeline as Pipeline
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified HeaderInfo as GHC
import qualified HscTypes as GHC
import qualified Lexer as GHC
import qualified Outputable as GHC
import qualified Parser as GHC
import qualified RdrName as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import qualified GHC.Hs.ImpExp as GHC
#else
import qualified HsImpExp as GHC
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Types.Name.Occurrence as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(8,8,2,0)
import qualified OccName as GHC
#else
import qualified TcRnTypes as GHC
#endif
import qualified GHC as GHC

#if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0)
import Data.Maybe (fromJust, fromMaybe)
#endif
import Control.Monad
import Control.Monad.IO.Class
import Data.List (delete, intercalate, isSuffixOf)
import Data.Set (Set)
import qualified Data.Set as Set
import System.Directory (getModificationTime, removeFile)

-- applies CPP rules to the input file and extracts the pragmas,
-- a more reliable alternative to GHC.hGetStringBuffer
mkCppState :: GHC.HscEnv -> FilePath -> IO (GHC.PState, [GHC.Located String])
mkCppState :: HscEnv -> [Char] -> IO (PState, [Located [Char]])
mkCppState HscEnv
sess [Char]
file = do
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
  Either ErrorMessages (DynFlags, [Char])
pp <- HscEnv
-> [Char]
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, [Char]))
Pipeline.preprocess HscEnv
sess [Char]
file forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  let (DynFlags
dflags, [Char]
tmp) = case Either ErrorMessages (DynFlags, [Char])
pp of
        Left ErrorMessages
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"preprocessing failed " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
file
        Right (DynFlags, [Char])
success -> (DynFlags, [Char])
success
#else
  (dflags, tmp) <- preprocess sess (file, Nothing)
#endif
  InputFileBuffer
full <- [Char] -> IO InputFileBuffer
GHC.hGetStringBuffer [Char]
tmp
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
".hscpp" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
tmp) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
removeFile forall a b. (a -> b) -> a -> b
$ [Char]
tmp
#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
  let (_, pragmas) = GHC.getOptions (GHC.initParserOpts dflags) full file
#else
  let pragmas :: [Located [Char]]
pragmas = DynFlags -> InputFileBuffer -> [Char] -> [Located [Char]]
GHC.getOptions DynFlags
dflags InputFileBuffer
full [Char]
file
#endif
      loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc ([Char] -> FastString
GHC.mkFastString [Char]
file) Int
1 Int
1
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
      mkPState' :: DynFlags -> InputFileBuffer -> RealSrcLoc -> PState
mkPState' = ParserOpts -> InputFileBuffer -> RealSrcLoc -> PState
GHC.initParserState forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> ParserOpts
GHC.initParserOpts
#else
      mkPState' = GHC.mkPState
#endif
  (DynFlags
dflags', [Located [Char]]
_, [Warn]
_) <- forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located [Char]] -> m (DynFlags, [Located [Char]], [Warn])
GHC.parseDynamicFilePragma DynFlags
dflags [Located [Char]]
pragmas
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (DynFlags -> InputFileBuffer -> RealSrcLoc -> PState
mkPState' DynFlags
dflags' InputFileBuffer
full RealSrcLoc
loc, [Located [Char]]
pragmas)

#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)
parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs)
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule)
#else
parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs)
#endif
parseHeader' :: forall (m :: * -> *).
GhcMonad m =>
[Char] -> m ([[Char]], HsModule)
parseHeader' [Char]
file = do
  HscEnv
sess <- forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  (PState
pstate, [Located [Char]]
pragmas) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> [Char] -> IO (PState, [Located [Char]])
mkCppState HscEnv
sess [Char]
file
  case forall a. P a -> PState -> ParseResult a
GHC.unP P (Located HsModule)
GHC.parseHeader PState
pstate of
    GHC.POk PState
_ (GHC.L SrcSpan
_ HsModule
hsmod) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. GenLocated l e -> e
GHC.unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located [Char]]
pragmas, HsModule
hsmod)
    ParseResult (Located HsModule)
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"parseHeader failed for " forall a. Semigroup a => a -> a -> a
<> [Char]
file

importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, GHC.Target)
importsOnly :: forall (m :: * -> *).
GhcMonad m =>
Set ModuleName -> [Char] -> m (Maybe ModuleName, Target)
importsOnly Set ModuleName
homes [Char]
file = do
  DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  ([[Char]]
pragmas, HsModule
hsmod) <- forall (m :: * -> *).
GhcMonad m =>
[Char] -> m ([[Char]], HsModule)
parseHeader' [Char]
file
  let allowed :: GHC.GenLocated l (GHC.ImportDecl GHC.GhcPs) -> Bool
      allowed :: forall l. GenLocated l (ImportDecl GhcPs) -> Bool
allowed (GHC.L l
_ (GHC.ImportDecl{XRec GhcPs ModuleName
ideclName :: forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName :: XRec GhcPs ModuleName
GHC.ideclName})) = forall a. Ord a => a -> Set a -> Bool
Set.notMember (forall l e. GenLocated l e -> e
GHC.unLoc XRec GhcPs ModuleName
ideclName) Set ModuleName
homes
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
      allowed (GHC.L _ (GHC.XImportDecl _)) = False
#endif
      modname :: Maybe ModuleName
modname = forall l e. GenLocated l e -> e
GHC.unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule -> Maybe (LocatedA ModuleName)
GHC.hsmodName HsModule
hsmod
      extra :: [Char]
extra =
        if Maybe ModuleName
modname forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
|| Maybe ModuleName
modname forall a. Eq a => a -> a -> Bool
== (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> ModuleName
GHC.mkModuleName [Char]
"Main")
        then [Char]
"\nmain = return ()"
        else [Char]
""
      imps :: [LImportDecl GhcPs]
imps = forall a. (a -> Bool) -> [a] -> [a]
filter forall l. GenLocated l (ImportDecl GhcPs) -> Bool
allowed forall a b. (a -> b) -> a -> b
$ HsModule -> [LImportDecl GhcPs]
GHC.hsmodImports HsModule
hsmod
      -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066
      --            cannot use CPP in combination with targetContents
      pragmas' :: [[Char]]
pragmas' = forall a. Eq a => a -> [a] -> [a]
delete [Char]
"-XCPP" [[Char]]
pragmas
      contents :: [Char]
contents =
        [Char]
"{-# OPTIONS_GHC " forall a. Semigroup a => a -> a -> a
<> (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " [[Char]]
pragmas') forall a. Semigroup a => a -> a -> a
<> [Char]
" #-}\n" forall a. Semigroup a => a -> a -> a
<>
        forall a. Outputable a => DynFlags -> a -> [Char]
GHC.showPpr DynFlags
dflags (HsModule
hsmod { hsmodExports :: Maybe (LocatedL [LIE GhcPs])
GHC.hsmodExports = forall a. Maybe a
Nothing
                               , hsmodImports :: [LImportDecl GhcPs]
GHC.hsmodImports = [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps }) forall a. Semigroup a => a -> a -> a
<>
        [Char]
extra
      trimmed :: InputFileBuffer
trimmed = [Char] -> InputFileBuffer
GHC.stringToStringBuffer [Char]
contents

  UTCTime
ts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO UTCTime
getModificationTime [Char]
file
  -- since 0f9ec9d1ff can't use Phase
#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
  sess <- GHC.getSession
  let unitid = GHC.ue_current_unit $ GHC.hsc_unit_env sess
  pure $ (modname, GHC.Target (GHC.TargetFile file Nothing) False unitid (Just (trimmed, ts)))
#else
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Maybe ModuleName
modname, TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target ([Char] -> Maybe Phase -> TargetId
GHC.TargetFile [Char]
file forall a. Maybe a
Nothing) Bool
False (forall a. a -> Maybe a
Just (InputFileBuffer
trimmed, UTCTime
ts)))
#endif

parseModuleName' :: GHC.GhcMonad m => FilePath -> m (Maybe GHC.ModuleName)
parseModuleName' :: forall (m :: * -> *). GhcMonad m => [Char] -> m (Maybe ModuleName)
parseModuleName' [Char]
file = do
  ([[Char]]
_, HsModule
hsmod) <- forall (m :: * -> *).
GhcMonad m =>
[Char] -> m ([[Char]], HsModule)
parseHeader' [Char]
file
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
GHC.unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule -> Maybe (LocatedA ModuleName)
GHC.hsmodName HsModule
hsmod

-- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541
minf_rdr_env' :: GHC.GhcMonad m => GHC.ModuleName -> m GHC.GlobalRdrEnv
minf_rdr_env' :: forall (m :: * -> *). GhcMonad m => ModuleName -> m GlobalRdrEnv
minf_rdr_env' ModuleName
m = do
#if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0)
  Module
mo <- forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
m forall a. Maybe a
Nothing
  (forall a. HasCallStack => Maybe a -> a
fromJust -> ModuleInfo
mi) <- forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
mo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. OccEnv a
GHC.emptyOccEnv forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe GlobalRdrEnv
GHC.modInfoRdrEnv ModuleInfo
mi
#else
  modSum <- GHC.getModSummary m
  pmod <- GHC.parseModule modSum
  tmod <- GHC.typecheckModule pmod
  let (tc_gbl_env, _) = GHC.tm_internals_ tmod
  pure $ tcg_rdr_env tc_gbl_env
#endif