Upgrade to Cabal 2.0

ChangeLog.md

@@ -11,6 +11,7 @@ Major changes:
   details, please see
   [the writeup on these changes](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots). [PR #3249](https://github.com/commercialhaskell/stack/pull/3249),
   see the PR description for a number of related issues.
+* Upgraded to version 2.0 of the Cabal library.
 
 Behavior changes:
 

Setup.hs

@@ -3,8 +3,7 @@ module Main (main) where
 
 import Data.List ( nub, sortBy )
 import Data.Ord ( comparing )
-import Data.Version ( showVersion )
-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )
+import Distribution.Package ( PackageId, InstalledPackageId, packageVersion, packageName )
 import Distribution.PackageDescription ( PackageDescription(), Executable(..) )
 import Distribution.InstalledPackageInfo (sourcePackageId, installedPackageId)
 import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
@@ -13,7 +12,10 @@ import Distribution.Simple.BuildPaths ( autogenModulesDir )
 import Distribution.Simple.PackageIndex (allPackages, dependencyClosure)
 import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )
 import Distribution.Simple.LocalBuildInfo ( installedPkgs, withLibLBI, withExeLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
+import Distribution.Types.PackageName (PackageName, unPackageName)
+import Distribution.Types.UnqualComponentName (unUnqualComponentName)
 import Distribution.Verbosity ( Verbosity )
+import Distribution.Version ( showVersion )
 import System.FilePath ( (</>) )
 
 main :: IO ()
@@ -29,27 +31,28 @@ generateBuildModule verbosity pkg lbi = do
   createDirectoryIfMissingVerbose verbosity True dir
   withLibLBI pkg lbi $ \_ libcfg -> do
     withExeLBI pkg lbi $ \exe clbi ->
-      rewriteFile (dir </> "Build_" ++ exeName exe ++ ".hs") $ unlines
-        [ "module Build_" ++ exeName exe ++ " where"
+      rewriteFile (dir </> "Build_" ++ exeName' exe ++ ".hs") $ unlines
+        [ "module Build_" ++ exeName' exe ++ " where"
         , ""
         , "deps :: [String]"
         , "deps = " ++ (show $ formatdeps (transDeps libcfg clbi))
         ]
   where
+    exeName' = unUnqualComponentName . exeName
     formatdeps = map formatone . sortBy (comparing unPackageName')
     formatone p = unPackageName' p ++ "-" ++ showVersion (packageVersion p)
-    unPackageName' p = case packageName p of PackageName n -> n
+    unPackageName' = unPackageName . packageName
     transDeps xs ys =
       either (map sourcePackageId . allPackages) handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds
       where
         allInstPkgsIdx = installedPkgs lbi
         allInstPkgIds = map installedPackageId $ allPackages allInstPkgsIdx
         -- instPkgIds includes `stack-X.X.X`, which is not a depedency hence is missing from allInstPkgsIdx. Filter that out.
-        availInstPkgIds = filter (`elem` allInstPkgIds) . map fst $ testDeps xs ys
+        availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys
         handleDepClosureFailure unsatisfied =
           error $
             "Computation of transitive dependencies failed." ++
             if null unsatisfied then "" else " Unresolved dependencies: " ++ show unsatisfied
 
-testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [InstalledPackageId]
+testDeps xs ys = map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys

src/Stack/Build/ConstructPlan.hs

@@ -790,7 +790,7 @@ packageDepsWithTools p = do
     ctx <- ask
     -- TODO: it would be cool to defer these warnings until there's an
     -- actual issue building the package.
-    let toEither (Cabal.Dependency (Cabal.PackageName name) _) mp =
+    let toEither (Cabal.Dependency (Cabal.unPackageName -> name) _) mp =
             case Map.toList mp of
                 [] -> Left (NoToolFound name (packageName p))
                 [_] -> Right mp

src/Stack/BuildPlan.hs

@@ -44,6 +44,7 @@ import           Distribution.PackageDescription (GenericPackageDescription,
                                                   flagName, genPackageFlags,
                                                   condExecutables)
 import qualified Distribution.PackageDescription as C
+import qualified Distribution.Types.UnqualComponentName as C
 import           Distribution.System (Platform)
 import           Distribution.Text (display)
 import qualified Distribution.Version as C
@@ -186,7 +187,7 @@ getToolMap ls locals =
     -- worse case scenario is we build an extra package that wasn't
     -- strictly needed.
     gpdExes :: GenericPackageDescription -> [Text]
-    gpdExes = map (T.pack . fst) . condExecutables
+    gpdExes = map (T.pack . C.unUnqualComponentName . fst) . condExecutables
 
 gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
 gpdPackages gpds = Map.fromList $

src/Stack/Config.hs

@@ -58,9 +58,10 @@ import qualified Data.Text as T
 import           Data.Text.Encoding (encodeUtf8)
 import qualified Data.Yaml as Yaml
 import qualified Distribution.PackageDescription as C
+import qualified Distribution.Types.UnqualComponentName as C
 import           Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch))
 import qualified Distribution.Text
-import           Distribution.Version (simplifyVersionRange)
+import           Distribution.Version (simplifyVersionRange, mkVersion')
 import           GHC.Conc (getNumProcessors)
 import           Lens.Micro (lens)
 import           Network.HTTP.Client (parseUrlThrow)
@@ -471,7 +472,7 @@ loadConfigMaybeProject configArgs mresolver mproject = do
           LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs
           LCSProject project -> loadHelper $ Just project
           LCSNoProject -> loadHelper Nothing
-    unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)
+    unless (fromCabalVersion (mkVersion' Meta.version) `withinRange` configRequireStackVersion config)
         (throwM (BadStackVersionException (configRequireStackVersion config)))
 
     let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject
@@ -687,9 +688,9 @@ getLocalPackages = do
         ]
       where
         go :: (T.Text -> NamedComponent)
-           -> (C.GenericPackageDescription -> [String])
+           -> (C.GenericPackageDescription -> [C.UnqualComponentName])
            -> [NamedComponent]
-        go wrapper f = map (wrapper . T.pack) $ f gpkg
+        go wrapper f = map (wrapper . T.pack . C.unUnqualComponentName) $ f gpkg
 
 -- | Check if there are any duplicate package names and, if so, throw an
 -- exception.

src/Stack/Init.hs

@@ -293,7 +293,7 @@ renderStackYaml p ignoredPackages dupPackages =
 
     footerHelp =
         let major = toCabalVersion
-                    $ toMajorVersion $ fromCabalVersion Meta.version
+                    $ toMajorVersion $ fromCabalVersion $ C.mkVersion' Meta.version
         in commentHelp
         [ "Control whether we use the GHC we find on the path"
         , "system-ghc: true"

src/Stack/Options/Completion.hs

@@ -18,6 +18,7 @@ import           Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Distribution.PackageDescription as C
+import qualified Distribution.Types.UnqualComponentName as C
 import           Options.Applicative
 import           Options.Applicative.Builder.Extra
 import           Stack.Config (getLocalPackages)
@@ -89,8 +90,8 @@ flagCompleter = buildConfigCompleter $ \input -> do
                     (C.genPackageFlags (lpvGPD lpv)))
             $ Map.toList lpvs
         flagString name fl =
-            case C.flagName fl of
-                C.FlagName flname -> (if flagEnabled name fl then "-" else "") ++ flname
+            let flname = C.unFlagName $ C.flagName fl
+             in (if flagEnabled name fl then "-" else "") ++ flname
         flagEnabled name fl =
             fromMaybe (C.flagDefault fl) $
             Map.lookup (fromCabalFlagName (C.flagName fl)) $
@@ -107,5 +108,5 @@ projectExeCompleter = buildConfigCompleter $ \input -> do
     return $
         filter (input `isPrefixOf`) $
         nubOrd $
-        concatMap (\(_, lpv) -> map fst (C.condExecutables (lpvGPD lpv))) $
+        concatMap (\(_, lpv) -> map (C.unUnqualComponentName . fst) (C.condExecutables (lpvGPD lpv))) $
         Map.toList lpvs

src/Stack/Package.hs

@@ -51,7 +51,6 @@ import qualified Data.Set as S
 import qualified Data.Text as T
 import           Data.Text.Encoding (decodeUtf8, decodeUtf8With)
 import           Data.Text.Encoding.Error (lenientDecode)
-import           Data.Version (showVersion)
 import           Distribution.Compiler
 import           Distribution.ModuleName (ModuleName)
 import qualified Distribution.ModuleName as Cabal
@@ -65,7 +64,13 @@ import           Distribution.ParseUtils
 import           Distribution.Simple.Utils
 import           Distribution.System (OS (..), Arch, Platform (..))
 import qualified Distribution.Text as D
+import qualified Distribution.Types.CondTree as Cabal
+import qualified Distribution.Types.Dependency as Cabal
+import qualified Distribution.Types.ExeDependency as Cabal
+import qualified Distribution.Types.LegacyExeDependency as Cabal
+import qualified Distribution.Types.UnqualComponentName as Cabal
 import qualified Distribution.Verbosity as D
+import           Distribution.Version (showVersion)
 import qualified Hpack
 import qualified Hpack.Config as Hpack
 import           Path as FL
@@ -115,7 +120,7 @@ readPackageUnresolvedBS mcabalfp bs =
 rawParseGPD :: BS.ByteString
             -> Either PError ([PWarning], GenericPackageDescription)
 rawParseGPD bs =
-    case parsePackageDescription chars of
+    case parseGenericPackageDescription chars of
        ParseFailed per -> Left per
        ParseOk warnings gpkg -> Right (warnings,gpkg)
   where
@@ -215,21 +220,24 @@ packageFromPackageDescription packageConfig pkgFlags pkg =
     , packageLicense = license pkg
     , packageDeps = deps
     , packageFiles = pkgFiles
-    , packageTools = packageDescTools pkg
+    , packageTools = map
+        (\(Cabal.ExeDependency name' _ range) -> Cabal.Dependency name' range)
+        (packageDescTools pkg)
     , packageGhcOptions = packageConfigGhcOptions packageConfig
     , packageFlags = packageConfigFlags packageConfig
     , packageDefaultFlags = M.fromList
       [(fromCabalFlagName (flagName flag), flagDefault flag) | flag <- pkgFlags]
     , packageAllDeps = S.fromList (M.keys deps)
     , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg)
     , packageTests = M.fromList
-      [(T.pack (testName t), testInterface t) | t <- testSuites pkg
+      [(T.pack (Cabal.unUnqualComponentName $ testName t), testInterface t) | t <- testSuites pkg
                                               , buildable (testBuildInfo t)]
     , packageBenchmarks = S.fromList
-      [T.pack (benchmarkName biBuildInfo) | biBuildInfo <- benchmarks pkg
+      [T.pack (Cabal.unUnqualComponentName $ benchmarkName biBuildInfo) | biBuildInfo <- benchmarks pkg
                                           , buildable (benchmarkBuildInfo biBuildInfo)]
     , packageExes = S.fromList
-      [T.pack (exeName biBuildInfo) | biBuildInfo <- executables pkg
+      [T.pack (Cabal.unUnqualComponentName $ exeName biBuildInfo)
+        | biBuildInfo <- executables pkg
                                     , buildable (buildInfo biBuildInfo)]
     -- This is an action used to collect info needed for "stack ghci".
     -- This info isn't usually needed, so computation of it is deferred.
@@ -336,19 +344,19 @@ generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componen
                    , fmap
                          (\exe ->
                                generate
-                                    (CExe (T.pack (exeName exe)))
+                                    (CExe (T.pack (Cabal.unUnqualComponentName (exeName exe))))
                                     (buildInfo exe))
                          (executables pkg)
                    , fmap
                          (\bench ->
                                generate
-                                    (CBench (T.pack (benchmarkName bench)))
+                                    (CBench (T.pack (Cabal.unUnqualComponentName (benchmarkName bench))))
                                     (benchmarkBuildInfo bench))
                          (benchmarks pkg)
                    , fmap
                          (\test ->
                                generate
-                                    (CTest (T.pack (testName test)))
+                                    (CTest (T.pack (Cabal.unUnqualComponentName (testName test))))
                                     (testBuildInfo test))
                          (testSuites pkg)]))
   where
@@ -529,13 +537,13 @@ packageDependencies pkg =
 packageToolDependencies :: PackageDescription -> Map Text VersionRange
 packageToolDependencies =
   M.fromList .
-  concatMap (fmap (packageNameText . depName &&& depRange) .
+  concatMap (fmap (\(Cabal.LegacyExeDependency name range) -> (T.pack name, range)) .
              buildTools) .
   allBuildInfo'
 
 -- | Get all dependencies of the package (buildable targets only).
-packageDescTools :: PackageDescription -> [Dependency]
-packageDescTools = concatMap buildTools . allBuildInfo'
+packageDescTools :: PackageDescription -> [Cabal.ExeDependency]
+packageDescTools = concatMap buildToolDepends . allBuildInfo'
 
 -- | This is a copy-paste from Cabal's @allBuildInfo@ function, but with the
 -- @buildable@ test removed. The implementation is broken.
@@ -549,12 +557,10 @@ allBuildInfo' pkg_descr = [ bi | Just lib <- [library pkg_descr]
                               , True || buildable bi ]
                       ++ [ bi | tst <- testSuites pkg_descr
                               , let bi = testBuildInfo tst
-                              , True || buildable bi
-                              , testEnabled tst ]
+                              , True || buildable bi ]
                       ++ [ bi | tst <- benchmarks pkg_descr
                               , let bi = benchmarkBuildInfo tst
-                              , True || buildable bi
-                              , benchmarkEnabled tst ]
+                              , True || buildable bi ]
 
 -- | Get all files referenced by the package.
 packageDescModulesAndFiles
@@ -594,9 +600,9 @@ packageDescModulesAndFiles pkg = do
     return (modules, files, dfiles, warnings)
   where
     libComponent = const CLib
-    exeComponent = CExe . T.pack . exeName
-    testComponent = CTest . T.pack . testName
-    benchComponent = CBench . T.pack . benchmarkName
+    exeComponent = CExe . T.pack . Cabal.unUnqualComponentName . exeName
+    testComponent = CTest . T.pack . Cabal.unUnqualComponentName . testName
+    benchComponent = CBench . T.pack . Cabal.unUnqualComponentName . benchmarkName
     asModuleAndFileMap label f lib = do
         (a,b,c) <- f lib
         return (M.singleton (label lib) a, M.singleton (label lib) b, c)
@@ -649,7 +655,7 @@ resolveGlobFiles =
 --
 matchDirFileGlob_ :: (MonadLogger m, MonadIO m) => String -> String -> m [String]
 matchDirFileGlob_ dir filepath = case parseFileGlob filepath of
-  Nothing -> liftIO $ die $
+  Nothing -> liftIO $ throwString $
       "invalid file glob '" ++ filepath
       ++ "'. Wildcards '*' are only allowed in place of the file"
       ++ " name, not in the directory name or file extension."
@@ -679,7 +685,7 @@ benchmarkFiles bench = do
     dir <- asks (parent . fst)
     (modules,files,warnings) <-
         resolveFilesAndDeps
-            (Just $ benchmarkName bench)
+            (Just $ Cabal.unUnqualComponentName $ benchmarkName bench)
             (dirs ++ [dir])
             (bnames <> exposed)
             haskellModuleExts
@@ -703,7 +709,7 @@ testFiles test = do
     dir <- asks (parent . fst)
     (modules,files,warnings) <-
         resolveFilesAndDeps
-            (Just $ testName test)
+            (Just $ Cabal.unUnqualComponentName $ testName test)
             (dirs ++ [dir])
             (bnames <> exposed)
             haskellModuleExts
@@ -728,7 +734,7 @@ executableFiles exe = do
     dir <- asks (parent . fst)
     (modules,files,warnings) <-
         resolveFilesAndDeps
-            (Just $ exeName exe)
+            (Just $ Cabal.unUnqualComponentName $ exeName exe)
             (dirs ++ [dir])
             (map DotCabalModule (otherModules build) ++
              [DotCabalMain (modulePath exe)])
@@ -780,7 +786,7 @@ targetJsSources = jsSources
 resolvePackageDescription :: PackageConfig
                           -> GenericPackageDescription
                           -> PackageDescription
-resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib exes tests benches) =
+resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib _subLibs _foreignLibs exes tests benches) =
   desc {library =
           fmap (resolveConditions rc updateLibDeps) mlib
        ,executables =
@@ -809,12 +815,18 @@ resolvePackageDescription packageConfig (GenericPackageDescription desc defaultF
                  (buildInfo exe) {targetBuildDepends = deps}}
         updateTestDeps test deps =
           test {testBuildInfo =
-                  (testBuildInfo test) {targetBuildDepends = deps}
-               ,testEnabled = packageConfigEnableTests packageConfig}
+                  (testBuildInfo test)
+                    { targetBuildDepends = deps
+                    , buildable = packageConfigEnableTests packageConfig
+                    }
+               }
         updateBenchmarkDeps benchmark deps =
           benchmark {benchmarkBuildInfo =
-                       (benchmarkBuildInfo benchmark) {targetBuildDepends = deps}
-                    ,benchmarkEnabled = packageConfigEnableBenchmarks packageConfig}
+                       (benchmarkBuildInfo benchmark)
+                         { targetBuildDepends = deps
+                         , buildable = packageConfigEnableBenchmarks packageConfig
+                         }
+                    }
 
 -- | Make a map from a list of flag specifications.
 --
