Merge remote-tracking branch 'kazu/master'

.travis.yml

@@ -17,7 +17,8 @@ script:
   - rm -rf /tmp/test && mkdir -p /tmp/test
   - cd /tmp/test
   - tar -xf $SRC_TGZ && cd ghc-mod*/
-  - cabal configure --enable-tests
+  - if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi
+  - cabal configure --enable-tests $WERROR
   - cabal build
   - cabal test
 

Language/Haskell/GhcMod.hs

@@ -60,7 +60,7 @@ import Language.Haskell.GhcMod.Flag
 import Language.Haskell.GhcMod.Info
 import Language.Haskell.GhcMod.Lang
 import Language.Haskell.GhcMod.Lint
-import Language.Haskell.GhcMod.List
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Modules
 import Language.Haskell.GhcMod.PkgDoc
 import Language.Haskell.GhcMod.Types

Language/Haskell/GhcMod/Boot.hs

@@ -4,8 +4,8 @@ import Control.Applicative
 import Language.Haskell.GhcMod.Browse
 import Language.Haskell.GhcMod.Flag
 import Language.Haskell.GhcMod.Lang
-import Language.Haskell.GhcMod.List
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Modules
 
 -- | Printing necessary information for front-end booting.
 boot :: IOish m => GhcModT m String

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/Modules.hs

@@ -1,4 +1,4 @@
-module Language.Haskell.GhcMod.List (modules) where
+module Language.Haskell.GhcMod.Modules (modules) where
 
 import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))

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)

ghc-mod.cabal

@@ -70,6 +70,7 @@ Library
                         Language.Haskell.GhcMod.Debug
                         Language.Haskell.GhcMod.Doc
                         Language.Haskell.GhcMod.DynFlags
+                        Language.Haskell.GhcMod.Error
                         Language.Haskell.GhcMod.FillSig
                         Language.Haskell.GhcMod.Find
                         Language.Haskell.GhcMod.Flag
@@ -80,9 +81,9 @@ Library
                         Language.Haskell.GhcMod.Info
                         Language.Haskell.GhcMod.Lang
                         Language.Haskell.GhcMod.Lint
-                        Language.Haskell.GhcMod.List
                         Language.Haskell.GhcMod.Logger
                         Language.Haskell.GhcMod.Monad
+                        Language.Haskell.GhcMod.Modules
                         Language.Haskell.GhcMod.PkgDoc
                         Language.Haskell.GhcMod.Read
                         Language.Haskell.GhcMod.SrcUtils
@@ -144,6 +145,7 @@ Executable ghc-modi
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
+                      , async
                       , containers
                       , directory
                       , filepath

src/GHCMod.hs

@@ -113,6 +113,7 @@ main = flip E.catches handlers $ do
         cmdArg4 = cmdArg !. 4
         cmdArg5 = cmdArg !. 5
         remainingArgs = tail cmdArg
+        nArgs :: Int -> a -> a
         nArgs n f = if length remainingArgs == n
                         then f
                         else E.throw (ArgumentsMismatch cmdArg0)
@@ -139,6 +140,7 @@ main = flip E.catches handlers $ do
       "version" -> return progVersion
       "help"    -> return $ O.usageInfo usage argspec
       cmd       -> E.throw (NoSuchCommand cmd)
+
     case res of
       Right s -> putStr s
       Left (GMENoMsg) ->
@@ -146,7 +148,12 @@ main = flip E.catches handlers $ do
       Left (GMEString msg) ->
           hPutStrLn stderr msg
       Left (GMECabalConfigure msg) ->
-          hPutStrLn stderr $ "cabal configure failed: " ++ msg
+          hPutStrLn stderr $ "cabal configure failed: " ++ show msg
+      Left (GMEProcess cmd msg) ->
+          hPutStrLn stderr $
+            "launching operating system process `"++c++"` failed: " ++ show msg
+          where c = unwords cmd
+
   where
     handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
     handleThenExit handler e = handler e >> exitFailure

src/GHCModi.hs

@@ -20,10 +20,10 @@ module Main where
 
 import Config (cProjectVersion)
 import Control.Applicative ((<$>))
-import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)
+import Control.Concurrent.Async (Async, async, wait)
 import Control.Exception (SomeException(..), Exception)
 import qualified Control.Exception as E
-import Control.Monad (when, void)
+import Control.Monad (when)
 import CoreMonad (liftIO)
 import Data.List (find, intercalate)
 import Data.List.Split (splitOn)
@@ -34,6 +34,7 @@ import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import qualified GHC as G
 import Language.Haskell.GhcMod
+import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt
 import System.Directory (setCurrentDirectory)
