Merge pull request #3288 from commercialhaskell/cabal-2

Upgrade to Cabal 2.0

Author: snoyberg

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

@@ -30,7 +30,6 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Data.Text.Encoding (decodeUtf8With)
 import           Data.Text.Encoding.Error (lenientDecode)
-import qualified Distribution.Package as Cabal
 import qualified Distribution.Text as Cabal
 import qualified Distribution.Version as Cabal
 import           Generics.Deriving.Monoid (memptydefault, mappenddefault)
@@ -129,7 +128,7 @@ data Ctx = Ctx
     , baseConfigOpts :: !BaseConfigOpts
     , loadPackage    :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package)
     , combinedMap    :: !CombinedMap
-    , toolToPackages :: !(Cabal.Dependency -> Map PackageName VersionRange)
+    , toolToPackages :: !(ExeName -> Map PackageName VersionRange)
     , ctxEnvConfig   :: !EnvConfig
     , callStack      :: ![PackageName]
     , extraToBuild   :: !(Set PackageName)
@@ -224,18 +223,18 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage
         , baseConfigOpts = baseConfigOpts0
         , loadPackage = loadPackage0
         , combinedMap = combineMap sourceMap installedMap
-        , toolToPackages = \(Cabal.Dependency name _) ->
+        , toolToPackages = \name ->
           maybe Map.empty (Map.fromSet (const Cabal.anyVersion)) $
-          Map.lookup (T.pack . packageNameString . fromCabalPackageName $ name) (toolMap lp)
+          Map.lookup name toolMap
         , ctxEnvConfig = econfig
         , callStack = []
         , extraToBuild = extraToBuild0
         , getVersions = getVersions0
         , wanted = wantedLocalPackages locals <> extraToBuild0
         , localNames = Set.fromList $ map (packageName . lpPackage) locals
         }
-
-    toolMap = getToolMap ls0
+      where
+        toolMap = getToolMap ls0 lp
 
 -- | State to be maintained during the calculation of local packages
 -- to unregister.
@@ -795,58 +794,49 @@ 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 name mp =
             case Map.toList mp of
-                [] -> Left (NoToolFound name (packageName p))
+                [] -> Left (ToolWarning name (packageName p) Nothing)
                 [_] -> Right mp
-                xs -> Left (AmbiguousToolsFound name (packageName p) (map fst xs))
+                ((x, _):(y, _):zs) ->
+                  Left (ToolWarning name (packageName p) (Just (x, y, map fst zs)))
         (warnings0, toolDeps) =
              partitionEithers $
-             map (\dep -> toEither dep (toolToPackages ctx dep)) (packageTools p)
+             map (\dep -> toEither dep (toolToPackages ctx dep)) (Map.keys (packageTools p))
     -- Check whether the tool is on the PATH before warning about it.
-    warnings <- fmap catMaybes $ forM warnings0 $ \warning -> do
-        let toolName = case warning of
-                NoToolFound tool _ -> tool
-                AmbiguousToolsFound tool _ _ -> tool
+    warnings <- fmap catMaybes $ forM warnings0 $ \warning@(ToolWarning (ExeName toolName) _ _) -> do
         config <- view configL
         menv <- liftIO $ configEnvOverride config minimalEnvSettings { esIncludeLocals = True }
-        mfound <- findExecutable menv toolName
+        mfound <- findExecutable menv $ T.unpack toolName
         case mfound of
             Nothing -> return (Just warning)
             Just _ -> return Nothing
     tell mempty { wWarnings = (map toolWarningText warnings ++) }
-    when (any isNoToolFound warnings) $ do
-        let msg = T.unlines
-                [ "Missing build-tools may be caused by dependencies of the build-tool being overridden by extra-deps."
-                , "This should be fixed soon - see this issue https://github.com/commercialhaskell/stack/issues/595"
-                ]
-        tell mempty { wWarnings = (msg:) }
     return $ Map.unionsWith intersectVersionRanges
            $ packageDeps p
            : toolDeps
 
