module Language.Haskell.GhcMod.Monad (
runGhcModT
, runGhcModT'
, runGhcModT''
, hoistGhcModT
, runGmlT
, runGmlT'
, runGmlTWith
, runGmPkgGhc
, withGhcModEnv
, withGhcModEnv'
, module Language.Haskell.GhcMod.Monad.Types
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Output
import Control.Arrow (first)
import Control.Applicative
import Control.Concurrent
import Control.Monad.Reader (runReaderT)
import Control.Monad.State.Strict (runStateT)
import Control.Monad.Trans.Journal (runJournalT)
import Exception (ExceptionMonad(..))
import System.Directory
import Prelude
withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
withCradle cradledir f =
gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f
withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f)
withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a
withGhcModEnv' opt f crdl = do
olddir <- liftIO getCurrentDirectory
c <- liftIO newChan
let outp = case linePrefix opt of
Just _ -> GmOutputChan c
Nothing -> GmOutputStdio
gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp)
where
setup c = liftIO $ do
setCurrentDirectory $ cradleRootDir crdl
forkIO $ stdoutGateway c
teardown olddir tid = liftIO $ do
setCurrentDirectory olddir
killThread tid
gbracket_ ma mb mc = gbracket ma mb (const mc)
runGhcModT :: IOish m
=> Options
-> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = do
dir <- liftIO getCurrentDirectory
runGhcModT' dir opt action
runGhcModT' :: IOish m
=> FilePath
-> Options
-> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
withGhcModEnv dir' opt $ \env ->
first (fst <$>) <$> runGhcModT'' env defaultGhcModState
(gmSetLogLevel (logLevel opt) >> action)
hoistGhcModT :: IOish m
=> (Either GhcModError a, GhcModLog)
-> GhcModT m a
hoistGhcModT (r,l) = do
gmlJournal l >> case r of
Left e -> throwError e
Right a -> return a
runGhcModT'' :: IOish m
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> m (Either GhcModError (a, GhcModState), GhcModLog)
runGhcModT'' r s a = do
flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s