@@ -100,14 +101,13 @@ main = E.handle cmdHandler $
         let rootdir = cradleRootDir cradle0
 --            c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
         setCurrentDirectory rootdir
-        mvar <- liftIO newEmptyMVar
-        void $ forkIO $ setupDB mvar
-        (res, _) <- runGhcModT opt $ loop S.empty mvar
+        symDb <- async $ runGhcModT opt loadSymbolDb
+        (res, _) <- runGhcModT opt $ loop S.empty symDb
 
         case res of
           Right () -> return ()
           Left (GMECabalConfigure msg) -> do
-              putStrLn $ notGood $ "cabal configure failed: " ++ msg
+              putStrLn $ notGood $ "cabal configure failed: " ++ show msg
               exitFailure
           Left e -> bug $ show e
       where
@@ -132,19 +132,14 @@ replace needle replacement = intercalate replacement . splitOn needle
 
 ----------------------------------------------------------------
 
-setupDB :: MVar SymbolDb -> IO ()
-setupDB mvar = loadSymbolDb >>= putMVar mvar
-
-----------------------------------------------------------------
-
-loop :: IOish m => Set FilePath -> MVar SymbolDb -> GhcModT m ()
-loop set mvar = do
+loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m ()
+loop set symDbReq = do
     cmdArg <- liftIO getLine
     let (cmd,arg') = break (== ' ') cmdArg
         arg = dropWhile (== ' ') arg'
     (ret,ok,set') <- case cmd of
         "check"  -> checkStx set arg
-        "find"   -> findSym set arg mvar
+        "find"   -> findSym set arg symDbReq
         "lint"   -> lintStx set arg
         "info"   -> showInfo set arg
         "type"   -> showType set arg
@@ -163,7 +158,7 @@ loop set mvar = do
       else do
         liftIO $ putStrLn $ notGood ret
     liftIO $ hFlush stdout
-    when ok $ loop set' mvar
+    when ok $ loop set' symDbReq
 
 ----------------------------------------------------------------
 
@@ -207,10 +202,12 @@ isSameMainFile file (Just x)
 
 ----------------------------------------------------------------
 
-findSym :: IOish m => Set FilePath -> String -> MVar SymbolDb
+type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)
+
+findSym :: IOish m => Set FilePath -> String -> SymDbReq
         -> GhcModT m (String, Bool, Set FilePath)
-findSym set sym mvar = do
-    db <- liftIO $ readMVar mvar
+findSym set sym dbReq = do
+    db <- hoistGhcModT =<< liftIO (wait dbReq)
     ret <- lookupSymbol sym db
     return (ret, True, set)
 

test/FindSpec.hs

@@ -2,10 +2,11 @@ module FindSpec where
 
 import Language.Haskell.GhcMod.Find
 import Test.Hspec
+import TestUtils
 
 spec :: Spec
 spec = do
     describe "db <- loadSymbolDb" $ do
         it "lookupSymbol' db \"head\"  contains at least `Data.List'" $ do
-            db <- loadSymbolDb
+            db <- runD loadSymbolDb
             lookupSym "head" db `shouldContain` ["Data.List"]

test/MonadSpec.hs

@@ -5,6 +5,7 @@ import Test.Hspec
 import Dir
 import TestUtils
 import Control.Applicative
+import Control.Exception
 import Control.Monad.Error.Class
 
 spec :: Spec
@@ -27,3 +28,12 @@ spec = do
         it "work" $ do
           (runD $ gmsPut (GhcModState Intelligent) >> gmsGet)
             `shouldReturn` (GhcModState Intelligent)
+
+    describe "liftIO" $ do
+        it "converts user errors to GhcModError" $ do
+            shouldReturnError $
+                runD' $ liftIO $ throw (userError "hello") >> return ""
+
+        it "converts a file not found exception to GhcModError" $ do
+            shouldReturnError $
+                runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return ""

test/UtilsSpec.hs

@@ -1,7 +1,7 @@
 module UtilsSpec where
 
+import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Utils
-import Control.Exception
 import TestUtils
 import Test.Hspec
 
@@ -15,7 +15,9 @@ spec = do
     describe "liftMonadError" $ do
         it "converts IOErrors to GhcModError" $ do
             shouldReturnError $
-                runD' $ liftIOExceptions $ throw (userError "hello") >> return ""
+                runD' $ liftIO $ throw (userError "hello") >> return ""
 
             shouldReturnError $
-                runD' $ liftIOExceptions $ readFile "/DOES_NOT_EXIST" >> return ""
+                runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return ""
+
+-- readProcessWithExitCode cmd opts ""