From f311efd90c4f67bade549fcfc808131a3c07521e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 22 Jul 2014 19:45:48 +0200 Subject: [PATCH] Rework GhcModT monad stack --- Language/Haskell/GhcMod/Internal.hs | 10 +- Language/Haskell/GhcMod/Monad.hs | 139 ++++++++++++++-------------- Language/Haskell/GhcMod/Target.hs | 4 +- ghc-mod.cabal | 2 + src/GHCMod.hs | 6 +- src/GHCModi.hs | 6 +- test/TestUtils.hs | 14 ++- 7 files changed, 96 insertions(+), 85 deletions(-) diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 62d4063..237aff4 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -31,20 +31,18 @@ module Language.Haskell.GhcMod.Internal ( , newGhcModEnv , GhcModState , defaultState - , Mode(..) - , GhcModWriter + , CompilerMode(..) + , GhcModLog -- * Monad utilities - , runGhcMod , runGhcModT' , withErrorHandler -- ** Conversion - , liftGhcMod , toGhcModT -- ** Accessing 'GhcModEnv' and 'GhcModState' , options , cradle - , getMode - , setMode + , getCompilerMode + , setCompilerMode , withOptions -- * 'Ghc' Choice , (||>) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index a27f7d0..7e3255f 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -6,34 +6,32 @@ module Language.Haskell.GhcMod.Monad ( -- * Monad Types - GhcMod - , GhcModT + GhcModT , IOish -- ** Environment, state and logging , GhcModEnv(..) , newGhcModEnv - , GhcModState + , GhcModState(..) , defaultState - , Mode(..) - , GhcModWriter + , CompilerMode(..) + , GhcModLog -- * Monad utilities - , runGhcMod , runGhcModT , runGhcModT' , withErrorHandler -- ** Conversion - , liftGhcMod , toGhcModT -- ** Accessing 'GhcModEnv' and 'GhcModState' , options , cradle - , getMode - , setMode + , getCompilerMode + , setCompilerMode , withOptions -- ** Exporting convenient modules , module Control.Monad.Reader.Class , module Control.Monad.Writer.Class , module Control.Monad.State.Class + , module Control.Monad.Journal.Class ) where #if __GLASGOW_HASKELL__ < 708 @@ -77,20 +75,25 @@ import Data.Monoid (Monoid) #endif 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.Reader.Class -import Control.Monad.State.Class -import Control.Monad.Trans.Class -#if __GLASGOW_HASKELL__ < 708 -import Control.Monad.Trans.Maybe -#endif +-- Monad transformer stuff import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, 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.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.IORef (IORef, readIORef, writeIORef, newIORef) @@ -106,15 +109,17 @@ data GhcModEnv = GhcModEnv { , 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 Simple -type GhcModWriter = () - data GhcModError = GMENoMsg | GMEString String | GMECabal @@ -132,20 +137,22 @@ instance Error GhcModError where -- -- 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 --- 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 GhcMod a = GhcModT (ErrorT GhcModError IO) a - --- | The GhcMod monad transformer data type. This is basically a wrapper around --- RWST with custom instances for 'GhcMonad' and it's constraints. +-- | The GhcMod monad transformer data type. This is basically a newtype wrapper +-- around 'StateT', 'ErrorT', 'JournalT' and 'ReaderT' with custom instances for +-- 'GhcMonad' and it's constraints. -- -- The inner monad should have instances for 'MonadIO' and 'MonadBaseControl' -- 'IO'. Most @mtl@ monads already have 'MonadBaseControl' 'IO' instances, see -- the @monad-control@ package. newtype GhcModT m a = GhcModT { - unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a - } deriving (Functor + unGhcModT :: StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) a + } deriving ( Functor , Applicative , Alternative , Monad @@ -155,23 +162,29 @@ newtype GhcModT m a = GhcModT { , Control.Monad.IO.Class.MonadIO #endif , MonadReader GhcModEnv - , MonadWriter GhcModWriter + , MonadWriter w , 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 -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 instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where liftIO = lift . liftIO -instance (MonadIO m) => MonadIO (MaybeT m) where +instance MonadIO m => MonadIO (MaybeT m) where liftIO = lift . liftIO - #endif ---------------------------------------------------------------- @@ -231,18 +244,18 @@ newGhcModEnv opt dir = do , gmCradle = c } --- | Run a @GhcModT m@ computation, i.e. one with a custom underlying monad. --- --- You probably don't want this, look at 'runGhcMod' instead. -runGhcModT :: IOish m => Options -> GhcModT m a -> m a +-- | Run a @GhcModT m@ computation. +runGhcModT :: IOish m + => Options + -> GhcModT m a + -> m (Either GhcModError a, GhcModLog) runGhcModT opt action = do env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory - (a,(_,_)) <- runGhcModT' env defaultState $ do + first (fmap fst) <$> (runGhcModT' env defaultState $ do dflags <- getSessionDynFlags defaultCleanupHandler dflags $ do initializeFlagsWithCradle opt (gmCradle env) - action - return a + action) -- | 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 @@ -253,28 +266,12 @@ runGhcModT' :: IOish m => GhcModEnv -> GhcModState -> GhcModT m a - -> m (a,(GhcModState, GhcModWriter)) + -> m (Either GhcModError (a, GhcModState), GhcModLog) runGhcModT' r s a = do - (a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s - return (a',(s',w)) - --- | Run a 'GhcMod' computation. If you want an underlying monad other than --- '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 - + (res, w') <- + flip runReaderT r $ runJournalT $ runErrorT $ flip runStateT s + $ (unGhcModT $ initGhcMonad (Just libdir) >> a) + return $ (res, w') ---------------------------------------------------------------- withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a @@ -300,13 +297,11 @@ options = gmOptions <$> ask cradle :: IOish m => GhcModT m Cradle cradle = gmCradle <$> ask -getMode :: IOish m => GhcModT m Mode -getMode = do - GhcModState mode <- get - return mode +getCompilerMode :: (Functor m, MonadState GhcModState m) => m CompilerMode +getCompilerMode = gmCompilerMode <$> get -setMode :: IOish m => Mode -> GhcModT m () -setMode mode = put $ GhcModState mode +setCompilerMode :: MonadState GhcModState m => CompilerMode -> m () +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 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 -> f $ liftM StGhcMod . runInBase . unGhcModT diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 53ad99c..572388b 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -15,7 +15,7 @@ setTargetFiles :: IOish m => [FilePath] -> GhcModT m () setTargetFiles files = do targets <- forM files $ \file -> G.guessTarget file Nothing G.setTargets targets - mode <- getMode + mode <- gmCompilerMode <$> get if mode == Intelligent then loadTargets Intelligent else do @@ -47,7 +47,7 @@ setTargetFiles files = do setIntelligent = do newdf <- setModeIntelligent <$> G.getSessionDynFlags void $ G.setSessionDynFlags newdf - setMode Intelligent + setCompilerMode Intelligent needsFallback :: G.ModuleGraph -> Bool needsFallback = any (hasTHorQQ . G.ms_hspp_opts) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 602025b..4d001e3 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -96,6 +96,7 @@ Library , ghc-syb-utils , hlint >= 1.8.61 , io-choice + , monad-journal , old-time , process , syb @@ -180,6 +181,7 @@ Test-Suite spec , ghc-syb-utils , hlint >= 1.7.1 , io-choice + , monad-journal , old-time , process , syb diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 8903d17..83b9165 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -113,7 +113,7 @@ main = flip E.catches handlers $ do nArgs n f = if length remainingArgs == n then f else E.throw (ArgumentsMismatch cmdArg0) - res <- runGhcModT opt $ case cmdArg0 of + (res, _) <- runGhcModT opt $ case cmdArg0 of "list" -> modules "lang" -> languages "flag" -> flags @@ -136,7 +136,9 @@ main = flip E.catches handlers $ do "version" -> return progVersion "help" -> return $ O.usageInfo usage argspec cmd -> E.throw (NoSuchCommand cmd) - putStr res + case res of + Right s -> putStr s + Left e -> error $ show e where handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] handleThenExit handler e = handler e >> exitFailure diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 04f68f8..6276338 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -98,7 +98,11 @@ main = E.handle cmdHandler $ setCurrentDirectory rootdir mvar <- liftIO newEmptyMVar 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 -- this is just in case. -- If an error is caught here, it is a bug of GhcMod library. diff --git a/test/TestUtils.hs b/test/TestUtils.hs index c9ed00f..29ec8d1 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -12,14 +12,22 @@ module TestUtils ( import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types +import Control.Applicative + isolateCradle :: IOish m => GhcModT m a -> GhcModT m a isolateCradle action = local modifyEnv $ action where 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 opt action = runGhcModT opt $ isolateCradle action +runIsolatedGhcMod opt action = do + extract $ runGhcModT opt $ isolateCradle action -- | Run GhcMod in isolated cradle with default options runID = runIsolatedGhcMod defaultOptions @@ -29,8 +37,8 @@ runI = runIsolatedGhcMod -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a -run = runGhcModT +run opt a = extract $ runGhcModT opt a -- | Run GhcMod with default options runD :: GhcModT IO a -> IO a -runD = runGhcModT defaultOptions +runD = extract . runGhcModT defaultOptions