Rework GhcModT monad stack

Language/Haskell/GhcMod/Internal.hs

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

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(..)
+  , CompilerMode(..)
-  , GhcModWriter
+  , GhcModLog
   -- * Monad utilities
-  , runGhcMod
   , runGhcModT
   , runGhcModT'
   , withErrorHandler
   -- ** Conversion
-  , liftGhcMod
   , toGhcModT
   -- ** Accessing 'GhcModEnv' and 'GhcModState'
   , options
   , cradle
-  , getMode
+  , getCompilerMode
-  , setMode
+  , 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
+-- 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,
   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 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'
 -- '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
+      unGhcModT :: StateT GhcModState
-    } deriving (Functor
+                     (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.
+-- | 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
     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
+            action)
-    return a
 
 -- | 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
+  (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
@@ -300,13 +297,11 @@ options = gmOptions <$> ask
 cradle :: IOish m => GhcModT m Cradle
 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
     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
 

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)

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

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

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.

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