Rework GhcModT monad stack

This commit is contained in:
Daniel Gröber 2014-07-22 19:45:48 +02:00
parent f95f7f89ce
commit f311efd90c
7 changed files with 96 additions and 85 deletions

View File

@ -31,20 +31,18 @@ module Language.Haskell.GhcMod.Internal (
, newGhcModEnv , newGhcModEnv
, GhcModState , GhcModState
, defaultState , defaultState
, Mode(..) , CompilerMode(..)
, GhcModWriter , GhcModLog
-- * Monad utilities -- * Monad utilities
, runGhcMod
, runGhcModT' , runGhcModT'
, withErrorHandler , withErrorHandler
-- ** Conversion -- ** Conversion
, liftGhcMod
, toGhcModT , toGhcModT
-- ** Accessing 'GhcModEnv' and 'GhcModState' -- ** Accessing 'GhcModEnv' and 'GhcModState'
, options , options
, cradle , cradle
, getMode , getCompilerMode
, setMode , setCompilerMode
, withOptions , withOptions
-- * 'Ghc' Choice -- * 'Ghc' Choice
, (||>) , (||>)

View File

@ -6,34 +6,32 @@
module Language.Haskell.GhcMod.Monad ( module Language.Haskell.GhcMod.Monad (
-- * Monad Types -- * Monad Types
GhcMod GhcModT
, GhcModT
, IOish , IOish
-- ** Environment, state and logging -- ** Environment, state and logging
, GhcModEnv(..) , GhcModEnv(..)
, newGhcModEnv , newGhcModEnv
, GhcModState , GhcModState(..)
, defaultState , defaultState
, Mode(..) , CompilerMode(..)
, GhcModWriter , GhcModLog
-- * Monad utilities -- * Monad utilities
, runGhcMod
, runGhcModT , runGhcModT
, runGhcModT' , runGhcModT'
, withErrorHandler , withErrorHandler
-- ** Conversion -- ** Conversion
, liftGhcMod
, toGhcModT , toGhcModT
-- ** Accessing 'GhcModEnv' and 'GhcModState' -- ** Accessing 'GhcModEnv' and 'GhcModState'
, options , options
, cradle , cradle
, getMode , getCompilerMode
, setMode , setCompilerMode
, withOptions , withOptions
-- ** Exporting convenient modules -- ** Exporting convenient modules
, module Control.Monad.Reader.Class , module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class , module Control.Monad.Writer.Class
, module Control.Monad.State.Class , module Control.Monad.State.Class
, module Control.Monad.Journal.Class
) where ) where
#if __GLASGOW_HASKELL__ < 708 #if __GLASGOW_HASKELL__ < 708
@ -77,20 +75,25 @@ import Data.Monoid (Monoid)
#endif #endif
import Control.Applicative (Alternative) import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, liftM, void) import Control.Arrow (first)
import Control.Monad (MonadPlus, void, liftM)
import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Reader.Class -- Monad transformer stuff
import Control.Monad.State.Class
import Control.Monad.Trans.Class
#if __GLASGOW_HASKELL__ < 708
import Control.Monad.Trans.Maybe
#endif
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_) control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
import Control.Monad.Trans.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class import Control.Monad.Writer.Class
import Control.Monad.Error (Error(..), ErrorT(..), MonadError) import Control.Monad.State.Class
import Control.Monad.Error (Error(..), MonadError, ErrorT, runErrorT)
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State.Strict (StateT, runStateT)
import Control.Monad.Trans.Journal (JournalT, runJournalT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Journal.Class
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.IORef (IORef, readIORef, writeIORef, newIORef)
@ -106,15 +109,17 @@ data GhcModEnv = GhcModEnv {
, gmCradle :: Cradle , gmCradle :: Cradle
} }
data GhcModState = GhcModState Mode deriving (Eq,Show,Read) type GhcModLog = ()
data Mode = Simple | Intelligent deriving (Eq,Show,Read) data GhcModState = GhcModState {
gmCompilerMode :: CompilerMode
} deriving (Eq,Show,Read)
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
defaultState :: GhcModState defaultState :: GhcModState
defaultState = GhcModState Simple defaultState = GhcModState Simple
type GhcModWriter = ()
data GhcModError = GMENoMsg data GhcModError = GMENoMsg
| GMEString String | GMEString String
| GMECabal | GMECabal
@ -132,20 +137,22 @@ instance Error GhcModError where
-- --
-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and -- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and
-- exception handling. Usually this will simply be 'IO' but we parametrise it in -- exception handling. Usually this will simply be 'IO' but we parametrise it in
-- the exported API so users have the option to use a custom underlying monad. -- the exported API so users have the option to use a custom inner monad.
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m) type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m)
type GhcMod a = GhcModT (ErrorT GhcModError IO) a -- | The GhcMod monad transformer data type. This is basically a newtype wrapper
-- around 'StateT', 'ErrorT', 'JournalT' and 'ReaderT' with custom instances for
-- | The GhcMod monad transformer data type. This is basically a wrapper around -- 'GhcMonad' and it's constraints.
-- RWST with custom instances for 'GhcMonad' and it's constraints.
-- --
-- The inner monad should have instances for 'MonadIO' and 'MonadBaseControl' -- The inner monad should have instances for 'MonadIO' and 'MonadBaseControl'
-- 'IO'. Most @mtl@ monads already have 'MonadBaseControl' 'IO' instances, see -- 'IO'. Most @mtl@ monads already have 'MonadBaseControl' 'IO' instances, see
-- the @monad-control@ package. -- the @monad-control@ package.
newtype GhcModT m a = GhcModT { newtype GhcModT m a = GhcModT {
unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a unGhcModT :: StateT GhcModState
} deriving (Functor (ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) a
} deriving ( Functor
, Applicative , Applicative
, Alternative , Alternative
, Monad , Monad
@ -155,23 +162,29 @@ newtype GhcModT m a = GhcModT {
, Control.Monad.IO.Class.MonadIO , Control.Monad.IO.Class.MonadIO
#endif #endif
, MonadReader GhcModEnv , MonadReader GhcModEnv
, MonadWriter GhcModWriter , MonadWriter w
, MonadState GhcModState , MonadState GhcModState
, MonadTrans , MonadError GhcModError
) )
deriving instance MonadError GhcModError m => MonadError GhcModError (GhcModT m) instance MonadTrans GhcModT where
lift = GhcModT . lift . lift . lift . lift
#if MONADIO_INSTANCES #if MONADIO_INSTANCES
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where instance MonadIO m => MonadIO (StateT s m) where
liftIO = lift . liftIO
instance MonadIO m => MonadIO (ReaderT r m) where
liftIO = lift . liftIO
instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
liftIO = lift . liftIO liftIO = lift . liftIO
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO liftIO = lift . liftIO
instance (MonadIO m) => MonadIO (MaybeT m) where instance MonadIO m => MonadIO (MaybeT m) where
liftIO = lift . liftIO liftIO = lift . liftIO
#endif #endif
---------------------------------------------------------------- ----------------------------------------------------------------
@ -231,18 +244,18 @@ newGhcModEnv opt dir = do
, gmCradle = c , gmCradle = c
} }
-- | Run a @GhcModT m@ computation, i.e. one with a custom underlying monad. -- | Run a @GhcModT m@ computation.
-- runGhcModT :: IOish m
-- You probably don't want this, look at 'runGhcMod' instead. => Options
runGhcModT :: IOish m => Options -> GhcModT m a -> m a -> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = do runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcModT' env defaultState $ do first (fmap fst) <$> (runGhcModT' env defaultState $ do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do defaultCleanupHandler dflags $ do
initializeFlagsWithCradle opt (gmCradle env) initializeFlagsWithCradle opt (gmCradle env)
action action)
return a
-- | Run a computation inside @GhcModT@ providing the RWST environment and -- | Run a computation inside @GhcModT@ providing the RWST environment and
-- initial state. This is a low level function, use it only if you know what to -- initial state. This is a low level function, use it only if you know what to
@ -253,28 +266,12 @@ runGhcModT' :: IOish m
=> GhcModEnv => GhcModEnv
-> GhcModState -> GhcModState
-> GhcModT m a -> GhcModT m a
-> m (a,(GhcModState, GhcModWriter)) -> m (Either GhcModError (a, GhcModState), GhcModLog)
runGhcModT' r s a = do runGhcModT' r s a = do
(a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s (res, w') <-
return (a',(s',w)) flip runReaderT r $ runJournalT $ runErrorT $ flip runStateT s
$ (unGhcModT $ initGhcMonad (Just libdir) >> a)
-- | Run a 'GhcMod' computation. If you want an underlying monad other than return $ (res, w')
-- 'ErrorT e IO' you should look at 'runGhcModT'
runGhcMod :: Options
-> GhcMod a
-> IO (Either GhcModError a)
runGhcMod o a =
runErrorT $ runGhcModT o a
liftErrorT :: IOish m => GhcModT m a -> GhcModT (ErrorT GhcModError m) a
liftErrorT action =
GhcModT $ RWST $ \e s -> ErrorT $ Right <$> (runRWST $ unGhcModT action) e s
-- | Lift @(GhcModT IO)@ into @GhcMod@, which is an alias for @GhcModT (ErrorT
-- GhcModError IO)@.
liftGhcMod :: GhcModT IO a -> GhcMod a
liftGhcMod = liftErrorT
---------------------------------------------------------------- ----------------------------------------------------------------
withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a
@ -300,13 +297,11 @@ options = gmOptions <$> ask
cradle :: IOish m => GhcModT m Cradle cradle :: IOish m => GhcModT m Cradle
cradle = gmCradle <$> ask cradle = gmCradle <$> ask
getMode :: IOish m => GhcModT m Mode getCompilerMode :: (Functor m, MonadState GhcModState m) => m CompilerMode
getMode = do getCompilerMode = gmCompilerMode <$> get
GhcModState mode <- get
return mode
setMode :: IOish m => Mode -> GhcModT m () setCompilerMode :: MonadState GhcModState m => CompilerMode -> m ()
setMode mode = put $ GhcModState mode setCompilerMode mode = (\s -> put s { gmCompilerMode = mode } ) =<< get
---------------------------------------------------------------- ----------------------------------------------------------------
@ -324,8 +319,10 @@ instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
newtype StM (GhcModT m) a = StGhcMod { newtype StM (GhcModT m) a = StGhcMod {
unStGhcMod :: StM (RWST GhcModEnv GhcModWriter GhcModState m) a } unStGhcMod :: StM (StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) ) a }
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcModT f $ liftM StGhcMod . runInBase . unGhcModT

View File

@ -15,7 +15,7 @@ setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()
setTargetFiles files = do setTargetFiles files = do
targets <- forM files $ \file -> G.guessTarget file Nothing targets <- forM files $ \file -> G.guessTarget file Nothing
G.setTargets targets G.setTargets targets
mode <- getMode mode <- gmCompilerMode <$> get
if mode == Intelligent then if mode == Intelligent then
loadTargets Intelligent loadTargets Intelligent
else do else do
@ -47,7 +47,7 @@ setTargetFiles files = do
setIntelligent = do setIntelligent = do
newdf <- setModeIntelligent <$> G.getSessionDynFlags newdf <- setModeIntelligent <$> G.getSessionDynFlags
void $ G.setSessionDynFlags newdf void $ G.setSessionDynFlags newdf
setMode Intelligent setCompilerMode Intelligent
needsFallback :: G.ModuleGraph -> Bool needsFallback :: G.ModuleGraph -> Bool
needsFallback = any (hasTHorQQ . G.ms_hspp_opts) needsFallback = any (hasTHorQQ . G.ms_hspp_opts)

View File

@ -96,6 +96,7 @@ Library
, ghc-syb-utils , ghc-syb-utils
, hlint >= 1.8.61 , hlint >= 1.8.61
, io-choice , io-choice
, monad-journal
, old-time , old-time
, process , process
, syb , syb
@ -180,6 +181,7 @@ Test-Suite spec
, ghc-syb-utils , ghc-syb-utils
, hlint >= 1.7.1 , hlint >= 1.7.1
, io-choice , io-choice
, monad-journal
, old-time , old-time
, process , process
, syb , syb

View File

@ -113,7 +113,7 @@ main = flip E.catches handlers $ do
nArgs n f = if length remainingArgs == n nArgs n f = if length remainingArgs == n
then f then f
else E.throw (ArgumentsMismatch cmdArg0) else E.throw (ArgumentsMismatch cmdArg0)
res <- runGhcModT opt $ case cmdArg0 of (res, _) <- runGhcModT opt $ case cmdArg0 of
"list" -> modules "list" -> modules
"lang" -> languages "lang" -> languages
"flag" -> flags "flag" -> flags
@ -136,7 +136,9 @@ main = flip E.catches handlers $ do
"version" -> return progVersion "version" -> return progVersion
"help" -> return $ O.usageInfo usage argspec "help" -> return $ O.usageInfo usage argspec
cmd -> E.throw (NoSuchCommand cmd) cmd -> E.throw (NoSuchCommand cmd)
putStr res case res of
Right s -> putStr s
Left e -> error $ show e
where where
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
handleThenExit handler e = handler e >> exitFailure handleThenExit handler e = handler e >> exitFailure

View File

@ -98,7 +98,11 @@ main = E.handle cmdHandler $
setCurrentDirectory rootdir setCurrentDirectory rootdir
mvar <- liftIO newEmptyMVar mvar <- liftIO newEmptyMVar
void $ forkIO $ setupDB mvar void $ forkIO $ setupDB mvar
runGhcModT opt $ loop S.empty mvar (res, _) <- runGhcModT opt $ loop S.empty mvar
case res of
Right () -> return ()
Left e -> error $ show e
where where
-- this is just in case. -- this is just in case.
-- If an error is caught here, it is a bug of GhcMod library. -- If an error is caught here, it is a bug of GhcMod library.

View File

@ -12,14 +12,22 @@ module TestUtils (
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Control.Applicative
isolateCradle :: IOish m => GhcModT m a -> GhcModT m a isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
isolateCradle action = isolateCradle action =
local modifyEnv $ action local modifyEnv $ action
where where
modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } } modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
extract :: IO (Either e a, w) -> IO a
extract action = do
(Right a, _) <- action
return a
runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
runIsolatedGhcMod opt action = runGhcModT opt $ isolateCradle action runIsolatedGhcMod opt action = do
extract $ runGhcModT opt $ isolateCradle action
-- | Run GhcMod in isolated cradle with default options -- | Run GhcMod in isolated cradle with default options
runID = runIsolatedGhcMod defaultOptions runID = runIsolatedGhcMod defaultOptions
@ -29,8 +37,8 @@ runI = runIsolatedGhcMod
-- | Run GhcMod -- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a run :: Options -> GhcModT IO a -> IO a
run = runGhcModT run opt a = extract $ runGhcModT opt a
-- | Run GhcMod with default options -- | Run GhcMod with default options
runD :: GhcModT IO a -> IO a runD :: GhcModT IO a -> IO a
runD = runGhcModT defaultOptions runD = extract . runGhcModT defaultOptions