Fix reading of older Cabal setup-configs

Language/Haskell/GhcMod/Cabal16.hs

@@ -0,0 +1,13 @@
+-- | ComponentLocalBuildInfo for Cabal <= 1.16
+module Language.Haskell.GhcMod.Cabal16 (
+    ComponentLocalBuildInfo
+  , componentPackageDeps
+  ) where
+
+import Distribution.Package (InstalledPackageId, PackageIdentifier)
+
+-- From Cabal <= 1.16
+data ComponentLocalBuildInfo = ComponentLocalBuildInfo {
+    componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)]
+  }
+  deriving (Read, Show)

Language/Haskell/GhcMod/Cabal18.hs

@@ -0,0 +1,7 @@
+-- | ComponentLocalBuildInfo for Cabal >= 1.18
+module Language.Haskell.GhcMod.Cabal18 (
+    ComponentLocalBuildInfo
+  , componentPackageDeps
+  ) where
+
+import Distribution.Simple.LocalBuildInfo (ComponentLocalBuildInfo(..))

Language/Haskell/GhcMod/CabalApi.hs

@@ -7,13 +7,12 @@ module Language.Haskell.GhcMod.CabalApi (
   , cabalDependPackages
   , cabalSourceDirs
   , cabalAllTargets
-  , cabalGetConfig
-  , cabalConfigPath
   , cabalConfigDependencies
   ) where
 
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.CabalConfig
 import Language.Haskell.GhcMod.Utils
 
 import Control.Applicative ((<$>))
@@ -39,13 +38,14 @@ import Distribution.Simple.Program (ghcProgram)
 import Distribution.Simple.Program.Types (programName, programFindVersion)
 import Distribution.Simple.BuildPaths (defaultDistPref)
 import Distribution.Simple.Configure (localBuildInfoFile)
-import Distribution.Simple.LocalBuildInfo (ComponentLocalBuildInfo(..), ComponentName)
+import Distribution.Simple.LocalBuildInfo (ComponentName)
 import Distribution.System (buildPlatform)
 import Distribution.Text (display)
 import Distribution.Verbosity (silent)
 import Distribution.Version (Version)
 import System.Directory (doesFileExist)
 import System.FilePath ((</>))
+import Text.Read (readMaybe)
 ----------------------------------------------------------------
 
 -- | Getting necessary 'CompilerOptions' from three information sources.
@@ -55,7 +55,7 @@ getCompilerOptions :: [GHCOption]
                    -> IO CompilerOptions
 getCompilerOptions ghcopts cradle pkgDesc = do
     gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos
-    depPkgs <- cabalConfigDependencies (C.packageId pkgDesc) <$> cabalGetConfig cradle
+    depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)
     return $ CompilerOptions gopts idirs depPkgs
   where
     wdir       = cradleCurrentDir cradle
@@ -205,88 +205,3 @@ cabalAllTargets pd = do
     getExecutableTarget exe = do
       let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]
       liftIO $ filterM doesFileExist maybeExes
