From 271ff4e162f84e2d655d9f6519be79abe243da86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 18 Aug 2014 08:06:36 +0200 Subject: [PATCH] Catch `cabal configure` failure properly --- Language/Haskell/GhcMod/CabalApi.hs | 7 ++--- Language/Haskell/GhcMod/CabalConfig.hs | 22 ++++++++++------ Language/Haskell/GhcMod/Debug.hs | 2 +- Language/Haskell/GhcMod/Monad.hs | 2 +- Language/Haskell/GhcMod/Types.hs | 5 ++-- Language/Haskell/GhcMod/Utils.hs | 30 ++++++++++++++++++--- ghc-mod.cabal | 1 + src/GHCMod.hs | 2 ++ src/GHCModi.hs | 36 ++++++++++++++++++-------- test/CabalApiSpec.hs | 2 +- test/UtilsSpec.hs | 11 ++++++++ 11 files changed, 90 insertions(+), 30 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 60cdb8a..b578f4f 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -42,12 +42,13 @@ import System.FilePath (()) ---------------------------------------------------------------- -- | Getting necessary 'CompilerOptions' from three information sources. -getCompilerOptions :: [GHCOption] +getCompilerOptions :: (MonadIO m, MonadError GhcModError m, Functor m) + => [GHCOption] -> Cradle -> PackageDescription - -> IO CompilerOptions + -> m CompilerOptions getCompilerOptions ghcopts cradle pkgDesc = do - gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos + gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc) return $ CompilerOptions gopts idirs depPkgs where diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index ed1fdeb..ccc3334 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -19,14 +19,15 @@ import qualified Language.Haskell.GhcMod.Cabal18 as C18 #define MIN_VERSION_mtl(x,y,z) 1 #endif -import qualified Control.Exception as E +import MonadUtils (MonadIO(liftIO)) import Control.Applicative ((<$>)) -import Control.Monad (mplus) +import Control.Monad (mplus,void) #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) @@ -44,14 +45,16 @@ 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 :: Cradle -> IO CabalConfig -getConfig cradle = - readFile path `E.catch` (\(E.SomeException _) -> configure >> readFile path) +getConfig :: (MonadIO m, MonadError GhcModError m) + => Cradle + -> m CabalConfig +getConfig cradle = tryFix (liftMonadError (readFile path)) $ \_ -> + rethrowError (GMECabalConfigure . gmeMsg) configure where prjDir = cradleRootDir cradle path = prjDir configPath - configure = - withDirectory_ prjDir $ readProcess' "cabal" ["configure"] + configure = liftMonadError $ void $ + withDirectory_ prjDir $ readProcess' "cabal" ["configure"] -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ @@ -59,7 +62,10 @@ configPath :: FilePath configPath = localBuildInfoFile defaultDistPref -- | Get list of 'Package's needed by all components of the current package -cabalConfigDependencies :: Cradle -> PackageIdentifier -> IO [Package] +cabalConfigDependencies :: (MonadIO m, Functor m, MonadError GhcModError m) + => Cradle + -> PackageIdentifier + -> m [Package] cabalConfigDependencies cradle thisPkg = configDependencies thisPkg <$> getConfig cradle diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 85cf9f6..c429bf2 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -32,7 +32,7 @@ debugInfo = cradle >>= \c -> convert' =<< do return $ CompilerOptions (ghcUserOptions op) [] [] fromCabalFile c = options >>= \opts -> do pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c - liftIO $ getCompilerOptions (ghcUserOptions opts) c pkgDesc + getCompilerOptions (ghcUserOptions opts) c pkgDesc ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index e762322..a46e2f1 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -204,7 +204,7 @@ initializeFlagsWithCradle opt c ghcopts = ghcUserOptions opt withCabal = do pkgDesc <- parseCabalFile $ fromJust mCradleFile - compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc + compOpts <- getCompilerOptions ghcopts c pkgDesc initSession CabalPkg opt compOpts withSandbox = initSession SingleFile opt compOpts where diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index b224059..1e80ca2 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -6,12 +6,13 @@ import Control.Monad.Error (Error(..)) import PackageConfig (PackageConfig) --- | data GhcModError = GMENoMsg -- ^ Unknown error - | GMEString String + | 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,Read) instance Error GhcModError where diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 9937e78..4adba59 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -1,11 +1,15 @@ module Language.Haskell.GhcMod.Utils where + import MonadUtils (MonadIO, liftIO) -import Control.Exception (bracket) +import Control.Exception +import Control.Monad.Error (MonadError(..), Error(..)) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Process (readProcessWithExitCode) import System.Exit (ExitCode(..)) import System.IO (hPutStrLn, stderr) +import System.IO.Error (tryIOError) + -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a] @@ -23,13 +27,17 @@ extractParens str = extractParens' str 0 | s `elem` "}])" = s : extractParens' ss (level-1) | otherwise = s : extractParens' ss level -readProcess' :: MonadIO m => String -> [String] -> m String +readProcess' :: (MonadIO m, Error e, MonadError e m) + => String + -> [String] + -> m String readProcess' cmd opts = do (rv,output,err) <- liftIO $ readProcessWithExitCode cmd opts "" case rv of ExitFailure val -> do liftIO $ hPutStrLn stderr err - fail $ cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")" + throwError $ strMsg $ + cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")" ExitSuccess -> return output @@ -37,3 +45,19 @@ withDirectory_ :: FilePath -> IO a -> IO 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 + +liftMonadError :: (MonadIO m, Error e, MonadError e m) => IO a -> m a +liftMonadError 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1069577..4fab525 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -141,6 +141,7 @@ Executable ghc-modi , containers , directory , filepath + , split , ghc , ghc-mod diff --git a/src/GHCMod.hs b/src/GHCMod.hs index dc007f2..4e9f4f7 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -143,6 +143,8 @@ main = flip E.catches handlers $ do Right s -> putStr s Left (GMENoMsg) -> hPutStrLn stderr "Unknown error" Left (GMEString msg) -> hPutStrLn stderr msg + Left (GMECabalConfigure msg) -> + hPutStrLn stderr $ "cabal configure failed: " ++ msg 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 f651a3a..36d2696 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -- Commands: -- check @@ -25,7 +25,8 @@ import Control.Exception (SomeException(..), Exception) import qualified Control.Exception as E import Control.Monad (when, void) import CoreMonad (liftIO) -import Data.List (find) +import Data.List (find, intercalate) +import Data.List.Split (splitOn) import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S @@ -38,6 +39,7 @@ import System.Console.GetOpt import System.Directory (setCurrentDirectory) import System.Environment (getArgs) import System.IO (hFlush,stdout) +import System.Exit (ExitCode, exitFailure) import Utils @@ -93,7 +95,7 @@ main = E.handle cmdHandler $ cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec go (_,"help":_) = putStr $ usageInfo usage argspec go (_,"version":_) = putStr progVersion - go (opt,_) = E.handle someHandler $ do + go (opt,_) = flip E.catches handlers $ do cradle0 <- findCradle let rootdir = cradleRootDir cradle0 -- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? @@ -104,17 +106,29 @@ main = E.handle cmdHandler $ case res of Right () -> return () - Left e -> error $ show e + Left (GMECabalConfigure msg) -> do + putStrLn $ notGood $ "cabal configure failed: " ++ msg + exitFailure + Left e -> bug $ show e where -- this is just in case. -- If an error is caught here, it is a bug of GhcMod library. - someHandler (SomeException e) = do - putStrLn $ "NG " ++ replace (show e) + handlers = [ E.Handler (\(_ :: ExitCode) -> return ()) + , E.Handler (\(SomeException e) -> bug $ show e) ] -replace :: String -> String -replace [] = [] -replace ('\n':xs) = ';' : replace xs -replace (x:xs) = x : replace xs +bug :: String -> IO () +bug msg = do + putStrLn $ notGood $ "BUG: " ++ msg + exitFailure + +notGood :: String -> String +notGood msg = "NG " ++ escapeNewlines msg + +escapeNewlines :: String -> String +escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" + +replace :: String -> String -> String -> String +replace needle replacement = intercalate replacement . splitOn needle ---------------------------------------------------------------- @@ -147,7 +161,7 @@ loop set mvar = do liftIO $ putStr ret liftIO $ putStrLn "OK" else do - liftIO $ putStrLn $ "NG " ++ replace ret + liftIO $ putStrLn $ notGood ret liftIO $ hFlush stdout when ok $ loop set' mvar diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index a43488d..b430226 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -34,7 +34,7 @@ spec = do withDirectory "test/data/subdir1/subdir2" $ \dir -> do cradle <- findCradle pkgDesc <- runD $ parseCabalFile $ fromJust $ cradleCabalFile cradle - res <- getCompilerOptions [] cradle pkgDesc + res <- runD $ getCompilerOptions [] cradle pkgDesc let res' = res { ghcOptions = ghcOptions res , includeDirs = map (toRelativeDir dir) (includeDirs res) diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs index 75f61cc..a8e193c 100644 --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -1,6 +1,9 @@ module UtilsSpec where import Language.Haskell.GhcMod.Utils +import System.IO.Error +import Control.Exception +import TestUtils import Test.Hspec spec :: Spec @@ -9,3 +12,11 @@ spec = do it "extracts the part of a string surrounded by parentheses" $ do extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )" extractParens "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")][][]" `shouldBe` "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")]" + + describe "liftMonadError" $ do + it "converts IOErrors to GhcModError" $ do + shouldReturnError $ + runD' $ liftMonadError $ throw (userError "hello") >> return "" + + shouldReturnError $ + runD' $ liftMonadError $ readFile "/DOES_NOT_EXIST" >> return ""