@@ -852,7 +864,7 @@ resolveConditions :: (Monoid target,Show target)
 resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children
   where basic = addDeps lib deps
         children = mconcat (map apply cs)
-          where apply (cond,node,mcs) =
+          where apply (Cabal.CondBranch cond node mcs) =
                   if condSatisfied cond
                      then resolveConditions rc addDeps node
                      else maybe mempty (resolveConditions rc addDeps) mcs
@@ -1254,10 +1266,10 @@ cabalFilePackageId
     :: (MonadIO m, MonadThrow m)
     => Path Abs File -> m PackageIdentifier
 cabalFilePackageId fp = do
-    pkgDescr <- liftIO (D.readPackageDescription D.silent $ toFilePath fp)
+    pkgDescr <- liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp)
     (toStackPI . D.package . D.packageDescription) pkgDescr
   where
-    toStackPI (D.PackageIdentifier (D.PackageName name) ver) = do
+    toStackPI (D.PackageIdentifier (D.unPackageName -> name) ver) = do
         name' <- parsePackageNameFromString name
         ver' <- parseVersionFromString (showVersion ver)
         return (PackageIdentifier name' ver')

src/Stack/Setup.hs

@@ -62,6 +62,7 @@ import qualified    Data.Yaml as Yaml
 import              Distribution.System (OS (Linux), Arch (..), Platform (..))
 import qualified    Distribution.System as Cabal
 import              Distribution.Text (simpleParse)
+import              Distribution.Version (mkVersion')
 import              Lens.Micro (set)
 import              Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode)
 import              Network.HTTP.Download
@@ -1904,4 +1905,4 @@ getDownloadVersion (StackReleaseInfo val) = do
     parseVersion $ T.drop 1 rawName
 
 stackVersion :: Version
-stackVersion = fromCabalVersion Meta.version
+stackVersion = fromCabalVersion (mkVersion' Meta.version)