-
-----------------------------------------------------------------
-
-type CabalConfig = String
-
--- | Get file containing 'LocalBuildInfo' data. If it doesn't exist run @cabal
--- configure@ i.e. configure with default options like @cabal build@ would do.
-cabalGetConfig :: Cradle -> IO CabalConfig
-cabalGetConfig cradle =
-    readFile path `E.catch` (\(SomeException _) -> configure >> readFile path)
- where
-   prjDir = cradleRootDir cradle
-   path = prjDir </> cabalConfigPath
-   configure =
-     withDirectory_ prjDir $ readProcess' "cabal" ["configure"]
-
-
--- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
-cabalConfigPath :: FilePath
-cabalConfigPath = localBuildInfoFile defaultDistPref
-
-cabalConfigDependencies :: PackageIdentifier -> CabalConfig -> [Package]
-cabalConfigDependencies thisPkg config = cfgDepends
- where
-    pids :: [InstalledPackageId]
-    pids = let
-      mps = map fst <$> (components18 thisPkg `mplus` components16 thisPkg)
-      in case mps of
-        Just ps -> ps
-        Nothing -> errorExtract
-    cfgDepends = filter (("inplace" /=) . pkgId)
-                   $ fromInstalledPackageId <$> pids
-
-    errorExtract = error $
-       "cabalConfigDependencies: Error extracting dependencies from setup-config"
-
-    -- Cabal 1.18
-    components18 :: PackageIdentifier
-                 -> Maybe [(InstalledPackageId,PackageIdentifier)]
-    components18 _ =
-          concatMap (componentPackageDeps . lbi)
-      <$> extractCabalSetupConfig config "componentsConfigs"
-
-    lbi :: (ComponentName, ComponentLocalBuildInfo, [ComponentName])
-        -> ComponentLocalBuildInfo
-    lbi (_,i,_) = i
-
-    -- Cabal 1.16 and below
-    components16 :: PackageIdentifier
-                 -> Maybe [(InstalledPackageId,PackageIdentifier)]
-    components16 thisPkg' = filter (not . internal . snd) . nub <$> do
-        cbi <- concat <$> sequence [ extract "executableConfigs"
-                                   , extract "testSuiteConfigs"
-                                   , extract "benchmarkConfigs" ]
-                                  :: Maybe [(String, ComponentLocalBuildInfo)]
-
-        return $ maybe [] componentPackageDeps libraryConfig
-              ++ concatMap (componentPackageDeps . snd) cbi
-     where
-       -- True if this dependency is an internal one (depends on the library
-       -- defined in the same package).
-       internal pkgid = pkgid == thisPkg'
-
-       libraryConfig :: Maybe ComponentLocalBuildInfo
-       libraryConfig = do
-         field <- find ("libraryConfig" `isPrefixOf`) (tails config)
-         clbi <- stripPrefix " = " field
-         if "Nothing" `isPrefixOf` clbi
-             then Nothing
-             else read <$> stripPrefix "Just " clbi
-
-       extract :: Read r => String -> Maybe r
-       extract field = extractCabalSetupConfig config field
-
--- | Extract part of cabal's @setup-config@, this is done with a mix of manual
--- string processing and use of 'read'. This way we can extract a field from
--- 'LocalBuildInfo' without having to parse the whole thing which would mean
--- depending on the exact version of Cabal used to configure the project as it
--- is rather likley that some part of 'LocalBuildInfo' changed.
---
--- Right now 'extractCabalSetupConfig' can only deal with Lists and Tuples in
--- the field!
-extractCabalSetupConfig :: (Read r) => CabalConfig -> String -> Maybe r
-extractCabalSetupConfig config field = do
-    read <$> extractParens <$> find (field `isPrefixOf`) (tails config)

Language/Haskell/GhcMod/CabalConfig.hs

