Give readProcess' more sensible error messages.
Also a bunch of refactoring for GhcModError
This commit is contained in:
parent
a7f00931c5
commit
a0ae09a3e6
@ -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
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
39
Language/Haskell/GhcMod/Error.hs
Normal file
39
Language/Haskell/GhcMod/Error.hs
Normal file
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -35,6 +35,7 @@ module Language.Haskell.GhcMod.Internal (
|
||||
, GhcModLog
|
||||
-- * Monad utilities
|
||||
, runGhcModT'
|
||||
, hoistGhcModT
|
||||
-- ** Accessing 'GhcModEnv' and 'GhcModState'
|
||||
, options
|
||||
, cradle
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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.
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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"]
|
||||
|
@ -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 ""
|
||||
|
@ -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 ""
|
||||
|
Loading…
Reference in New Issue
Block a user