{-# LANGUAGE PatternGuards, OverloadedStrings, FlexibleContexts, PackageImports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Tools.Ghc.Worker (
	-- * Workers
	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

-- | Multi-session ghc worker
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)

-- | Create session with options
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

-- | Get ghc session
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

-- | Get ghci session
ghciSession :: GhcM ()
ghciSession :: MGhcT SessionConfig (First DynFlags) (LogT IO) ()
ghciSession = SessionType
-> PackageDbStack
-> FormatFlags
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
workerSession SessionType
SessionGhci PackageDbStack
userDb []

-- | Get haddock session with flags
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

-- | Get haddock session with flags
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