{-# LANGUAGE PatternGuards, OverloadedStrings, FlexibleContexts, PackageImports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HsDev.Tools.Ghc.Worker (
SessionType(..), SessionConfig(..),
GhcM, GhcWorker, MGhcT(..), runGhcM,
ghcWorker,
workerSession, ghcSession, ghciSession, haddockSession, tmpSession,
Ghc,
LogT(..),
module HsDev.Tools.Ghc.Base,
module HsDev.Tools.Ghc.Repl,
module HsDev.Tools.Ghc.MGhc,
module Control.Concurrent.Worker
) where
import Control.Lens (view)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Catch
import Data.Monoid
import qualified System.Log.Simple as Log
import System.Log.Simple.Monad (MonadLog(..), LogT(..), withLog)
import Text.Format hiding (withFlags)
import "ghc" Exception (ExceptionMonad(..), ghandle)
import "ghc" GHC hiding (Warning, Module)
import "ghc" Linker (initDynLinker)
import GHC.Paths
import Control.Concurrent.Worker
import HsDev.PackageDb.Types
import HsDev.Tools.Ghc.Base
import HsDev.Tools.Ghc.Repl
import HsDev.Tools.Ghc.MGhc
data SessionType = SessionGhci | SessionGhc | SessionHaddock | SessionTmp deriving (SessionType -> SessionType -> Bool
(SessionType -> SessionType -> Bool)
-> (SessionType -> SessionType -> Bool) -> Eq SessionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionType -> SessionType -> Bool
$c/= :: SessionType -> SessionType -> Bool
== :: SessionType -> SessionType -> Bool
$c== :: SessionType -> SessionType -> Bool
Eq, Eq SessionType
Eq SessionType
-> (SessionType -> SessionType -> Ordering)
-> (SessionType -> SessionType -> Bool)
-> (SessionType -> SessionType -> Bool)
-> (SessionType -> SessionType -> Bool)
-> (SessionType -> SessionType -> Bool)
-> (SessionType -> SessionType -> SessionType)
-> (SessionType -> SessionType -> SessionType)
-> Ord SessionType
SessionType -> SessionType -> Bool
SessionType -> SessionType -> Ordering
SessionType -> SessionType -> SessionType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SessionType -> SessionType -> SessionType
$cmin :: SessionType -> SessionType -> SessionType
max :: SessionType -> SessionType -> SessionType
$cmax :: SessionType -> SessionType -> SessionType
>= :: SessionType -> SessionType -> Bool
$c>= :: SessionType -> SessionType -> Bool
> :: SessionType -> SessionType -> Bool
$c> :: SessionType -> SessionType -> Bool
<= :: SessionType -> SessionType -> Bool
$c<= :: SessionType -> SessionType -> Bool
< :: SessionType -> SessionType -> Bool
$c< :: SessionType -> SessionType -> Bool
compare :: SessionType -> SessionType -> Ordering
$ccompare :: SessionType -> SessionType -> Ordering
$cp1Ord :: Eq SessionType
Ord)
data SessionConfig = SessionConfig SessionType PackageDbStack deriving (SessionConfig -> SessionConfig -> Bool
(SessionConfig -> SessionConfig -> Bool)
-> (SessionConfig -> SessionConfig -> Bool) -> Eq SessionConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionConfig -> SessionConfig -> Bool
$c/= :: SessionConfig -> SessionConfig -> Bool
== :: SessionConfig -> SessionConfig -> Bool
$c== :: SessionConfig -> SessionConfig -> Bool
Eq, Eq SessionConfig
Eq SessionConfig
-> (SessionConfig -> SessionConfig -> Ordering)
-> (SessionConfig -> SessionConfig -> Bool)
-> (SessionConfig -> SessionConfig -> Bool)
-> (SessionConfig -> SessionConfig -> Bool)
-> (SessionConfig -> SessionConfig -> Bool)
-> (SessionConfig -> SessionConfig -> SessionConfig)
-> (SessionConfig -> SessionConfig -> SessionConfig)
-> Ord SessionConfig
SessionConfig -> SessionConfig -> Bool
SessionConfig -> SessionConfig -> Ordering
SessionConfig -> SessionConfig -> SessionConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SessionConfig -> SessionConfig -> SessionConfig
$cmin :: SessionConfig -> SessionConfig -> SessionConfig
max :: SessionConfig -> SessionConfig -> SessionConfig
$cmax :: SessionConfig -> SessionConfig -> SessionConfig
>= :: SessionConfig -> SessionConfig -> Bool
$c>= :: SessionConfig -> SessionConfig -> Bool
> :: SessionConfig -> SessionConfig -> Bool
$c> :: SessionConfig -> SessionConfig -> Bool
<= :: SessionConfig -> SessionConfig -> Bool
$c<= :: SessionConfig -> SessionConfig -> Bool
< :: SessionConfig -> SessionConfig -> Bool
$c< :: SessionConfig -> SessionConfig -> Bool
compare :: SessionConfig -> SessionConfig -> Ordering
$ccompare :: SessionConfig -> SessionConfig -> Ordering
$cp1Ord :: Eq SessionConfig
Ord)
instance Show SessionType where
show :: SessionType -> String
show SessionType
SessionGhci = String
"ghci"
show SessionType
SessionGhc = String
"ghc"
show SessionType
SessionHaddock = String
"haddock"
show SessionType
SessionTmp = String
"tmp"
instance Formattable SessionType
instance Show SessionConfig where
show :: SessionConfig -> String
show (SessionConfig SessionType
t PackageDbStack
pdb) = Format
"{} {}" Format -> SessionType -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ SessionType
t Format -> PackageDbStack -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ PackageDbStack
pdb
instance Formattable SessionConfig
type GhcM a = MGhcT SessionConfig (First DynFlags) (LogT IO) a
type GhcWorker = Worker (MGhcT SessionConfig (First DynFlags) (LogT IO))
instance (Monad m, GhcMonad m) => GhcMonad (ReaderT r m) where
getSession :: ReaderT r m HscEnv
getSession = m HscEnv -> ReaderT r m HscEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
setSession :: HscEnv -> ReaderT r m ()
setSession = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ())
-> (HscEnv -> m ()) -> HscEnv -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession
instance ExceptionMonad m => ExceptionMonad (LogT m) where
gcatch :: LogT m a -> (e -> LogT m a) -> LogT m a
gcatch LogT m a
act e -> LogT m a
onError = ReaderT Log m a -> LogT m a
forall (m :: * -> *) a. ReaderT Log m a -> LogT m a
LogT (ReaderT Log m a -> LogT m a) -> ReaderT Log m a -> LogT m a
forall a b. (a -> b) -> a -> b
$ ReaderT Log m a -> (e -> ReaderT Log m a) -> ReaderT Log m a
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
gcatch (LogT m a -> ReaderT Log m a
forall (m :: * -> *) a. LogT m a -> ReaderT Log m a
runLogT LogT m a
act) (LogT m a -> ReaderT Log m a
forall (m :: * -> *) a. LogT m a -> ReaderT Log m a
runLogT (LogT m a -> ReaderT Log m a)
-> (e -> LogT m a) -> e -> ReaderT Log m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> LogT m a
onError)
gmask :: ((LogT m a -> LogT m a) -> LogT m b) -> LogT m b
gmask (LogT m a -> LogT m a) -> LogT m b
f = ReaderT Log m b -> LogT m b
forall (m :: * -> *) a. ReaderT Log m a -> LogT m a
LogT (ReaderT Log m b -> LogT m b) -> ReaderT Log m b -> LogT m b
forall a b. (a -> b) -> a -> b
$ ((ReaderT Log m a -> ReaderT Log m a) -> ReaderT Log m b)
-> ReaderT Log m b
forall (m :: * -> *) a b.
ExceptionMonad m =>
((m a -> m a) -> m b) -> m b
gmask (ReaderT Log m a -> ReaderT Log m a) -> ReaderT Log m b
f' where
f' :: (ReaderT Log m a -> ReaderT Log m a) -> ReaderT Log m b
f' ReaderT Log m a -> ReaderT Log m a
g' = LogT m b -> ReaderT Log m b
forall (m :: * -> *) a. LogT m a -> ReaderT Log m a
runLogT (LogT m b -> ReaderT Log m b) -> LogT m b -> ReaderT Log m b
forall a b. (a -> b) -> a -> b
$ (LogT m a -> LogT m a) -> LogT m b
f (ReaderT Log m a -> LogT m a
forall (m :: * -> *) a. ReaderT Log m a -> LogT m a
LogT (ReaderT Log m a -> LogT m a)
-> (LogT m a -> ReaderT Log m a) -> LogT m a -> LogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Log m a -> ReaderT Log m a
g' (ReaderT Log m a -> ReaderT Log m a)
-> (LogT m a -> ReaderT Log m a) -> LogT m a -> ReaderT Log m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> ReaderT Log m a
forall (m :: * -> *) a. LogT m a -> ReaderT Log m a
runLogT)
instance MonadThrow Ghc where
throwM :: e -> Ghc a
throwM = IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Ghc a) -> (e -> IO a) -> e -> Ghc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a
runGhcM :: Maybe String -> GhcM a -> m a
runGhcM Maybe String
dir GhcM a
act = do
Log
l <- m Log
forall (m :: * -> *). MonadLog m => m Log
Log.askLog
IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Log -> LogT IO a -> IO a
forall (m :: * -> *) a. Log -> LogT m a -> m a
withLog Log
l (LogT IO a -> IO a) -> LogT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Maybe String -> GhcM a -> LogT IO a
forall (m :: * -> *) s d a.
(MonadIO m, ExceptionMonad m, Ord s, Monoid d) =>
Maybe String -> MGhcT s d m a -> m a
runMGhcT Maybe String
dir GhcM a
act
ghcWorker :: MonadLog m => m GhcWorker
ghcWorker :: m GhcWorker
ghcWorker = do
Log
l <- m Log
forall (m :: * -> *). MonadLog m => m Log
Log.askLog
IO GhcWorker -> m GhcWorker
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GhcWorker -> m GhcWorker) -> IO GhcWorker -> m GhcWorker
forall a b. (a -> b) -> a -> b
$ (MGhcT SessionConfig (First DynFlags) (LogT IO) () -> IO ())
-> (MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> (MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> IO GhcWorker
forall (m :: * -> *).
MonadIO m =>
(m () -> IO ())
-> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m)
startWorker (Log -> LogT IO () -> IO ()
forall (m :: * -> *) a. Log -> LogT m a -> m a
withLog Log
l (LogT IO () -> IO ())
-> (MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> LogT IO ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String
-> MGhcT SessionConfig (First DynFlags) (LogT IO) () -> LogT IO ()
forall (m :: * -> *) a. MonadLog m => Maybe String -> GhcM a -> m a
runGhcM (String -> Maybe String
forall a. a -> Maybe a
Just String
libdir)) (Text
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"ghc") ((SomeException
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle SomeException -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => SomeException -> m ()
logErr)
where
logErr :: MonadLog m => SomeException -> m ()
logErr :: SomeException -> m ()
logErr SomeException
e = Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning (Format
"exception in ghc worker task: {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
workerSession :: SessionType -> PackageDbStack -> [String] -> GhcM ()
workerSession :: SessionType
-> PackageDbStack
-> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
workerSession SessionType
ty PackageDbStack
pdbs FormatFlags
opts = do
[Session SessionConfig (First DynFlags)]
ms <- (SessionConfig -> Bool)
-> MGhcT
SessionConfig
(First DynFlags)
(LogT IO)
[Session SessionConfig (First DynFlags)]
forall (m :: * -> *) s d.
MonadIO m =>
(s -> Bool) -> MGhcT s d m [Session s d]
findSessionBy SessionConfig -> Bool
toKill
[Session SessionConfig (First DynFlags)]
-> (Session SessionConfig (First DynFlags)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Session SessionConfig (First DynFlags)]
ms ((Session SessionConfig (First DynFlags)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> (Session SessionConfig (First DynFlags)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ \Session SessionConfig (First DynFlags)
s' -> do
Level -> Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ Format
"killing session: {}" Format -> SessionConfig -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Getting
SessionConfig
(Session SessionConfig (First DynFlags))
SessionConfig
-> Session SessionConfig (First DynFlags) -> SessionConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
SessionConfig
(Session SessionConfig (First DynFlags))
SessionConfig
forall s d. Lens' (Session s d) s
sessionKey Session SessionConfig (First DynFlags)
s'
SessionConfig -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) s d.
(MonadIO m, ExceptionMonad m, Ord s, Monoid d) =>
s -> MGhcT s d m ()
deleteSession (SessionConfig
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> SessionConfig
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ Getting
SessionConfig
(Session SessionConfig (First DynFlags))
SessionConfig
-> Session SessionConfig (First DynFlags) -> SessionConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
SessionConfig
(Session SessionConfig (First DynFlags))
SessionConfig
forall s d. Lens' (Session s d) s
sessionKey Session SessionConfig (First DynFlags)
s'
Level -> Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ Format
"session: {}" Format -> SessionConfig -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ SessionType -> PackageDbStack -> SessionConfig
SessionConfig SessionType
ty PackageDbStack
pdbs
SessionConfig
-> Maybe (MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) s d.
(MonadIO m, ExceptionMonad m, Ord s, Monoid d) =>
s -> Maybe (MGhcT s d m ()) -> MGhcT s d m ()
switchSession_ (SessionType -> PackageDbStack -> SessionConfig
SessionConfig SessionType
ty PackageDbStack
pdbs) (Maybe (MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> Maybe (MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> Maybe (MGhcT SessionConfig (First DynFlags) (LogT IO) ())
forall a. a -> Maybe a
Just MGhcT SessionConfig (First DynFlags) (LogT IO) ()
initialize
MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall s. MGhcT s (First DynFlags) (LogT IO) ()
setSessionFlags
Level -> Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"session set"
where
toKill :: SessionConfig -> Bool
toKill (SessionConfig SessionType
ty' PackageDbStack
pdbs') = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [
(SessionType
ty SessionType -> SessionType -> Bool
forall a. Eq a => a -> a -> Bool
== SessionType
ty' Bool -> Bool -> Bool
&& PackageDbStack
pdbs PackageDbStack -> PackageDbStack -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageDbStack
pdbs'),
(SessionType
ty SessionType -> SessionType -> Bool
forall a. Eq a => a -> a -> Bool
/= SessionType
ty' Bool -> Bool -> Bool
&& SessionType
ty' SessionType -> [SessionType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SessionType
SessionTmp, SessionType
SessionHaddock] Bool -> Bool -> Bool
&& SessionType
ty SessionType -> SessionType -> Bool
forall a. Eq a => a -> a -> Bool
/= SessionType
SessionTmp)]
initialize :: MGhcT SessionConfig (First DynFlags) (LogT IO) ()
initialize = do
MGhcT SessionConfig (First DynFlags) (LogT IO) ()
run
DynFlags
dflags <- MGhcT SessionConfig (First DynFlags) (LogT IO) DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
First DynFlags -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) d s. MonadIO m => d -> MGhcT s d m ()
setSessionData (Maybe DynFlags -> First DynFlags
forall a. Maybe a -> First a
First (Maybe DynFlags -> First DynFlags)
-> Maybe DynFlags -> First DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just DynFlags
dflags)
run :: MGhcT SessionConfig (First DynFlags) (LogT IO) ()
run = case SessionType
ty of
SessionType
SessionGhci -> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a. GhcMonad m => FormatFlags -> m a -> m a
ghcRun FormatFlags
pdbsOpts (FormatFlags -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). GhcMonad m => FormatFlags -> m ()
importModules FormatFlags
preludeModules)
SessionType
SessionGhc -> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a. GhcMonad m => FormatFlags -> m a -> m a
ghcRun FormatFlags
pdbsOpts (MGhcT SessionConfig (First DynFlags) (LogT IO) HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession MGhcT SessionConfig (First DynFlags) (LogT IO) HscEnv
-> (HscEnv -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> (HscEnv -> IO ())
-> HscEnv
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> IO ()
initDynLinker)
SessionType
SessionTmp -> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a. GhcMonad m => FormatFlags -> m a -> m a
ghcRun FormatFlags
pdbsOpts (MGhcT SessionConfig (First DynFlags) (LogT IO) HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession MGhcT SessionConfig (First DynFlags) (LogT IO) HscEnv
-> (HscEnv -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> (HscEnv -> IO ())
-> HscEnv
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> IO ()
initDynLinker)
SessionType
SessionHaddock -> (DynFlags -> DynFlags)
-> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a.
GhcMonad m =>
(DynFlags -> DynFlags) -> FormatFlags -> m a -> m a
ghcRunWith DynFlags -> DynFlags
noLinkFlags (String
"-haddock" String -> FormatFlags -> FormatFlags
forall a. a -> [a] -> [a]
: FormatFlags
pdbsOpts) (() -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
setSessionFlags :: MGhcT s (First DynFlags) (LogT IO) ()
setSessionFlags = do
Level -> Text -> MGhcT s (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> MGhcT s (First DynFlags) (LogT IO) ())
-> Text -> MGhcT s (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ Format
"setting flags: {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ FormatFlags -> String
unwords FormatFlags
opts
Maybe DynFlags
mdflags <- (Maybe (First DynFlags) -> Maybe DynFlags)
-> MGhcT s (First DynFlags) (LogT IO) (Maybe (First DynFlags))
-> MGhcT s (First DynFlags) (LogT IO) (Maybe DynFlags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (Maybe DynFlags) -> Maybe DynFlags
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe DynFlags) -> Maybe DynFlags)
-> (Maybe (First DynFlags) -> Maybe (Maybe DynFlags))
-> Maybe (First DynFlags)
-> Maybe DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (First DynFlags -> Maybe DynFlags)
-> Maybe (First DynFlags) -> Maybe (Maybe DynFlags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap First DynFlags -> Maybe DynFlags
forall a. First a -> Maybe a
getFirst) MGhcT s (First DynFlags) (LogT IO) (Maybe (First DynFlags))
forall (m :: * -> *) s d. MonadIO m => MGhcT s d m (Maybe d)
getSessionData
DynFlags
dflags <- MGhcT s (First DynFlags) (LogT IO) DynFlags
-> (DynFlags -> MGhcT s (First DynFlags) (LogT IO) DynFlags)
-> Maybe DynFlags
-> MGhcT s (First DynFlags) (LogT IO) DynFlags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MGhcT s (First DynFlags) (LogT IO) DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags DynFlags -> MGhcT s (First DynFlags) (LogT IO) DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynFlags
mdflags
(DynFlags
df', [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String]
-> MGhcT
s (First DynFlags) (LogT IO) (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags DynFlags
dflags ((String -> Located String) -> FormatFlags -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc FormatFlags
opts)
MGhcT s (First DynFlags) (LogT IO) [InstalledUnitId]
-> MGhcT s (First DynFlags) (LogT IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MGhcT s (First DynFlags) (LogT IO) [InstalledUnitId]
-> MGhcT s (First DynFlags) (LogT IO) ())
-> MGhcT s (First DynFlags) (LogT IO) [InstalledUnitId]
-> MGhcT s (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MGhcT s (First DynFlags) (LogT IO) [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
df'
pdbsOpts :: FormatFlags
pdbsOpts = PackageDbStack -> FormatFlags
packageDbStackOpts PackageDbStack
pdbs
ghcSession :: PackageDbStack -> [String] -> GhcM ()
ghcSession :: PackageDbStack
-> FormatFlags -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
ghcSession = SessionType
-> PackageDbStack
-> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
workerSession SessionType
SessionGhc
ghciSession :: GhcM ()
ghciSession :: MGhcT SessionConfig (First DynFlags) (LogT IO) ()
ghciSession = SessionType
-> PackageDbStack
-> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
workerSession SessionType
SessionGhci PackageDbStack
userDb []
haddockSession :: PackageDbStack -> [String] -> GhcM ()
haddockSession :: PackageDbStack
-> FormatFlags -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
haddockSession = SessionType
-> PackageDbStack
-> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
workerSession SessionType
SessionHaddock
tmpSession :: PackageDbStack -> [String] -> GhcM ()
tmpSession :: PackageDbStack
-> FormatFlags -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
tmpSession = SessionType
-> PackageDbStack
-> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
workerSession SessionType
SessionTmp