{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
module HsInspect.Runner (runGhcAndJamMasterShe, ghcflags_flags) where
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 DynFlags (parseDynamicFlagsCmdLine, updOptLevel)
import qualified EnumSet as EnumSet
import GHC (Ghc, GhcMonad, getSessionDynFlags)
import qualified GHC as GHC
import HsInspect.Context
import HsInspect.Util (homeSources)
import HsInspect.Workarounds (parseModuleName')
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Environment (setEnv)
runGhcAndJamMasterShe :: [String] -> Bool -> Ghc a -> IO a
runGhcAndJamMasterShe :: [String] -> Bool -> Ghc a -> IO a
runGhcAndJamMasterShe ([String] -> [String]
filterFlags -> [String]
flags) Bool
setTargets Ghc a
work =
let libdir :: Maybe String
libdir = (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String
"-B" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
flags
flags' :: [String]
flags' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-B" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) [String]
flags
in Maybe String -> Ghc a -> IO a
forall a. Maybe String -> Ghc a -> IO a
GHC.runGhc Maybe String
libdir (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
(Int -> DynFlags -> DynFlags
updOptLevel Int
0 -> DynFlags
dflags', (Located String -> String
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc (Located String -> String) -> [Located String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) -> [String]
_ghcargs, [Warn]
_) <-
IO (DynFlags, [Located String], [Warn])
-> Ghc (DynFlags, [Located String], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located String], [Warn])
-> Ghc (DynFlags, [Located String], [Warn]))
-> IO (DynFlags, [Located String], [Warn])
-> Ghc (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsCmdLine DynFlags
dflags (String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc (String -> Located String) -> [String] -> [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
flags')
Ghc [InstalledUnitId] -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc [InstalledUnitId] -> Ghc ())
-> Ghc [InstalledUnitId] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags'
{ hscTarget :: HscTarget
GHC.hscTarget = HscTarget
GHC.HscInterpreted
, ghcLink :: GhcLink
GHC.ghcLink = GhcLink
GHC.LinkInMemory
, ghcMode :: GhcMode
GHC.ghcMode = GhcMode
GHC.MkDepend
, warningFlags :: EnumSet WarningFlag
GHC.warningFlags = EnumSet WarningFlag
forall a. EnumSet a
EnumSet.empty
, fatalWarningFlags :: EnumSet WarningFlag
GHC.fatalWarningFlags = EnumSet WarningFlag
forall a. EnumSet a
EnumSet.empty
}
Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
setTargets (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
let mkTarget :: ModuleName -> Target
mkTarget ModuleName
m = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> TargetId
GHC.TargetModule ModuleName
m) Bool
True Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing
[ModuleName]
homeModules <- Ghc [ModuleName]
forall (m :: * -> *). GhcMonad m => m [ModuleName]
inferHomeModules
[Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets ([Target] -> Ghc ()) -> [Target] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> Target
mkTarget (ModuleName -> Target) -> [ModuleName] -> [Target]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
homeModules
Ghc a
work
ghcflags_flags :: Maybe FilePath -> ExceptT String IO [String]
ghcflags_flags :: Maybe String -> ExceptT String IO [String]
ghcflags_flags Maybe String
mf = do
String
from <- IO String -> ExceptT String IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getCurrentDirectory String -> IO String
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
IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
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)
[String] -> ExceptT String IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> ExceptT String IO [String])
-> [String] -> ExceptT String IO [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
ghcflags
inferHomeModules :: GHC.GhcMonad m => m [GHC.ModuleName]
inferHomeModules :: m [ModuleName]
inferHomeModules = do
[String]
files <- m [String]
forall (m :: * -> *). GhcMonad m => m [String]
homeSources
[Maybe ModuleName]
mmns <- (String -> m (Maybe ModuleName))
-> [String] -> m [Maybe ModuleName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> m (Maybe ModuleName)
forall (m :: * -> *). GhcMonad m => String -> m (Maybe ModuleName)
parseModuleName' [String]
files
let main' :: ModuleName
main' = String -> ModuleName
GHC.mkModuleName String
"Main"
[ModuleName] -> m [ModuleName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleName] -> m [ModuleName])
-> ([ModuleName] -> [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
L.nub ([ModuleName] -> [ModuleName])
-> ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName
main' ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([ModuleName] -> m [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall a b. (a -> b) -> a -> b
$ [Maybe ModuleName] -> [ModuleName]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleName]
mmns
filterFlags :: [String] -> [String]
filterFlags :: [String] -> [String]
filterFlags [String]
args = case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String
"+RTS" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=) [String]
args of
([String]
front, []) -> [String]
front
([String]
front, String
_ : [String]
middle) -> case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String
"-RTS" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=) [String]
middle of
([String]
_, []) -> [String]
front
([String]
_, String
_ : [String]
back) -> [String]
front [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
back