-data ToolWarning
-    = NoToolFound String PackageName
-    | AmbiguousToolsFound String PackageName [PackageName]
-
-isNoToolFound :: ToolWarning -> Bool
-isNoToolFound NoToolFound{} = True
-isNoToolFound _ = False
+-- | Warn about tools in the snapshot definition. States the tool name
+-- expected, the package name using it, and found packages. If the
+-- last value is Nothing, it means the tool was not found
+-- anywhere. For a Just value, it was found in at least two packages.
+data ToolWarning = ToolWarning ExeName PackageName (Maybe (PackageName, PackageName, [PackageName]))
+  deriving Show
 
 toolWarningText :: ToolWarning -> Text
-toolWarningText (NoToolFound toolName pkgName) =
+toolWarningText (ToolWarning (ExeName toolName) pkgName Nothing) =
     "No packages found in snapshot which provide a " <>
     T.pack (show toolName) <>
     " executable, which is a build-tool dependency of " <>
     T.pack (show (packageNameString pkgName))
-toolWarningText (AmbiguousToolsFound toolName pkgName options) =
+toolWarningText (ToolWarning (ExeName toolName) pkgName (Just (option1, option2, options))) =
     "Multiple packages found in snapshot which provide a " <>
     T.pack (show toolName) <>
     " exeuctable, which is a build-tool dependency of " <>
     T.pack (show (packageNameString pkgName)) <>
     ", so none will be installed.\n" <>
     "Here's the list of packages which provide it: " <>
-    T.intercalate ", " (map packageNameText options) <>
+    T.intercalate ", " (map packageNameText (option1:option2:options)) <>
     "\nSince there's no good way to choose, you may need to install it manually."
 
 -- | Strip out anything from the @Plan@ intended for the local database

src/Stack/Build/Source.hs

@@ -13,7 +13,6 @@ module Stack.Build.Source
     , getLocalFlags
     , getGhcOptions
     , addUnlistedToBuildCache
-    , getDefaultPackageConfig
     ) where
 
 import              Stack.Prelude
@@ -471,20 +470,6 @@ checkComponentsBuildable lps =
         , c <- Set.toList (lpUnbuildable lp)
         ]
 
-getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
-  => m PackageConfig
-getDefaultPackageConfig = do
-  platform <- view platformL
-  compilerVersion <- view actualCompilerVersionL
-  return PackageConfig
-    { packageConfigEnableTests = False
-    , packageConfigEnableBenchmarks = False
-    , packageConfigFlags = M.empty
-    , packageConfigGhcOptions = []
-    , packageConfigCompilerVersion = compilerVersion
-    , packageConfigPlatform = platform
-    }
-
 -- | Get 'PackageConfig' for package given its name.
 getPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
   => BuildOptsCLI

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
@@ -151,7 +152,7 @@ instance Show BuildPlanException where
 -- both snapshot and local packages (deps and project packages).
 getToolMap :: LoadedSnapshot
            -> LocalPackages
-           -> Map Text (Set PackageName)
+           -> Map ExeName (Set PackageName)
 getToolMap ls locals =
 
     {- We no longer do this, following discussion at:
@@ -170,13 +171,13 @@ getToolMap ls locals =
         ]
   where
     goSnap (pname, lpi) =
-        map (flip Map.singleton (Set.singleton pname) . unExeName)
+        map (flip Map.singleton (Set.singleton pname))
       $ Set.toList
       $ lpiProvidedExes lpi
 
     goLocalProj (pname, lpv) =
         map (flip Map.singleton (Set.singleton pname))
-        [t | CExe t <- Set.toList (lpvComponents lpv)]
+        [ExeName t | CExe t <- Set.toList (lpvComponents lpv)]
 
     goLocalDep (pname, (gpd, _loc)) =
         map (flip Map.singleton (Set.singleton pname))
@@ -185,8 +186,8 @@ getToolMap ls locals =
     -- TODO consider doing buildable checking. Not a big deal though:
     -- worse case scenario is we build an extra package that wasn't
     -- strictly needed.
-    gpdExes :: GenericPackageDescription -> [Text]
-    gpdExes = map (T.pack . fst) . condExecutables
+    gpdExes :: GenericPackageDescription -> [ExeName]
+    gpdExes = map (ExeName . T.pack . C.unUnqualComponentName . fst) . condExecutables
 
 gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
 gpdPackages gpds = Map.fromList $

src/Stack/Config.hs

@@ -59,9 +59,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)
@@ -473,7 +474,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
@@ -708,9 +709,9 @@ getNamedComponents gpkg = Set.fromList $ concat
     ]
   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