Give readProcess' more sensible error messages.

Also a bunch of refactoring for GhcModError

Language/Haskell/GhcMod/Browse.hs

@@ -14,7 +14,7 @@ import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
 import Language.Haskell.GhcMod.Gap
-import Language.Haskell.GhcMod.Monad (IOish, GhcModT, options)
+import Language.Haskell.GhcMod.Monad (GhcModT, options)
 import Language.Haskell.GhcMod.Target (setTargetFiles)
 import Language.Haskell.GhcMod.Types
 import Name (getOccString)

Language/Haskell/GhcMod/CabalApi.hs

@@ -11,6 +11,7 @@ module Language.Haskell.GhcMod.CabalApi (
   ) where
 
 import Language.Haskell.GhcMod.CabalConfig
+import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,
                                     toModuleString)
 import Language.Haskell.GhcMod.GhcPkg
@@ -20,7 +21,6 @@ import MonadUtils (MonadIO, liftIO)
 import Control.Applicative ((<$>))
 import qualified Control.Exception as E
 import Control.Monad (filterM)
-import Control.Monad.Error.Class (Error, MonadError(..))
 import Data.Maybe (maybeToList)
 import Data.Set (fromList, toList)
 import Distribution.Package (Dependency(Dependency)
@@ -42,7 +42,7 @@ import System.FilePath ((</>))
 ----------------------------------------------------------------
 
 -- | Getting necessary 'CompilerOptions' from three information sources.
-getCompilerOptions :: (MonadIO m, MonadError GhcModError m, Functor m)
+getCompilerOptions :: (IOish m, MonadError GhcModError m)
                    => [GHCOption]
                    -> Cradle
                    -> PackageDescription

Language/Haskell/GhcMod/CabalConfig.hs

@@ -7,6 +7,7 @@ module Language.Haskell.GhcMod.CabalConfig (
   , cabalConfigDependencies
   ) where
 
+import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Read
@@ -20,13 +21,12 @@ import qualified Language.Haskell.GhcMod.Cabal18 as C18
 #endif
 
 import Control.Applicative ((<$>))
-import Control.Monad (mplus,void)
+import Control.Monad (mplus)
 #if MIN_VERSION_mtl(2,2,1)
 import Control.Monad.Except ()
 #else
 import Control.Monad.Error ()
 #endif
-import Control.Monad.Error (MonadError(..))
 import Data.Maybe ()
 import Data.Set ()
 import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
@@ -35,7 +35,7 @@ import Distribution.Package (InstalledPackageId(..)
 import Distribution.Simple.BuildPaths (defaultDistPref)
 import Distribution.Simple.Configure (localBuildInfoFile)
 import Distribution.Simple.LocalBuildInfo (ComponentName)
-import MonadUtils (MonadIO)
+import MonadUtils (liftIO)
 import System.FilePath ((</>))
 
 ----------------------------------------------------------------
@@ -46,16 +46,18 @@ type CabalConfig = String
 -- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
 -- exist run @cabal configure@ i.e. configure with default options like @cabal
 -- build@ would do.
-getConfig :: (MonadIO m, MonadError GhcModError m)
+getConfig :: (IOish m, MonadError GhcModError m)
           => Cradle
           -> m CabalConfig
-getConfig cradle = tryFix (liftIOExceptions (readFile path)) $ \_ ->
-    rethrowError (GMECabalConfigure . gmeMsg) configure
+getConfig cradle = liftIO (readFile path) `tryFix` \_ ->
+     configure `modifyError'` GMECabalConfigure
  where
    prjDir = cradleRootDir cradle
    path = prjDir </> configPath
-   configure = liftIOExceptions $ void $
-       withDirectory_ prjDir $ readProcess' "cabal" ["configure"]
+
+   configure :: (IOish m, MonadError GhcModError m) => m ()
+   configure =
+       withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return ()
 
 
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
@@ -63,7 +65,7 @@ configPath :: FilePath
 configPath = localBuildInfoFile defaultDistPref
 
 -- | Get list of 'Package's needed by all components of the current package
-cabalConfigDependencies :: (MonadIO m, Functor m, MonadError GhcModError m)
+cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
                         => Cradle
                         -> PackageIdentifier
                         -> m [Package]

Language/Haskell/GhcMod/Error.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
+module Language.Haskell.GhcMod.Error (
+    GhcModError(..)
+  , modifyError
+  , modifyError'
+  , tryFix
+  , module Control.Monad.Error
+  , module Exception
+  ) where
+
+import Control.Monad.Error (MonadError(..), Error(..))
+import Exception
+
+data GhcModError = GMENoMsg
+                 -- ^ Unknown error
+                 | GMEString String
+                 -- ^ Some Error with a message. These are produced mostly by
+                 -- 'fail' calls on GhcModT.
+                 | GMECabalConfigure GhcModError
+                 -- ^ Configuring a cabal project failed.
+                 | GMEProcess [String] GhcModError
+                 -- ^ Launching an operating system process failed. The first
+                 -- field is the command.
+                   deriving (Eq,Show)
+
+instance Error GhcModError where
+    noMsg = GMENoMsg
+    strMsg = GMEString
+
+modifyError :: MonadError e m => (e -> e) -> m a -> m a
+modifyError f action = action `catchError` \e -> throwError $ f e
+
+infixr 0 `modifyError'`
+modifyError' :: MonadError e m => m a -> (e -> e) -> m a
+modifyError' = flip modifyError
+
+tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
+tryFix action fix = do
+  action `catchError` \e -> fix e >> action

Language/Haskell/GhcMod/Find.hs

@@ -16,7 +16,6 @@ module Language.Haskell.GhcMod.Find
 
 import Config (cProjectVersion,cTargetPlatformString)
 import Control.Applicative ((<$>))
-import Control.Exception (handle, SomeException(..))
 import Control.Monad (when, void)
 import Control.Monad.Error.Class
 import Data.Function (on)
@@ -78,7 +77,7 @@ packageConfDir = "package.conf.d"
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
 --   which will be concatenated. 'loadSymbolDb' is called internally.
 findSymbol :: IOish m => Symbol -> GhcModT m String
-findSymbol sym = liftIO loadSymbolDb >>= lookupSymbol sym
+findSymbol sym = loadSymbolDb >>= lookupSymbol sym
 
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
 --   which will be concatenated.
@@ -91,7 +90,7 @@ lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
 ---------------------------------------------------------------
 
 -- | Loading a file and creates 'SymbolDb'.
-loadSymbolDb :: IO SymbolDb
+loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
 loadSymbolDb = SymbolDb <$> readSymbolDb
 
 -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
@@ -102,7 +101,9 @@ ghcModExecutable = do
     dir <- getExecutablePath'
     return $ dir </> "ghc-mod"
 #else
-ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
+ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
+                                              -- compiling spec
+                      return "dist/build/ghc-mod/ghc-mod"
 #endif
  where
     getExecutablePath' :: IO FilePath
@@ -112,11 +113,11 @@ ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
     getExecutablePath' = return ""
 # endif
 
-readSymbolDb :: IO (Map Symbol [ModuleString])
-readSymbolDb = handle (\(SomeException _) -> return M.empty) $ do
-    ghcMod <- ghcModExecutable
+readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
+readSymbolDb = do
+    ghcMod <- liftIO ghcModExecutable
     file <- chop <$> readProcess' ghcMod ["dumpsym"]
-    M.fromAscList . map conv . lines <$> readFile file
+    M.fromAscList . map conv . lines <$> liftIO (readFile file)
   where
     conv :: String -> (Symbol,[ModuleString])
     conv = read

Language/Haskell/GhcMod/GHCApi.hs

@@ -11,7 +11,7 @@ module Language.Haskell.GhcMod.GHCApi (
   ) where
 
 import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
+import Language.Haskell.GhcMod.Monad (GhcModT)
 import Language.Haskell.GhcMod.Target (setTargetFiles)
 import Language.Haskell.GhcMod.Types
 

Language/Haskell/GhcMod/Internal.hs

@@ -35,6 +35,7 @@ module Language.Haskell.GhcMod.Internal (
   , GhcModLog
   -- * Monad utilities
   , runGhcModT'
+  , hoistGhcModT
   -- ** Accessing 'GhcModEnv' and 'GhcModState'
   , options
   , cradle

Language/Haskell/GhcMod/Monad.hs

@@ -18,6 +18,7 @@ module Language.Haskell.GhcMod.Monad (
   -- * Monad utilities
   , runGhcModT
   , runGhcModT'
+  , hoistGhcModT
   -- ** Accessing 'GhcModEnv' and 'GhcModState'
   , gmsGet
   , gmsPut
@@ -45,6 +46,7 @@ module Language.Haskell.GhcMod.Monad (
 
 
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.GhcPkg
@@ -52,7 +54,6 @@ import Language.Haskell.GhcMod.CabalApi
 import qualified Language.Haskell.GhcMod.Gap as Gap
 
 import DynFlags
-import Exception
 import GHC
 import qualified GHC as G
 import GHC.Paths (libdir)
@@ -87,7 +88,7 @@ import Control.Monad.Reader.Class
 import Control.Monad.Writer.Class (MonadWriter)
 import Control.Monad.State.Class (MonadState(..))
 
-import Control.Monad.Error (MonadError, ErrorT, runErrorT)
+import Control.Monad.Error (ErrorT, runErrorT)
 import Control.Monad.Reader (ReaderT, runReaderT)
 import Control.Monad.State.Strict (StateT, runStateT)
 import Control.Monad.Trans.Journal (JournalT, runJournalT)
@@ -100,6 +101,7 @@ import Control.Monad.Journal.Class
 import Data.Maybe (fromJust, isJust)
 import Data.IORef (IORef, readIORef, writeIORef, newIORef)
 import System.Directory (getCurrentDirectory)
+import System.IO.Error (tryIOError)
 
 ----------------------------------------------------------------
 
@@ -122,14 +124,6 @@ defaultState = GhcModState Simple
 
 ----------------------------------------------------------------
 
--- | A constraint alias (-XConstraintKinds) to make functions dealing with
--- 'GhcModT' somewhat cleaner.
---
--- 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 inner monad.
-type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m)
-
 -- | 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.
@@ -147,7 +141,6 @@ newtype GhcModT m a = GhcModT {
                , Alternative
                , Monad
                , MonadPlus
-               , MonadIO
 #if DIFFERENT_MONADIO
                , Control.Monad.IO.Class.MonadIO
 #endif
@@ -157,7 +150,16 @@ newtype GhcModT m a = GhcModT {
                , MonadError GhcModError
                )
 
-instance MonadTrans GhcModT where
+instance MonadIO m => MonadIO (GhcModT m) where
+    liftIO action = do
+      res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ tryIOError action
+      case res of
+        Right a -> return a
+        Left e -> case show e of
+          ""  -> throwError $ noMsg
+          msg -> throwError $ strMsg msg
+
+instance MonadTrans (GhcModT) where
     lift = GhcModT . lift . lift . lift . lift
 
 instance MonadState s m => MonadState s (GhcModT m) where
@@ -188,7 +190,7 @@ instance MonadIO m => MonadIO (MaybeT m) where
 -- | Initialize the 'DynFlags' relating to the compilation of a single
 -- file or GHC session according to the 'Cradle' and 'Options'
 -- provided.
-initializeFlagsWithCradle :: (GhcMonad m, MonadError GhcModError m)
+initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m)
         => Options
         -> Cradle
         -> m ()
@@ -253,6 +255,17 @@ runGhcModT opt action = do
             initializeFlagsWithCradle opt (gmCradle env)
             action)
 
+-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
+-- computation. Note that if the computation that returned @result@ modified the
+-- state part of GhcModT this cannot be restored.
+hoistGhcModT :: IOish m
+             => (Either GhcModError a, GhcModLog)
+             -> GhcModT m a
+hoistGhcModT (r,l) = do
+  GhcModT (lift $ lift $ journal l) >> case r of
+    Left e -> throwError e
+    Right a -> 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
 -- do with 'GhcModEnv' and 'GhcModState'.
@@ -293,6 +306,9 @@ overrideGhcUserOptions action = withTempSession $ do
 
 ----------------------------------------------------------------
 
+gmeAsk :: IOish m => GhcModT m GhcModEnv
+gmeAsk = ask
+
 gmsGet :: IOish m => GhcModT m GhcModState
 gmsGet = GhcModT get
 
@@ -300,10 +316,10 @@ gmsPut :: IOish m => GhcModState -> GhcModT m ()
 gmsPut = GhcModT . put
 
 options :: IOish m => GhcModT m Options
-options = gmOptions <$> ask
+options = gmOptions <$> gmeAsk
 
 cradle :: IOish m => GhcModT m Cradle
-cradle = gmCradle <$> ask
+cradle = gmCradle <$> gmeAsk
 
 getCompilerMode :: IOish m => GhcModT m CompilerMode
 getCompilerMode = gmCompilerMode <$> gmsGet

Language/Haskell/GhcMod/SrcUtils.hs

@@ -85,7 +85,10 @@ pretty dflag style = showOneLine dflag style . Gap.typeForUser
 
 ----------------------------------------------------------------
 
-inModuleContext :: IOish m => FilePath -> (DynFlags -> PprStyle -> GhcModT m a) -> GhcModT m a
+inModuleContext :: IOish m
+                => FilePath
+                -> (DynFlags -> PprStyle -> GhcModT m a)
+                -> GhcModT m a
 inModuleContext file action =
     withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do
     setTargetFiles [file]

Language/Haskell/GhcMod/Types.hs

@@ -1,23 +1,20 @@
 module Language.Haskell.GhcMod.Types where
 
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.List (intercalate)
 import qualified Data.Map as M
-import Control.Monad.Error (Error(..))
+import Exception (ExceptionMonad)
+import MonadUtils (MonadIO)
 
 import PackageConfig (PackageConfig)
 
-data GhcModError = GMENoMsg
-                 -- ^ Unknown error
-                 | GMEString { gmeMsg :: String }
-                 -- ^ Some Error with a message. These are produced mostly by
-                 -- 'fail' calls on GhcModT.
-                 | GMECabalConfigure { gmeMsg :: String }
-                 -- ^ Configuring a cabal project failed.
-                   deriving (Eq,Show)
-
-instance Error GhcModError where
-    noMsg = GMENoMsg
-    strMsg = GMEString
+-- | A constraint alias (-XConstraintKinds) to make functions dealing with
+-- 'GhcModT' somewhat cleaner.
+--
+-- 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 inner monad.
+type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)
 
 -- | Output style.
 data OutputStyle = LispStyle  -- ^ S expression style.

Language/Haskell/GhcMod/Utils.hs

@@ -1,12 +1,10 @@
 module Language.Haskell.GhcMod.Utils where
 
 
-import Control.Exception
-import Control.Monad.Error (MonadError(..), Error(..))
+import Language.Haskell.GhcMod.Error
 import MonadUtils (MonadIO, liftIO)
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
 import System.Exit (ExitCode(..))
-import System.IO.Error (tryIOError)
 import System.Process (readProcessWithExitCode)
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
@@ -25,39 +23,22 @@ extractParens str = extractParens' str 0
        | s `elem` "}])" = s : extractParens' ss (level-1)
        | otherwise = s : extractParens' ss level
 
-readProcess' :: (MonadIO m, Error e, MonadError e m)
+readProcess' :: (MonadIO m, MonadError GhcModError m)
              => String
              -> [String]
              -> m String
 readProcess' cmd opts = do
-  (rv,output,err) <- liftIO $ readProcessWithExitCode cmd opts ""
+  (rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "")
+      `modifyError'` GMEProcess ([cmd] ++ opts)
   case rv of
     ExitFailure val -> do
-        throwError $ strMsg $
+        throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $
           cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
               ++ "\n" ++ err
     ExitSuccess ->
         return output
 
-withDirectory_ :: FilePath -> IO a -> IO a
+withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
 withDirectory_ dir action =
-    bracket getCurrentDirectory setCurrentDirectory
-                (\_ -> setCurrentDirectory dir >> action)
-
-rethrowError :: MonadError e m => (e -> e) -> m a -> m a
-rethrowError f action = action `catchError` \e -> throwError $ f e
-
-tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
-tryFix action fix = do
-  action `catchError` \e -> fix e >> action
-
--- | 'IOException's thrown in the computation passed to this function will be
--- converted to 'MonadError' failures using 'throwError'.
-liftIOExceptions :: (MonadIO m, Error e, MonadError e m) => IO a -> m a
-liftIOExceptions action = do
-  res <- liftIO $ tryIOError action
-  case res of
-    Right a -> return a
-    Left e -> case show e of
-                ""  -> throwError $ noMsg
-                msg -> throwError $ strMsg msg
+    gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
+                (\_ -> liftIO (setCurrentDirectory dir) >> action)