diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index e312488..4978d65 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -11,14 +11,16 @@ module Language.Haskell.GhcMod.CabalApi ( ) where import Language.Haskell.GhcMod.CabalConfig -import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, toModuleString) +import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, + toModuleString) import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Types import Control.Applicative ((<$>)) import qualified Control.Exception as E import Control.Monad (filterM) -import CoreMonad (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Error.Class (MonadError(..)) import Data.Maybe (maybeToList) import Data.Set (fromList, toList) import Distribution.Package (Dependency(Dependency) @@ -71,17 +73,20 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir]) -- | Parsing a cabal file and returns 'PackageDescription'. -- 'IOException' is thrown if parsing fails. -parseCabalFile :: FilePath -> IO PackageDescription +parseCabalFile :: (MonadIO m, MonadError GhcModError m) + => FilePath + -> m PackageDescription parseCabalFile file = do - cid <- getGHCId - epgd <- readPackageDescription silent file + cid <- liftIO $ getGHCId + epgd <- liftIO $ readPackageDescription silent file case toPkgDesc cid epgd of - Left deps -> E.throwIO $ userError $ show deps ++ " are not installed" + Left deps -> throwError $ GMECabal $ show deps ++ " are not installed" Right (pd,_) -> if nullPkg pd - then E.throwIO $ userError $ file ++ " is broken" + then throwError $ GMECabal $ file ++ " is broken" else return pd where - toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid [] + toPkgDesc cid = + finalizePackageDescription [] (const True) buildPlatform cid [] nullPkg pd = name == "" where PackageName name = C.pkgName (P.package pd) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index d9cd186..82685f3 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -31,9 +31,9 @@ debugInfo = cradle >>= \c -> convert' =<< do where simpleCompilerOption = options >>= \op -> return $ CompilerOptions (ghcOpts op) [] [] - fromCabalFile c = options >>= \opts -> liftIO $ do + fromCabalFile c = options >>= \opts -> do pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c - getCompilerOptions (ghcOpts opts) c pkgDesc + liftIO $ getCompilerOptions (ghcOpts opts) c pkgDesc ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 6df8380..3b99b1a 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -187,7 +187,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 +initializeFlagsWithCradle :: (GhcMonad m, MonadError GhcModError m) => Options -> Cradle -> m () @@ -199,7 +199,7 @@ initializeFlagsWithCradle opt c cabal = isJust mCradleFile ghcopts = ghcOpts opt withCabal = do - pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile + pkgDesc <- parseCabalFile $ fromJust mCradleFile compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc initSession CabalPkg opt compOpts withSandbox = initSession SingleFile opt compOpts diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index d7b1d13..a43488d 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -13,6 +13,7 @@ import System.Directory import System.FilePath import Dir +import TestUtils import Config (cProjectVersionInt) -- ghc version @@ -23,14 +24,16 @@ spec :: Spec spec = do describe "parseCabalFile" $ do it "throws an exception if the cabal file is broken" $ do - parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True) + shouldReturnError $ + runD' $ parseCabalFile "test/data/broken-cabal/broken.cabal" + describe "getCompilerOptions" $ do it "gets necessary CompilerOptions" $ do cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do cradle <- findCradle - pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle + pkgDesc <- runD $ parseCabalFile $ fromJust $ cradleCabalFile cradle res <- getCompilerOptions [] cradle pkgDesc let res' = res { ghcOptions = ghcOptions res @@ -45,18 +48,18 @@ spec = do describe "cabalDependPackages" $ do it "extracts dependent packages" $ do - pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" + pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal") pkgs `shouldBe` ["Cabal","base","template-haskell"] describe "cabalSourceDirs" $ do it "extracts all hs-source-dirs" $ do - dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal" + dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal") dirs `shouldBe` ["src", "test"] it "extracts all hs-source-dirs including \".\"" $ do - dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" + dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal") dirs `shouldBe` [".", "test"] describe "cabalAllBuildInfo" $ do it "extracts build info" $ do - info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" + info <- cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal") show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]" diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs index 74404f1..938f763 100644 --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -3,6 +3,7 @@ module MonadSpec where import Test.Hspec import Dir +import TestUtils import Control.Applicative import Control.Monad.Error.Class import Language.Haskell.GhcMod.Types @@ -23,5 +24,4 @@ spec = do describe "runGhcModT" $ it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do - (a,_) <- runGhcModT defaultOptions (gmCradle <$> ask) - a `shouldSatisfy` (\(Left _) -> True) + shouldReturnError $ runD' (gmCradle <$> ask) diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 02ce0e3..4732ffe 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,10 +1,12 @@ module TestUtils ( run , runD + , runD' , runI , runID , runIsolatedGhcMod , isolateCradle + , shouldReturnError , module Language.Haskell.GhcMod.Monad , module Language.Haskell.GhcMod.Types ) where @@ -12,6 +14,8 @@ module TestUtils ( import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types +import Test.Hspec + isolateCradle :: IOish m => GhcModT m a -> GhcModT m a isolateCradle action = local modifyEnv $ action @@ -42,3 +46,16 @@ run opt a = extract $ runGhcModT opt a -- | Run GhcMod with default options runD :: GhcModT IO a -> IO a runD = extract . runGhcModT defaultOptions + +runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog) +runD' = runGhcModT defaultOptions + +shouldReturnError :: Show a + => IO (Either GhcModError a, GhcModLog) + -> Expectation +shouldReturnError action = do + (a,_) <- action + a `shouldSatisfy` isLeft + where + isLeft (Left _) = True + isLeft _ = False