Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

74 lines (60 sloc) 2.126 kb
-- | The types used by the worker (which talks to the GHC API.)
module Scion.Types.Worker
( module Scion.Types.Worker
, module Scion.Types.Core
)
where
import Scion.Types.Core
import Scion.Types.Note ( Note )
import Control.Applicative
import Control.Monad ( when )
import Data.IORef
import System.IO
import Distribution.Simple.LocalBuildInfo
import GHC ( Ghc, GhcMonad(..) )
newtype Worker a
= Worker { unWorker :: IORef WorkerState -> Ghc a }
data WorkerState = WorkerState
{ workerLBI :: Maybe LocalBuildInfo
, workerLogHandle :: Maybe Handle
, workerLogLevel :: Verbosity
, workerNewNotes :: IORef [Note]
}
mkWorkerState :: IORef [Note] -> IO (IORef WorkerState)
mkWorkerState r = newIORef $ WorkerState
{ workerLBI = Nothing
, workerLogHandle = Nothing
, workerLogLevel = normal
, workerNewNotes = r}
instance Functor Worker where
fmap f (Worker g) = Worker $ \r -> fmap f (g r)
instance Applicative Worker where
pure x = Worker $ \_ -> return x
Worker af <*> Worker ax =
Worker $ \r -> do f <- af r; x <- ax r; return (f x)
instance Monad Worker where
return x = pure x
Worker f >>= k = Worker $ \r -> do
a <- f r
unWorker (k a) r
instance MonadIO Worker where
liftIO act = Worker $ \_ -> liftIO act
instance ExceptionMonad Worker where
gcatch (Worker act) handler =
Worker $ \r -> act r `gcatch` (\e -> unWorker (handler e) r)
gblock (Worker act) = Worker $ \r -> gblock (act r)
gunblock (Worker act) = Worker $ \r -> gunblock (act r)
instance GhcMonad Worker where
getSession = Worker (\_ -> getSession)
setSession s = Worker (\_ -> setSession s)
getAndClearNewNotes :: Worker [Note]
getAndClearNewNotes = Worker $ \r -> liftIO $ do
nn <- workerNewNotes <$> readIORef r
atomicModifyIORef nn $ \ns -> ([], ns)
instance LogMonad Worker where
setVerbosity v = Worker $ \r ->
io (atomicModifyIORef r (\ws -> (ws{ workerLogLevel = v }, ())))
getVerbosity = Worker $ \r -> workerLogLevel <$> io (readIORef r)
message verb msg = do
v <- getVerbosity
when (verb <= v) $ io $ hPutStrLn stderr msg >> hFlush stderr
Jump to Line
Something went wrong with that request. Please try again.