@@ -0,0 +1,118 @@
+-- | Reading cabal @dist/setup-config@
+module Language.Haskell.GhcMod.CabalConfig (
+    CabalConfig
+  , cabalConfigDependencies
+  ) where
+
+import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.Types
+
+import qualified Language.Haskell.GhcMod.Cabal16 as C16
+import qualified Language.Haskell.GhcMod.Cabal18 as C18
+
+import qualified Control.Exception as E
+import Control.Applicative ((<$>))
+import Control.Monad (filterM,mplus)
+import Control.Monad.Error ()
+import Data.Maybe ()
+import Data.Set ()
+import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
+import Distribution.Package (PackageName(PackageName)
+                           , InstalledPackageId(..)
+                           , PackageIdentifier)
+import qualified Distribution.Package as C
+import Distribution.Simple.BuildPaths (defaultDistPref)
+import Distribution.Simple.Configure (localBuildInfoFile)
+import Distribution.Simple.LocalBuildInfo (ComponentName)
+import System.FilePath ((</>))
+import Text.Read (readMaybe)
+----------------------------------------------------------------
+
+type CabalConfig = String
+
+-- | Get 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)
+ where
+   prjDir = cradleRootDir cradle
+   path = prjDir </> configPath
+   configure =
+     withDirectory_ prjDir $ readProcess' "cabal" ["configure"]
+
+
+-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
+configPath :: FilePath
+configPath = localBuildInfoFile defaultDistPref
+
+cabalConfigDependencies :: Cradle -> PackageIdentifier -> IO [Package]
+cabalConfigDependencies cradle thisPkg =
+    configDependencies thisPkg <$> getConfig cradle
+
+configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
+configDependencies thisPkg config = map fromInstalledPackageId deps
+ where
+    deps :: [InstalledPackageId]
+    deps = case (deps18 `mplus` deps16) of
+        Right ps -> ps
+        Left msg -> error msg
+
+--    errorExtract = error $
+--     "cabalConfigDependencies: Error extracting dependencies from setup-config"
+
+    -- Cabal >= 1.18
+    deps18 :: Either String [InstalledPackageId]
+    deps18 =
+          concatMap (map fst . C18.componentPackageDeps . lbi)
+      <$> (readEither =<< extractField config "componentsConfigs")
+
+    lbi :: (ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])
+        -> C18.ComponentLocalBuildInfo
+    lbi (_,i,_) = i
+
+    -- Cabal 1.16 and below
+    deps16 :: Either String [InstalledPackageId]
+    deps16 = map fst <$> filter (not . internal . snd) . nub <$> do
+        cbi <- concat <$> sequence [ extract "executableConfigs"
+                                   , extract "testSuiteConfigs"
+                                   , extract "benchmarkConfigs" ]
+                        :: Either String [(String, C16.ComponentLocalBuildInfo)]
+
+        return $ maybe [] C16.componentPackageDeps libraryConfig
+              ++ concatMap (C16.componentPackageDeps . snd) cbi
+     where
+       -- True if this dependency is an internal one (depends on the library
+       -- defined in the same package).
+       internal pkgid = pkgid == thisPkg
+
+       libraryConfig :: Maybe C16.ComponentLocalBuildInfo
+       libraryConfig = do
+         field <- find ("libraryConfig" `isPrefixOf`) (tails config)
+         clbi <- stripPrefix " = " field
+         if "Nothing" `isPrefixOf` clbi
+             then Nothing
+             else case readMaybe <$> stripPrefix "Just " clbi of
+                    Just x -> x
+                    Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)
+
+       extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]
+       extract field = readConfigs field <$> extractField config field
+
+       readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]
+       readConfigs f s = case readMaybe s of
+           Just x -> x
+           Nothing -> error $ "reading config " ++ f ++ " failed"
+
+
+readEither :: Read r => String -> Either String r
+readEither s = case readMaybe s of
+    Just x -> Right x
+    Nothing -> Left $ "read: failed on input:\n" ++ s
+
+extractField :: CabalConfig -> String -> Either String String
+extractField config field =
+    case extractParens <$> find (field `isPrefixOf`) (tails config) of
+        Just f -> Right f
+        Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)

ghc-mod.cabal

@@ -58,6 +58,9 @@ Library
   Other-Modules:        Language.Haskell.GhcMod.Boot
                         Language.Haskell.GhcMod.Browse
                         Language.Haskell.GhcMod.CabalApi
+                        Language.Haskell.GhcMod.CabalConfig
+                        Language.Haskell.GhcMod.Cabal16
+                        Language.Haskell.GhcMod.Cabal18
                         Language.Haskell.GhcMod.Check
                         Language.Haskell.GhcMod.Cradle
                         Language.Haskell.GhcMod.Debug

test/CabalApiSpec.hs

@@ -60,10 +60,3 @@ spec = do
         it "extracts build info" $ do
             info <- cabalAllBuildInfo <$> 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 = []})))]}]"
-
-    describe "cabalGetConfig" $ do
-        it "can reconfigure a cabal package" $ do
-            withDirectory_ "test/data/check-test-subdir" $ do
-                cradle <- findCradle
-                cfg <- cabalGetConfig cradle
-                cfg `shouldSatisfy` not . null