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

module HsInspect.Runner (runGhcAndJamMasterShe, ghcflags_flags) where

#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
import qualified GHC.Driver.Env.Types as GHC
import qualified GHC.Unit.Env as GHC
#endif

#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Driver.Session as GHC
import qualified GHC.Data.EnumSet as GHC
#else
import qualified DynFlags as GHC
import qualified EnumSet as GHC
#endif
import qualified GHC as GHC

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except (ExceptT(..))
import Data.List (find, isPrefixOf)
import qualified Data.List as L
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import HsInspect.Context
import HsInspect.Util (homeSources)
import HsInspect.Workarounds (parseModuleName')
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Environment (setEnv)

-- expects the PWD to be the same as the .cabal file and the PATH to be what the
-- build tool sees.
runGhcAndJamMasterShe :: [String] -> Bool -> GHC.Ghc a -> IO a
runGhcAndJamMasterShe :: forall a. [String] -> Bool -> Ghc a -> IO a
runGhcAndJamMasterShe ([String] -> [String]
filterFlags -> [String]
flags) Bool
setTargets Ghc a
work =
  let libdir :: Maybe String
libdir = (forall a. Int -> [a] -> [a]
drop Int
2) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String
"-B" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
flags
      flags' :: [String]
flags' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-B" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) [String]
flags
   in forall a. Maybe String -> Ghc a -> IO a
GHC.runGhc Maybe String
libdir forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  (Int -> DynFlags -> DynFlags
GHC.updOptLevel Int
0 -> DynFlags
dflags', (forall l e. GenLocated l e -> e
GHC.unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) -> [String]
_ghcargs, [Warn]
_) <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlagsCmdLine DynFlags
dflags (forall e. e -> Located e
GHC.noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
flags')
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags'
         {
#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)
           GHC.backend = GHC.interpreterBackend
#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
           backend :: Backend
GHC.backend = Backend
GHC.Interpreter
#else
           GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why
#endif
         , ghcLink :: GhcLink
GHC.ghcLink   = GhcLink
GHC.LinkInMemory   -- required by HscInterpreted
         , ghcMode :: GhcMode
GHC.ghcMode   = GhcMode
GHC.MkDepend       -- prefer .hi to .hs for dependencies
         , warningFlags :: EnumSet WarningFlag
GHC.warningFlags = forall a. EnumSet a
GHC.empty
         , fatalWarningFlags :: EnumSet WarningFlag
GHC.fatalWarningFlags = forall a. EnumSet a
GHC.empty
         }

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
setTargets forall a b. (a -> b) -> a -> b
$ do
    -- The caller may have provided a list of home modules, but we do not trust
    -- them because the ghcflags plugin does not keep the flags up to date for
    -- incremental compiles.
#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
    sess <- GHC.getSession
    let unitid = GHC.ue_current_unit $ GHC.hsc_unit_env sess
        mkTarget m = GHC.Target (GHC.TargetModule m) True unitid Nothing
#else
    let mkTarget :: ModuleName -> Target
mkTarget ModuleName
m = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> TargetId
GHC.TargetModule ModuleName
m) Bool
True forall a. Maybe a
Nothing
#endif
    [ModuleName]
homeModules <- forall (m :: * -> *). GhcMonad m => m [ModuleName]
inferHomeModules
    forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets forall a b. (a -> b) -> a -> b
$ ModuleName -> Target
mkTarget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
homeModules

  Ghc a
work

-- gets the flags (and sets the environment) from the output of the ghcflags plugin
ghcflags_flags :: Maybe FilePath -> ExceptT String IO [String]
ghcflags_flags :: Maybe String -> ExceptT String IO [String]
ghcflags_flags Maybe String
mf = do
  String
from <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getCurrentDirectory forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
mf
  Context{String
package_dir :: Context -> String
package_dir :: String
package_dir, [Text]
ghcflags :: Context -> [Text]
ghcflags :: [Text]
ghcflags, Text
ghcpath :: Context -> Text
ghcpath :: Text
ghcpath} <- String -> ExceptT String IO Context
findContext String
from
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
setCurrentDirectory String
package_dir
    String -> String -> IO ()
setEnv String
"PATH" (Text -> String
T.unpack Text
ghcpath)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
ghcflags

inferHomeModules :: GHC.GhcMonad m => m [GHC.ModuleName]
inferHomeModules :: forall (m :: * -> *). GhcMonad m => m [ModuleName]
inferHomeModules = do
  [String]
files <- forall (m :: * -> *). GhcMonad m => m [String]
homeSources
  [Maybe ModuleName]
mmns <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). GhcMonad m => String -> m (Maybe ModuleName)
parseModuleName' [String]
files
  let main' :: ModuleName
main' = String -> ModuleName
GHC.mkModuleName String
"Main"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
L.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName
main' forall a. Eq a => a -> a -> Bool
/=) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleName]
mmns
  -- stack often has duplicates

-- removes the "+RTS ... -RTS" sections
filterFlags :: [String] -> [String]
filterFlags :: [String] -> [String]
filterFlags [String]
args = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String
"+RTS" forall a. Eq a => a -> a -> Bool
/=) [String]
args of
  ([String]
front, []) -> [String]
front
  ([String]
front, String
_ : [String]
middle) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String
"-RTS" forall a. Eq a => a -> a -> Bool
/=) [String]
middle of
    ([String]
_, []) -> [String]
front -- bad input?
    ([String]
_, String
_ : [String]
back) -> [String]
front forall a. Semigroup a => a -> a -> a
<> [String]
back