packages feed

hackport 0.5 → 0.5.1

raw patch · 902 files changed

+59539/−26045 lines, 902 filesdep +asyncdep +base16-bytestringbinary-added

Dependencies added: async, base16-bytestring

Files

.gitmodules view
@@ -1,6 +1,6 @@ [submodule "cabal"] 	path = cabal-	url = git://github.com/gentoo-haskell/cabal.git+	url = https://github.com/gentoo-haskell/cabal.git [submodule "hackage-security"] 	path = hackage-security-	url = git://github.com/well-typed/hackage-security.git+	url = https://github.com/well-typed/hackage-security.git
Cabal2Ebuild.hs view
@@ -29,11 +29,13 @@ import Distribution.Text (display)  import Data.Char          (isUpper)+import Data.Maybe  import Portage.Dependency import qualified Portage.Cabal as Portage import qualified Portage.PackageId as Portage import qualified Portage.EBuild as Portage+import qualified Portage.EBuild.CabalFeature as Portage import qualified Portage.Resolve as Portage import qualified Portage.EBuild as E import qualified Portage.Overlay as O@@ -54,20 +56,21 @@     E.slot            = (E.slot E.ebuildTemplate) ++ (if hasLibs then "/${PV}" else ""),     E.my_pn           = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,     E.features        = E.features E.ebuildTemplate-                   ++ (if hasExe then ["bin"]-                                 else [])-                   ++ (if hasLibs then (["lib","profile","haddock","hoogle"]+                   ++ (if hasLibs then ([ Portage.Lib+                                        , Portage.Profile+                                        , Portage.Haddock+                                        , Portage.Hoogle+                                        ]                                         ++ if cabalPkgName == "hscolour"                                                 then []-                                                else ["hscolour"])+                                                else [Portage.HsColour])                                   else [])-                   ++ (if hasTests then ["test-suite"]+                   ++ (if hasTests then [Portage.TestSuite]                                    else [])   } where         cabal_pn = Cabal.pkgName $ Cabal.package pkg         cabalPkgName = display cabal_pn-        hasLibs = Cabal.libraries pkg /= []-        hasExe = (not . null) (Cabal.executables pkg)+        hasLibs = isJust (Cabal.library pkg)         hasTests = (not . null) (Cabal.testSuites pkg)         thisHomepage = if (null $ Cabal.homepage pkg)                          then E.homepage E.ebuildTemplate@@ -96,6 +99,7 @@             )(\v     -> mk_p (DRange (NonstrictLB (p_v v)) InfinityB)         -- ^ @\">= v\"@             )(\v     -> mk_p (DRange ZeroB                (NonstrictUB (p_v v))) -- ^ @\"<= v\"@             )(\v1 v2 -> mk_p (DRange (NonstrictLB (p_v v1)) (StrictUB (p_v v2))) -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper)+            )(\v1 v2 -> mk_p (DRange (NonstrictLB (p_v v1)) (StrictUB (p_v v2))) -- ^ @\"^>= v\"@ major upper bound             )(\g1 g2 -> DependAnyOf [g1, g2]                                  -- ^ @\"_ || _\"@ union             )(\r1 r2 -> DependAllOf [r1, r2]                                  -- ^ @\"_ && _\"@ intersection             )(\dp    -> dp                                                    -- ^ @\"(_)\"@ parentheses
Main.hs view
@@ -23,9 +23,11 @@  import Distribution.Client.Types import Distribution.Client.Update-import qualified Distribution.Client.PackageIndex as Index-import qualified Distribution.Client.IndexUtils as Index +import qualified Distribution.Client.IndexUtils as CabalInstall+import qualified Distribution.Solver.Types.SourcePackage as CabalInstall+import qualified Distribution.Solver.Types.PackageIndex as CabalInstall+ import Portage.Overlay as Overlay ( loadLazy, inOverlay ) import Portage.Host as Host ( getInfo, portage_dir ) import Portage.PackageId ( normalizeCabalPackageId )@@ -92,11 +94,11 @@  let verbosity = fromFlag (listVerbosity flags)  H.withHackPortContext verbosity globalFlags $ \repoContext -> do   overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags)-  index <- fmap packageIndex (Index.getSourcePackages verbosity repoContext)+  index <- fmap packageIndex (CabalInstall.getSourcePackages verbosity repoContext)   overlay <- Overlay.loadLazy overlayPath-  let pkgs | null extraArgs = Index.allPackages index-           | otherwise = concatMap (concatMap snd . Index.searchByNameSubstring index) extraArgs-      normalized = map (normalizeCabalPackageId . packageInfoId) pkgs+  let pkgs | null extraArgs = CabalInstall.allPackages index+           | otherwise = concatMap (concatMap snd . CabalInstall.searchByNameSubstring index) extraArgs+      normalized = map (normalizeCabalPackageId . CabalInstall.packageInfoId) pkgs   let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized   mapM_ (putStrLn . pretty) decorated   where@@ -356,11 +358,30 @@ globalCommand :: CommandUI H.GlobalFlags globalCommand = CommandUI {     commandName = "",-    commandSynopsis = "",-    commandDescription = Nothing,-    commandNotes = Nothing,-    commandUsage = \_ -> [],+    commandSynopsis = "HackPort is an .ebuild generator from .cabal files with hackage index support",+    commandDescription = Just $ \pname ->+       let+         commands' = commands ++ [commandAddAction helpCommandUI undefined]+         cmdDescs = getNormalCommandDescriptions commands'+         maxlen    = maximum $ [length name | (name, _) <- cmdDescs]+         align str = str ++ replicate (maxlen - length str) ' '+       in+          "Commands:\n"+       ++ unlines [ "  " ++ align name ++ "    " ++ descr+                  | (name, descr) <- cmdDescs ]+       ++ "\n"+       ++ "For more information about a command use\n"+       ++ "  " ++ pname ++ " COMMAND --help\n\n"+       ++ "Typical steps for generating ebuilds from hackage packages:\n"+       ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"+                 | x <- ["update", "merge <package>"]]+       ++ "\n"+       ++ "Advanced usage:\n"+       ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"+                 | x <- ["update", "make-ebuild <ebuild.name> <CATEGORY>"]], +    commandNotes = Nothing,+    commandUsage = \pname -> "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",     commandDefaultFlags = H.defaultGlobalFlags,     commandOptions = \_showOrParseArgs ->         [ option ['V'] ["version"]@@ -412,7 +433,9 @@     errorHandler :: HackPortError -> IO ()     errorHandler e = do       putStrLn (hackPortShowError e)-    commands =++commands :: [Command (H.GlobalFlags -> IO ())]+commands =       [ listCommand `commandAddAction` listAction       , makeEbuildCommand `commandAddAction` makeEbuildAction       , statusCommand `commandAddAction` statusAction
Merge.hs view
@@ -8,22 +8,17 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.Function (on) import Data.Maybe-import Data.Monoid import qualified Data.List as L import qualified Data.Set as S import qualified Data.Time.Clock as TC-import Data.Version  -- cabal import qualified Distribution.Package as Cabal import qualified Distribution.Version as Cabal-import qualified Distribution.PackageDescription as Cabal ( PackageDescription(..)-                                       , Flag(..)-                                       , FlagAssignment-                                       , FlagName(..)-                                       , GenericPackageDescription(..)-                                       )-import qualified Distribution.PackageDescription.Parse as Cabal (showPackageDescription)+import qualified Distribution.PackageDescription as Cabal+import qualified Distribution.PackageDescription.PrettyPrint as Cabal (showPackageDescription)+import qualified Distribution.Solver.Types.SourcePackage as CabalInstall+import qualified Distribution.Solver.Types.PackageIndex as CabalInstall  import Distribution.Text (display) import Distribution.Verbosity@@ -32,7 +27,6 @@ -- cabal-install import Distribution.Client.IndexUtils ( getSourcePackages ) import qualified Distribution.Client.GlobalFlags as CabalInstall-import qualified Distribution.Client.PackageIndex as Index import Distribution.Client.Types  -- others@@ -96,10 +90,10 @@ -- return the available package with that version. Latest version is chosen -- if no preference. resolveVersion :: [UnresolvedSourcePackage] -> Maybe Cabal.Version -> Maybe UnresolvedSourcePackage-resolveVersion avails Nothing = Just $ L.maximumBy (comparing (Cabal.pkgVersion . packageInfoId)) avails+resolveVersion avails Nothing = Just $ L.maximumBy (comparing (Cabal.pkgVersion . CabalInstall.packageInfoId)) avails resolveVersion avails (Just ver) = listToMaybe (filter match avails)   where-    match avail = ver == Cabal.pkgVersion (packageInfoId avail)+    match avail = ver == Cabal.pkgVersion (CabalInstall.packageInfoId avail)  merge :: Verbosity -> CabalInstall.RepoContext -> [String] -> FilePath -> Maybe String -> IO () merge verbosity repoContext args overlayPath users_cabal_flags = do@@ -117,7 +111,7 @@   debug verbosity $ "Package: " ++ show user_pName   debug verbosity $ "Version: " ++ show m_version -  let (Cabal.PackageName user_pname_str) = user_pName+  let user_pname_str = Cabal.unPackageName user_pName    overlay <- Overlay.loadLazy overlayPath   -- portage_path <- Host.portage_dir `fmap` Host.getInfo@@ -126,17 +120,15 @@    -- find all packages that maches the user specified package name   availablePkgs <--    case map snd (Index.searchByName index user_pname_str) of+    case map snd (CabalInstall.searchByName index user_pname_str) of       [] -> throwEx (PackageNotFound user_pname_str)       [pkg] -> return pkg-      pkgs  -> do let cabal_pkg_to_pn pkg =-                          case Cabal.pkgName (packageInfoId pkg) of-                              Cabal.PackageName pn -> pn+      pkgs  -> do let cabal_pkg_to_pn pkg = Cabal.unPackageName $ Cabal.pkgName (CabalInstall.packageInfoId pkg)                       names      = map (cabal_pkg_to_pn . L.head) pkgs                   notice verbosity $ "Ambiguous names: " ++ L.intercalate ", " names                   forM_ pkgs $ \ps ->                       do let p_name = (cabal_pkg_to_pn . L.head) ps-                         notice verbosity $ p_name ++ ": " ++ (L.intercalate ", " $ map (showVersion . Cabal.pkgVersion . packageInfoId) ps)+                         notice verbosity $ p_name ++ ": " ++ (L.intercalate ", " $ map (display . Cabal.pkgVersion . CabalInstall.packageInfoId) ps)                   return $ concat pkgs    -- select a single package taking into account the user specified version@@ -145,21 +137,21 @@       Nothing -> do         putStrLn "No such version for that package, available versions:"         forM_ availablePkgs $ \ avail ->-          putStrLn (display . packageInfoId $ avail)+          putStrLn (display . CabalInstall.packageInfoId $ avail)         throwEx (ArgumentError "no such version for that package")       Just avail -> return avail    -- print some info   info verbosity "Selecting package:"   forM_ availablePkgs $ \ avail -> do-    let match_text | packageInfoId avail == packageInfoId selectedPkg = "* "+    let match_text | CabalInstall.packageInfoId avail == CabalInstall.packageInfoId selectedPkg = "* "                    | otherwise = "- "-    info verbosity $ match_text ++ (display . packageInfoId $ avail)+    info verbosity $ match_text ++ (display . CabalInstall.packageInfoId $ avail) -  let cabal_pkgId = packageInfoId selectedPkg+  let cabal_pkgId = CabalInstall.packageInfoId selectedPkg       norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)   cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category-  mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True users_cabal_flags+  mergeGenericPackageDescription verbosity overlayPath cat (CabalInstall.packageDescription selectedPkg) True users_cabal_flags  first_just_of :: [Maybe a] -> Maybe a first_just_of = msum@@ -181,7 +173,8 @@                            | ((cf, _), Just b) <- cn_in_mb                            ]                 user_renames = [ (cfn, ein)-                               | ((Cabal.FlagName cfn, ein), Nothing) <- cn_in_mb+                               | ((cabal_cfn, ein), Nothing) <- cn_in_mb+                               , let cfn = Cabal.unFlagName cabal_cfn                                ]                 cn_in_mb = map read_fa $ DLS.splitOn "," user_fas_s                 read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool)@@ -194,8 +187,8 @@                   where get_rename :: String -> (Cabal.FlagName, String)                         get_rename s =                             case DLS.splitOn ":" s of-                                [cabal_flag_name] -> (Cabal.FlagName cabal_flag_name, cabal_flag_name)-                                [cabal_flag_name, iuse_name] -> (Cabal.FlagName cabal_flag_name, iuse_name)+                                [cabal_flag_name] -> (Cabal.mkFlagName cabal_flag_name, cabal_flag_name)+                                [cabal_flag_name, iuse_name] -> (Cabal.mkFlagName cabal_flag_name, iuse_name)                                 _                 -> error $ "get_rename: too many components" ++ show (s)        (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags@@ -232,7 +225,8 @@        pp_fa :: Cabal.FlagAssignment -> String       pp_fa fa = L.intercalate ", " [ (if b then '+' else '-') : f-                                    | (Cabal.FlagName f, b) <- fa+                                    | (cabal_f, b) <- fa+                                    , let f = Cabal.unFlagName cabal_f                                     ]  @@ -322,7 +316,7 @@                                  }        liftFlags :: Cabal.FlagAssignment -> Portage.Dependency -> Portage.Dependency-      liftFlags fs e = let k = foldr (\(y,b) x -> Portage.mkUseDependency (b, Portage.Use . cfn_to_iuse . unFlagName $ y) . x)+      liftFlags fs e = let k = foldr (\(y,b) x -> Portage.mkUseDependency (b, Portage.Use . cfn_to_iuse . Cabal.unFlagName $ y) . x)                                       id fs                        in k e @@ -336,16 +330,17 @@   notice verbosity $ "Accepted depends: " ++ show (map display accepted_deps)   notice verbosity $ "Skipped  depends: " ++ show (map display skipped_deps)   notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments)-  notice verbosity $ "Dropped  flags: " ++ show (map (unFlagName.fst) common_fa)-  notice verbosity $ "Active flags: " ++ show (map unFlagName active_flags)-  notice verbosity $ "Irrelevant flags: " ++ show (map unFlagName irrelevant_flags)+  notice verbosity $ "Dropped  flags: " ++ show (map (Cabal.unFlagName.fst) common_fa)+  notice verbosity $ "Active flags: " ++ show (map Cabal.unFlagName active_flags)+  notice verbosity $ "Irrelevant flags: " ++ show (map Cabal.unFlagName irrelevant_flags)   -- mapM_ print tdeps    forM_ ghc_packages $-      \(Cabal.PackageName name) -> info verbosity $ "Excluded packages (comes with ghc): " ++ name+      \name -> info verbosity $ "Excluded packages (comes with ghc): " ++ Cabal.unPackageName name -  let pp_fn (Cabal.FlagName fn, True)  =     fn-      pp_fn (Cabal.FlagName fn, False) = '-':fn+  let pp_fn (cabal_fn, yesno) = b yesno ++ Cabal.unFlagName cabal_fn+          where b True  = ""+                b False = "-"        -- appends 's' to each line except the last one       --  handy to build multiline shell expressions@@ -365,9 +360,9 @@       selected_flags (active_fns, users_fas) = map snd (L.sortBy (compare `on` fst) flag_pairs)           where flag_pairs :: [(String, String)]                 flag_pairs = active_pairs ++ users_pairs-                active_pairs = map (\fn -> (fn,                    "$(cabal_flag " ++ cfn_to_iuse fn ++ " " ++ fn ++ ")")) $ map unFlagName active_fns-                users_pairs  = map (\fa -> ((unFlagName . fst) fa, "--flag=" ++ pp_fn fa)) users_fas-      to_iuse x = let fn = unFlagName $ Cabal.flagName x+                active_pairs = map (\fn -> (fn,                    "$(cabal_flag " ++ cfn_to_iuse fn ++ " " ++ fn ++ ")")) $ map Cabal.unFlagName active_fns+                users_pairs  = map (\fa -> ((Cabal.unFlagName . fst) fa, "--flag=" ++ pp_fn fa)) users_fas+      to_iuse x = let fn = Cabal.unFlagName $ Cabal.flagName x                       p  = if Cabal.flagDefault x then "+" else ""                   in p ++ cfn_to_iuse fn @@ -457,6 +452,3 @@       else do current_meta <- BL.readFile mpath               when (current_meta /= default_meta) $                   notice verbosity $ "Default and current " ++ emeta ++ " differ."--unFlagName :: Cabal.FlagName -> String-unFlagName (Cabal.FlagName fname) = fname
Merge/Dependencies.hs view
@@ -1,45 +1,5 @@ {- | Merge a package from hackage to an ebuild.--Merging a library-=================--Compile time:-  ghc-  cabal-  build tools-  deps (haskell dependencies)-  extra-libs (c-libs)-  pkg-config (c-libs)--Run time:-  ghc-  deps (haskell dependencies)-  extra-libs (c-libs)-  pkg-config (c-libs)--RDEPEND="ghc ${DEPS} ${EXTRALIBS}"-DEPEND="${RDEPEND} cabal ${BUILDTOOLS}"--Merging an executable-=====================-Packages with both executable and library must be treated as libraries, as it will impose a stricter DEPEND.--Compile time:-  ghc-  cabal-  build tools-  deps (haskell dependencies)-  extra-libs (c-libs)-  pkg-config (c-libs)--Run time:-  extra-libs (c-libs)-  pkg-config (c-libs)--RDEPEND="${EXTRALIBS}"-DEPEND="${RDEPEND} ghc cabal ${DEPS} ${BUILDTOOLS}"---}+ -} module Merge.Dependencies   ( EDep(..)   , resolveDependencies@@ -66,6 +26,7 @@ import qualified Distribution.Package as Cabal import qualified Distribution.PackageDescription as Cabal import qualified Distribution.Version as Cabal+import qualified Distribution.Text as Cabal  import qualified Distribution.Compiler as Cabal @@ -114,7 +75,7 @@   where     -- hasBuildableExes p = any (buildable . buildInfo) . executables $ p     treatAsLibrary :: Bool-    treatAsLibrary = Cabal.libraries pkg /= []+    treatAsLibrary = isJust (Cabal.library pkg)     -- without slot business     raw_haskell_deps :: Portage.Dependency     raw_haskell_deps = PN.normalize_depend $ Portage.DependAllOf $ haskellDependencies overlay (buildDepends pkg)@@ -139,12 +100,18 @@                            else [any_c_p "virtual" "pkgconfig"]     build_tools :: Portage.Dependency     build_tools = Portage.DependAllOf $ pkg_config_tools : buildToolsDependencies pkg++    setup_deps :: Portage.Dependency+    setup_deps = PN.normalize_depend $ Portage.DependAllOf $+                     setupDependencies overlay pkg ghc_package_names merged_cabal_pkg_name+     edeps :: EDep     edeps         | treatAsLibrary = mempty                   {                     dep = Portage.DependAllOf                               [ cabal_dep+                              , setup_deps                               , build_tools                               , test_deps                               ],@@ -160,6 +127,7 @@                   {                     dep = Portage.DependAllOf                               [ cabal_dep+                              , setup_deps                               , build_tools                               , test_deps                               ],@@ -174,7 +142,19 @@     add_profile    = Portage.addDepUseFlag (Portage.mkQUse (Portage.Use "profile"))  ---------------------------------------------------------------+-- Custom-setup dependencies+-- TODO: move partitioning part to Merge:mergeGenericPackageDescription+---------------------------------------------------------------++setupDependencies :: Portage.Overlay -> PackageDescription -> [Cabal.PackageName] -> Cabal.PackageName -> [Portage.Dependency]+setupDependencies overlay pkg ghc_package_names merged_cabal_pkg_name = deps+    where cabalDeps = maybe [] id $ Cabal.setupDepends `fmap` setupBuildInfo pkg+          cabalDeps' = fst $ Portage.partition_depends ghc_package_names merged_cabal_pkg_name cabalDeps+          deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps'++--------------------------------------------------------------- -- Test-suite dependencies+-- TODO: move partitioning part to Merge:mergeGenericPackageDescription ---------------------------------------------------------------  testDependencies :: Portage.Overlay -> PackageDescription -> [Cabal.PackageName] -> Cabal.PackageName -> [Portage.Dependency]@@ -200,13 +180,14 @@ cabalDependency :: Portage.Overlay -> PackageDescription -> Cabal.CompilerInfo -> Portage.Dependency cabalDependency overlay pkg ~(Cabal.CompilerInfo {                                   Cabal.compilerInfoId =-                                      Cabal.CompilerId Cabal.GHC (Cabal.Version versionNumbers _)+                                      Cabal.CompilerId Cabal.GHC cabal_version                               }) =          C2E.convertDependency overlay                                (Portage.Category "dev-haskell")-                               (Cabal.Dependency (Cabal.PackageName "Cabal")+                               (Cabal.Dependency (Cabal.mkPackageName "Cabal")                                                  finalCabalDep)   where+    versionNumbers = Cabal.versionNumbers cabal_version     userCabalVersion = Cabal.orLaterVersion (specVersion pkg)     shippedCabalVersion = GHCCore.cabalFromGHC versionNumbers     shippedCabalDep = maybe Cabal.anyVersion Cabal.orLaterVersion shippedCabalVersion@@ -222,22 +203,22 @@ compilerInfoToDependency :: Cabal.CompilerInfo -> Portage.Dependency compilerInfoToDependency ~(Cabal.CompilerInfo {                                Cabal.compilerInfoId =-                                   Cabal.CompilerId Cabal.GHC versionNumbers}) =-  at_least_c_p_v "dev-lang" "ghc" (Cabal.versionBranch versionNumbers)+                                   Cabal.CompilerId Cabal.GHC cabal_version}) =+  at_least_c_p_v "dev-lang" "ghc" (Cabal.versionNumbers cabal_version)  --------------------------------------------------------------- -- C Libraries ---------------------------------------------------------------  findCLibs :: PackageDescription -> [Portage.Dependency]-findCLibs (PackageDescription { libraries = libs, executables = exes }) =+findCLibs (PackageDescription { library = lib, executables = exes }) =   [ trace ("WARNING: This package depends on a C library we don't know the portage name for: " ++ p ++ ". Check the generated ebuild.")           (any_c_p "unknown-c-lib" p)   | p <- notFound   ] ++   found   where-  libE = concatMap (extraLibs . libBuildInfo) libs+  libE = concatMap (extraLibs . libBuildInfo) $ maybe [] return lib   exeE = concatMap extraLibs (filter buildable (map buildInfo exes))   allE = libE ++ exeE @@ -358,6 +339,8 @@       , ("SDL_image", any_c_p "media-libs" "sdl-image")       , ("SDL_ttf", any_c_p "media-libs" "sdl-ttf")       , ("odbc", any_c_p "dev-db" "unixODBC")+      , ("uuid", any_c_p "sys-apps" "util-linux")+      , ("notify", any_c_p "x11-libs" "libnotify")       ]  ---------------------------------------------------------------@@ -365,19 +348,19 @@ ---------------------------------------------------------------  buildToolsDependencies :: PackageDescription -> [Portage.Dependency]-buildToolsDependencies (PackageDescription { libraries = libs, executables = exes }) = nub $+buildToolsDependencies (PackageDescription { library = lib, executables = exes }) = nub $   [ case pkg of       Just p -> p-      Nothing -> trace ("WARNING: Unknown build tool '" ++ pn ++ "'. Check the generated ebuild.")+      Nothing -> trace ("WARNING: Unknown build tool '" ++ Cabal.display exe ++ "'. Check the generated ebuild.")                        (any_c_p "unknown-build-tool" pn)-  | Cabal.Dependency (Cabal.PackageName pn) _range <- cabalDeps+  | exe@(Cabal.LegacyExeDependency pn _range) <- cabalDeps   , pkg <- return (lookup pn buildToolsTable)   ]   where   cabalDeps = filter notProvided $ depL ++ depE-  depL = concatMap (buildTools . libBuildInfo) libs+  depL = concatMap (buildTools . libBuildInfo) $ maybe [] return lib   depE = concatMap buildTools (filter buildable (map buildInfo exes))-  notProvided (Cabal.Dependency (Cabal.PackageName pn) _range) = pn `notElem` buildToolsProvided+  notProvided (Cabal.LegacyExeDependency pn _range) = pn `notElem` buildToolsProvided  buildToolsTable :: [(String, Portage.Dependency)] buildToolsTable =@@ -406,23 +389,25 @@ ---------------------------------------------------------------  pkgConfigDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]-pkgConfigDependencies overlay (PackageDescription { libraries = libs, executables = exes }) = nub $ resolvePkgConfigs overlay cabalDeps+pkgConfigDependencies overlay (PackageDescription { library = lib, executables = exes }) = nub $ resolvePkgConfigs overlay cabalDeps   where   cabalDeps = depL ++ depE-  depL = concatMap (pkgconfigDepends . libBuildInfo) libs+  depL = concatMap (pkgconfigDepends . libBuildInfo) $ maybe [] return lib   depE = concatMap pkgconfigDepends (filter buildable (map buildInfo exes)) -resolvePkgConfigs :: Portage.Overlay -> [Cabal.Dependency] -> [Portage.Dependency]+resolvePkgConfigs :: Portage.Overlay -> [Cabal.PkgconfigDependency] -> [Portage.Dependency] resolvePkgConfigs overlay cdeps =   [ case resolvePkgConfig overlay pkg of       Just d -> d-      Nothing -> trace ("WARNING: Could not resolve pkg-config: " ++ pn ++ ". Check generated ebuild.")+      Nothing -> trace ("WARNING: Could not resolve pkg-config: " ++ Cabal.display pkg ++ ". Check generated ebuild.")                        (any_c_p "unknown-pkg-config" pn)-  | pkg@(Cabal.Dependency (Cabal.PackageName pn) _range) <- cdeps ]+  | pkg@(Cabal.PkgconfigDependency cabal_pn _range) <- cdeps+  , let pn = Cabal.unPkgconfigName cabal_pn+  ] -resolvePkgConfig :: Portage.Overlay -> Cabal.Dependency -> Maybe Portage.Dependency-resolvePkgConfig _overlay (Cabal.Dependency (Cabal.PackageName pn) _cabalVersion) = do-  (cat,portname, slot) <- lookup pn pkgconfig_table+resolvePkgConfig :: Portage.Overlay -> Cabal.PkgconfigDependency -> Maybe Portage.Dependency+resolvePkgConfig _overlay (Cabal.PkgconfigDependency cabal_pn _cabalVersion) = do+  (cat,portname, slot) <- lookup (Cabal.unPkgconfigName cabal_pn) pkgconfig_table   return $ any_c_p_s_u cat portname slot []  pkgconfig_table :: [(String, (String, String, Portage.SlotDepend))]
Portage/Cabal.hs view
@@ -7,7 +7,7 @@ import qualified Data.List as L import qualified Data.Map as Map -import qualified Distribution.Client.PackageIndex as Cabal+import qualified Distribution.Simple.PackageIndex as Cabal import qualified Distribution.License             as Cabal import qualified Distribution.Package             as Cabal import qualified Distribution.Text                as Cabal
Portage/EBuild.hs view
@@ -7,6 +7,8 @@         ) where  import Portage.Dependency+import Portage.EBuild.CabalFeature+import Portage.EBuild.Render import qualified Portage.Dependency.Normalize as PN  import Data.String.Utils@@ -37,9 +39,9 @@     depend :: Dependency,     depend_extra :: [String],     rdepend :: Dependency,-    rdepend_extra :: [String],-    features :: [String],-    my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters+    rdepend_extra :: [String]+    , features :: [CabalFeature]+    , my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters     , src_prepare :: [String] -- ^ raw block for src_prepare() contents     , src_configure :: [String] -- ^ raw block for src_configure() contents     , used_options :: [(String, String)] -- ^ hints to ebuild writers/readers@@ -98,7 +100,7 @@   ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl.   sconcat (map (\(k, v) -> ss "#hackport: " . ss k . ss ": " . ss v . nl) $ used_options ebuild).   nl.-  ss "CABAL_FEATURES=". quote' (sepBy " " $ features ebuild). nl.+  ss "CABAL_FEATURES=". quote' (sepBy " " $ map render (features ebuild)). nl.   ss "inherit haskell-cabal". nl.   nl.   (case my_pn ebuild of
+ Portage/EBuild/CabalFeature.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE LambdaCase #-}++-- CABAL_FEATURES="..." in haskell-cabal .ebuild files+-- see haskell-cabal.eclass for details on each of those+module Portage.EBuild.CabalFeature (CabalFeature(..)) where++import Portage.EBuild.Render++data CabalFeature = Lib+                  | Profile+                  | Haddock+                  | Hoogle+                  | HsColour+                  | TestSuite+    deriving Eq++instance Render CabalFeature where+    render = \case+                 Lib        -> "lib"+                 Profile    -> "profile"+                 Haddock    -> "haddock"+                 Hoogle     -> "hoogle"+                 HsColour   -> "hscolour"+                 TestSuite  -> "test-suite"
+ Portage/EBuild/Render.hs view
@@ -0,0 +1,6 @@+-- CABAL_FEATURES="..." in haskell-cabal .ebuild files+module Portage.EBuild.Render (Render(..)) where++class Render a where+    render :: a -> String+
Portage/GHCCore.hs view
@@ -9,7 +9,8 @@         ) where  import qualified Distribution.Compiler as DC-import Distribution.Package+import qualified Distribution.Package as Cabal+import qualified Distribution.Version as Cabal import Distribution.Version import Distribution.Simple.PackageIndex import Distribution.InstalledPackageInfo as IPI@@ -23,7 +24,6 @@  import Data.Maybe import Data.List ( nub )-import Data.Version  import Debug.Trace @@ -31,35 +31,36 @@ -- It means that first ghc in this list is a minmum default. ghcs :: [(DC.CompilerInfo, InstalledPackageIndex)] ghcs = modern_ghcs-    where modern_ghcs  = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101, ghc7102]+    where modern_ghcs  = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101, ghc7102, ghc801] -cabalFromGHC :: [Int] -> Maybe Version+cabalFromGHC :: [Int] -> Maybe Cabal.Version cabalFromGHC ver = lookup ver table   where-  table = [ ([7,4,2],  Version [1,14,0] [])-          , ([7,6,1],  Version [1,16,0] [])-          , ([7,6,2],  Version [1,16,0] [])-          , ([7,8,2],  Version [1,18,1,3] [])-          , ([7,10,1], Version [1,22,2,0] [])-          , ([7,10,2], Version [1,22,4,0] [])+  table = [ ([7,4,2],  Cabal.mkVersion [1,14,0])+          , ([7,6,1],  Cabal.mkVersion [1,16,0])+          , ([7,6,2],  Cabal.mkVersion [1,16,0])+          , ([7,8,2],  Cabal.mkVersion [1,18,1,3])+          , ([7,10,1], Cabal.mkVersion [1,22,2,0])+          , ([7,10,2], Cabal.mkVersion [1,22,4,0])+          , ([8,0,1],  Cabal.mkVersion [1,24,0,0])           ]  platform :: Platform platform = Platform X86_64 Linux -packageIsCore :: InstalledPackageIndex -> PackageName -> Bool+packageIsCore :: InstalledPackageIndex -> Cabal.PackageName -> Bool packageIsCore index pn = not . null $ lookupPackageName index pn -packageIsCoreInAnyGHC :: PackageName -> Bool+packageIsCoreInAnyGHC :: Cabal.PackageName -> Bool packageIsCoreInAnyGHC pn = any (flip packageIsCore pn) (map snd ghcs)  -- | Check if a dependency is satisfiable given a 'PackageIndex' -- representing the core packages in a GHC version. -- Packages that are not core will always be accepted, packages that are -- core in any ghc must be satisfied by the 'PackageIndex'.-dependencySatisfiable :: InstalledPackageIndex -> Dependency -> Bool-dependencySatisfiable pindex dep@(Dependency pn _rang)-  | pn == PackageName "Win32" = False -- only exists on windows, not in linux+dependencySatisfiable :: InstalledPackageIndex -> Cabal.Dependency -> Bool+dependencySatisfiable pindex dep@(Cabal.Dependency pn _rang)+  | Cabal.unPackageName pn == "Win32" = False -- only exists on windows, not in linux   | not . null $ lookupDependency pindex dep = True -- the package index satisfies the dep   | packageIsCoreInAnyGHC pn = False -- some other ghcs support the dependency   | otherwise = True -- the dep is not related with core packages, accept the dep@@ -68,7 +69,7 @@   :: GenericPackageDescription   -> FlagAssignment   -> (DC.CompilerInfo, InstalledPackageIndex)-  -> Either [Dependency] (PackageDescription, FlagAssignment)+  -> Either [Cabal.Dependency] (PackageDescription, FlagAssignment) packageBuildableWithGHCVersion pkg user_specified_fas (compiler_info, pkgIndex) = trace_failure $   finalizePackageDescription user_specified_fas (dependencySatisfiable pkgIndex) platform compiler_info [] pkg     where trace_failure v = case v of@@ -81,32 +82,39 @@                                             ]                                    ) v           show_deps = show . map display-          show_compiler (DC.CompilerInfo { DC.compilerInfoId = CompilerId GHC v }) = "ghc-" ++ showVersion v+          show_compiler (DC.CompilerInfo { DC.compilerInfoId = CompilerId GHC v }) = "ghc-" ++ display v           show_compiler c = show c  -- | Given a 'GenericPackageDescription' it returns the miminum GHC version -- to build a package, and a list of core packages to that GHC version.-minimumGHCVersionToBuildPackage :: GenericPackageDescription -> FlagAssignment -> Maybe (DC.CompilerInfo, [PackageName], PackageDescription, FlagAssignment, InstalledPackageIndex)+minimumGHCVersionToBuildPackage :: GenericPackageDescription -> FlagAssignment -> Maybe ( DC.CompilerInfo+                                                                                        , [Cabal.PackageName]+                                                                                        , PackageDescription+                                                                                        , FlagAssignment+                                                                                        , InstalledPackageIndex) minimumGHCVersionToBuildPackage gpd user_specified_fas =   listToMaybe [ (cinfo, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix)               | g@(cinfo, pix) <- ghcs               , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd user_specified_fas g)] -mkIndex :: [PackageIdentifier] -> InstalledPackageIndex+mkIndex :: [Cabal.PackageIdentifier] -> InstalledPackageIndex mkIndex pids = fromList   [ emptyInstalledPackageInfo       { sourcePackageId = pindex       , exposed = True       }-  | pindex@(PackageIdentifier name version) <- pids ]+  | pindex@(Cabal.PackageIdentifier _name _version) <- pids ] -packageNamesFromPackageIndex :: InstalledPackageIndex -> [PackageName]+packageNamesFromPackageIndex :: InstalledPackageIndex -> [Cabal.PackageName] packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix  ghc :: [Int] -> DC.CompilerInfo ghc nrs = DC.unknownCompilerInfo c_id DC.NoAbiTag-    where c_id = CompilerId GHC (Version nrs [])+    where c_id = CompilerId GHC (mkVersion nrs) +ghc801 :: (DC.CompilerInfo, InstalledPackageIndex)+ghc801 = (ghc [8,0,1], mkIndex ghc801_pkgs)+ ghc7102 :: (DC.CompilerInfo, InstalledPackageIndex) ghc7102 = (ghc [7,10,2], mkIndex ghc7102_pkgs) @@ -132,11 +140,38 @@ -- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC --         and our binary tarballs (package.conf.d.initial subdir) -ghc7102_pkgs :: [PackageIdentifier]+ghc801_pkgs :: [Cabal.PackageIdentifier]+ghc801_pkgs =+  [ p "array" [0,5,1,1]+  , p "base" [4,9,0,0]+  , p "binary" [0,8,3,0] -- used by libghc+  , p "bytestring" [0,10,8,0]+--  , p "Cabal" [1,24,0,0]  package is upgradeable+  , p "containers" [0,5,7,1]+  , p "deepseq" [1,4,2,0] -- used by time+  , p "directory" [1,2,6,2]+  , p "filepath" [1,4,1,0]+  , p "ghc-boot" [8,0,1]+  , p "ghc-prim" [0,5,0,0]+  , p "ghci" [8,0,1]+  , p "hoopl" [3,10,2,1] -- used by libghc+  , p "hpc" [0,6,0,3] -- used by libghc+  , p "integer-gmp" [1,0,0,1]+  , p "pretty" [1,1,3,3]+  , p "process" [1,4,2,0]+  , p "template-haskell" [2,11,0,0] -- used by libghc+  -- , p "terminfo" [0,4,0,2]+  , p "time" [1,6,0,1] -- used by unix, directory, hpc, ghc. unsafe to upgrade+  , p "transformers" [0,5,2,0] -- used by libghc+  , p "unix" [2,7,2,0]+--  , p "xhtml" [3000,2,1]+  ]++ghc7102_pkgs :: [Cabal.PackageIdentifier] ghc7102_pkgs =   [ p "array" [0,5,1,0]   , p "base" [4,8,1,0]---  , p "binary" [0,7,3,0]  package is upgradeable+  , p "binary" [0,7,3,0] -- used by libghc   , p "bytestring" [0,10,6,0] --  , p "Cabal" [1,18,1,3]  package is upgradeable   , p "containers" [0,5,6,2]@@ -155,15 +190,15 @@   , p "process" [1,2,3,0]   , p "template-haskell" [2,10,0,0] -- used by libghc   , p "time" [1,5,0,1] -- used by haskell98, unix, directory, hpc, ghc. unsafe to upgrade---  , p "transformers" [0,4,2,0] -- used by libghc+  , p "transformers" [0,4,2,0] -- used by libghc   , p "unix" [2,7,1,0]   ] -ghc7101_pkgs :: [PackageIdentifier]+ghc7101_pkgs :: [Cabal.PackageIdentifier] ghc7101_pkgs =   [ p "array" [0,5,1,0]   , p "base" [4,8,0,0]---  , p "binary" [0,7,3,0]  package is upgradeable+  , p "binary" [0,7,3,0] -- used by libghc   , p "bytestring" [0,10,6,0] --  , p "Cabal" [1,18,1,3]  package is upgradeable   , p "containers" [0,5,6,2]@@ -182,15 +217,15 @@   , p "process" [1,2,3,0]   , p "template-haskell" [2,10,0,0] -- used by libghc   , p "time" [1,5,0,1] -- used by haskell98, unix, directory, hpc, ghc. unsafe to upgrade---  , p "transformers" [0,4,2,0] -- used by libghc+  , p "transformers" [0,4,2,0] -- used by libghc   , p "unix" [2,7,1,0]   ] -ghc782_pkgs :: [PackageIdentifier]+ghc782_pkgs :: [Cabal.PackageIdentifier] ghc782_pkgs =   [ p "array" [0,5,0,0]   , p "base" [4,7,0,0]---  , p "binary" [0,7,1,0]  package is upgradeable+  , p "binary" [0,7,1,0] -- used by libghc   , p "bytestring" [0,10,4,0] --  , p "Cabal" [1,18,1,3]  package is upgradeable   , p "containers" [0,5,5,1]@@ -209,15 +244,15 @@   , p "process" [1,2,0,0]   , p "template-haskell" [2,9,0,0] -- used by libghc   , p "time" [1,4,2] -- used by haskell98, unix, directory, hpc, ghc. unsafe to upgrade---  , p "transformers" [0,3,0,0] -- used by libghc+  , p "transformers" [0,3,0,0] -- used by libghc   , p "unix" [2,7,0,1]   ] -ghc762_pkgs :: [PackageIdentifier]+ghc762_pkgs :: [Cabal.PackageIdentifier] ghc762_pkgs =   [ p "array" [0,4,0,1]   , p "base" [4,6,0,1]---  , p "binary" [0,5,1,1]  package is upgradeable+  , p "binary" [0,5,1,1] -- used by libghc   , p "bytestring" [0,10,0,2] --  , p "Cabal" [1,16,0]  package is upgradeable   , p "containers" [0,5,0,0]@@ -239,11 +274,11 @@   , p "unix" [2,6,0,1]   ] -ghc761_pkgs :: [PackageIdentifier]+ghc761_pkgs :: [Cabal.PackageIdentifier] ghc761_pkgs =   [ p "array" [0,4,0,1]   , p "base" [4,6,0,0]---  , p "binary" [0,5,1,1]  package is upgradeable+  , p "binary" [0,5,1,1] -- used by libghc   , p "bytestring" [0,10,0,0] --  , p "Cabal" [1,16,0]  package is upgradeable   , p "containers" [0,5,0,0]@@ -265,11 +300,11 @@   , p "unix" [2,6,0,0]   ] -ghc742_pkgs :: [PackageIdentifier]+ghc742_pkgs :: [Cabal.PackageIdentifier] ghc742_pkgs =   [ p "array" [0,4,0,0]   , p "base" [4,5,1,0]---  , p "binary" [0,5,1,0]  package is upgradeable+  , p "binary" [0,5,1,0] -- used by libghc   , p "bytestring" [0,9,2,1] --  , p "Cabal" [1,14,0]  package is upgradeable   , p "containers" [0,4,2,1]@@ -292,11 +327,11 @@   , p "unix" [2,5,1,1]   ] -ghc741_pkgs :: [PackageIdentifier]+ghc741_pkgs :: [Cabal.PackageIdentifier] ghc741_pkgs =   [ p "array" [0,4,0,0]   , p "base" [4,5,0,0]---  , p "binary" [0,5,1,0]  package is upgradeable+  , p "binary" [0,5,1,0] -- used by libghc   , p "bytestring" [0,9,2,1] --  , p "Cabal" [1,14,0]  package is upgradeable   , p "containers" [0,4,2,1]@@ -319,5 +354,5 @@   , p "unix" [2,5,1,0]   ] -p :: String -> [Int] -> PackageIdentifier-p pn vs = PackageIdentifier (PackageName pn) (Version vs [])+p :: String -> [Int] -> Cabal.PackageIdentifier+p pn vs = Cabal.PackageIdentifier (Cabal.mkPackageName pn) (mkVersion vs)
Portage/Overlay.hs view
@@ -34,7 +34,11 @@     ebuildPath    :: FilePath   } deriving (Show,Ord,Eq) -instance Cabal.Package ExistingEbuild where packageId = ebuildCabalId+instance Cabal.Package ExistingEbuild where+    packageId = ebuildCabalId++instance Cabal.HasUnitId ExistingEbuild where+    installedUnitId _ = error "Portage.Cabal.installedUnitId: FIXME: should not be used"  data Overlay = Overlay {     overlayPath  :: FilePath,
Portage/PackageId.hs view
@@ -62,7 +62,7 @@     a <.> b = a ++ '.':b  mkPackageName :: String -> String -> PackageName-mkPackageName cat package = PackageName (Category cat) (Cabal.PackageName package)+mkPackageName cat package = PackageName (Category cat) (Cabal.mkPackageName package)  fromCabalPackageId :: Category -> Cabal.PackageIdentifier -> PackageId fromCabalPackageId category (Cabal.PackageIdentifier name version) =@@ -70,8 +70,8 @@             (Portage.fromCabalVersion version)  normalizeCabalPackageName :: Cabal.PackageName -> Cabal.PackageName-normalizeCabalPackageName (Cabal.PackageName name) =-  Cabal.PackageName (map Char.toLower name)+normalizeCabalPackageName =+  Cabal.mkPackageName . map Char.toLower . Cabal.unPackageName  normalizeCabalPackageId :: Cabal.PackageIdentifier -> Cabal.PackageIdentifier normalizeCabalPackageId (Cabal.PackageIdentifier name version) =
Portage/Version.hs view
@@ -50,10 +50,10 @@   deriving (Eq, Ord, Show, Read)  fromCabalVersion :: Cabal.Version -> Version-fromCabalVersion (Cabal.Version nums _tags) = Version nums Nothing [] 0+fromCabalVersion cabal_version = Version (Cabal.versionNumbers cabal_version) Nothing [] 0  toCabalVersion :: Version -> Maybe Cabal.Version-toCabalVersion (Version nums Nothing [] _) = Just (Cabal.Version nums [])+toCabalVersion (Version nums Nothing [] _) = Just (Cabal.mkVersion nums) toCabalVersion _                           = Nothing  instance Text Version where
README.rst view
@@ -62,9 +62,8 @@         KEYWORDS             Defaults to ~amd64 ~x86         CABAL_FEATURES-            Set to "bin" for executables, and "lib haddock profile" for-            libraries. Packages that contains both a binary and library will-            get the union.+            Populates the following features (see haskell-cabal.eclass):+            lib, profile, haddock, hoogle, hscolour, test-suite         DEPEND             GHC dependency defaults to >=dev-lang/ghc-6.6.1.             Cabal dependency is fetched from Cabal field 'Cabal-Version'.
Status.hs view
@@ -28,15 +28,16 @@ import Control.Monad  -- cabal-import Distribution.Client.Types ( SourcePackageDb(..), SourcePackage(..) )-import Distribution.Verbosity-import Distribution.Package (pkgName)-import Distribution.Simple.Utils (comparing, die, equating)-import Distribution.Text ( display, simpleParse )+import qualified Distribution.Verbosity as Cabal+import qualified Distribution.Package as Cabal (pkgName)+import qualified Distribution.Simple.Utils as Cabal (comparing, die, equating)+import qualified Distribution.Text as Cabal ( display, simpleParse )  import qualified Distribution.Client.GlobalFlags as CabalInstall import qualified Distribution.Client.IndexUtils as CabalInstall-import qualified Distribution.Client.PackageIndex as CabalInstall+import qualified Distribution.Client.Types as CabalInstall ( SourcePackageDb(..) )+import qualified Distribution.Solver.Types.PackageIndex as CabalInstall+import qualified Distribution.Solver.Types.SourcePackage as CabalInstall ( SourcePackage(..) )  data StatusDirection     = PortagePlusOverlay@@ -53,7 +54,7 @@         deriving (Show,Eq)  instance Ord a => Ord (FileStatus a) where-    compare = comparing fromStatus+    compare = Cabal.comparing fromStatus  instance Functor FileStatus where     fmap f st =@@ -75,20 +76,20 @@   -loadHackage :: Verbosity -> CabalInstall.RepoContext -> Overlay -> IO [[PackageId]]+loadHackage :: Cabal.Verbosity -> CabalInstall.RepoContext -> Overlay -> IO [[PackageId]] loadHackage verbosity repoContext overlay = do-    SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity repoContext-    let get_cat cabal_pkg = case resolveCategories overlay (pkgName cabal_pkg) of+    CabalInstall.SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity repoContext+    let get_cat cabal_pkg = case resolveCategories overlay (Cabal.pkgName cabal_pkg) of                                 []    -> Category "dev-haskell"                                 [cat] -> cat                                 _     -> {- ambig -} Category "dev-haskell"         pkg_infos = map ( reverse . take 3 . reverse -- hackage usually has a ton of older versions                         . map ((\p -> fromCabalPackageId (get_cat p) p)-                              . packageInfoId))+                              . CabalInstall.packageInfoId))                         (CabalInstall.allPackagesByName pindex)     return pkg_infos -status :: Verbosity -> FilePath -> FilePath -> CabalInstall.RepoContext -> IO (Map PackageName [FileStatus ExistingEbuild])+status :: Cabal.Verbosity -> FilePath -> FilePath -> CabalInstall.RepoContext -> IO (Map PackageName [FileStatus ExistingEbuild]) status verbosity portdir overlaydir repoContext = do     overlay <- loadLazy overlaydir     hackage <- loadHackage verbosity repoContext overlay@@ -112,8 +113,15 @@         mk_fake_ee :: [PackageId] -> (PackageName, [ExistingEbuild])         mk_fake_ee ~pkgs@(p:_) = (packageId p, map p_to_ee pkgs) -        map_diff = Map.differenceWith (\le re -> Just $ foldr (List.deleteBy (equating ebuildId)) le re)-        hack = ((Map.fromList $ map mk_fake_ee hackage) `map_diff` overlayMap overlay) `map_diff` overlayMap portage+        map_diff = Map.differenceWith (\le re -> Just $ foldr (List.deleteBy (Cabal.equating ebuildId)) le re)+        hack = (( -- We merge package names as we do case-insensitive match.+                  -- Hackage contains the following 2 package names:+                  --   ... Cabal-1.24.0.0 Cabal-1.24.1.0+                  --   cabal-0.0.0.0+                  -- We need to pick both lists of versions, not the first.+                  -- TODO: have a way to distict between them in the output.+                  Map.fromListWith (++) $+                      map mk_fake_ee hackage) `map_diff` overlayMap overlay) `map_diff` overlayMap portage          meld = Map.unionsWith (\a b -> List.sort (a++b))                 [ Map.map (map PortageOnly) port@@ -130,15 +138,15 @@   ebuilds <- Map.lookup (packageId pkgid) overlay   List.find (\e -> ebuildId e == pkgid) ebuilds -runStatus :: Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> CabalInstall.RepoContext -> IO ()+runStatus :: Cabal.Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> CabalInstall.RepoContext -> IO () runStatus verbosity portdir overlaydir direction pkgs repoContext = do   let pkgFilter = case direction of                       OverlayToPortage   -> toPortageFilter                       PortagePlusOverlay -> id                       HackageToOverlay   -> fromHackageFilter   pkgs' <- forM pkgs $ \p ->-            case simpleParse p of-              Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg")+            case Cabal.simpleParse p of+              Nothing -> Cabal.die ("Could not parse package name: " ++ p ++ ". Format cat/pkg")               Just pn -> return pn   tree0 <- status verbosity portdir overlaydir repoContext   let tree = pkgFilter tree0@@ -196,10 +204,10 @@         let (PackageName c p) = pkg         putStr (bold (show ix))         putStr " "-        putStr $ display c ++ '/' : bold (display p)+        putStr $ Cabal.display c ++ '/' : bold (Cabal.display p)         putStr " "         forM_ ebuilds $ \e -> do-            putStr $ toColor (fmap (display . pkgVersion . ebuildId) e)+            putStr $ toColor (fmap (Cabal.display . pkgVersion . ebuildId) e)             putChar ' '         putStrLn "" @@ -215,12 +223,12 @@  portageDiff :: EMap -> EMap -> (EMap, EMap, EMap) portageDiff p1 p2 = (in1, ins, in2)-    where ins = Map.filter (not . null) $ Map.intersectionWith (List.intersectBy $ equating ebuildId) p1 p2+    where ins = Map.filter (not . null) $ Map.intersectionWith (List.intersectBy $ Cabal.equating ebuildId) p1 p2           in1 = difference p1 p2           in2 = difference p2 p1           difference x y = Map.filter (not . null) $                        Map.differenceWith (\xs ys ->-                        let lst = foldr (List.deleteBy (equating ebuildId)) xs ys in+                        let lst = foldr (List.deleteBy (Cabal.equating ebuildId)) xs ys in                         if null lst                             then Nothing                             else Just lst@@ -236,7 +244,7 @@     return (equal' f1 f2)  equal' :: BS.ByteString -> BS.ByteString -> Bool-equal' = equating essence+equal' = Cabal.equating essence     where     essence = filter (not . isEmpty) . filter (not . isComment) . BS.lines     isComment = BS.isPrefixOf (BS.pack "#") . BS.dropWhile isSpace
cabal/.gitignore view
@@ -1,6 +1,8 @@ # trivial gitignore file .cabal-sandbox/ cabal.sandbox.config+cabal.project.local+.ghc.environment.* cabal-dev/ .hpc/ *.hi@@ -11,6 +13,7 @@ cabal.config dist dist-*+register.sh  /Cabal/dist/ /Cabal/tests/Setup@@ -52,3 +55,8 @@ # test files dist-test register.sh+/Cabal/tests/PackageTests/Configure/include/HsZlibConfig.h+/Cabal/tests/PackageTests/Configure/zlib.buildinfo++# python artifacts from documentation builds+*.pyc
+ cabal/.mailmap view
@@ -0,0 +1,117 @@+# See 'git help shortlog' for more details.+# Formats: Proper Name [<proper@email.xx> [Commit Name]] <commit@email.xx>+#+# Show result: 'git shortlog -se'.+# Should be empty list: 'git shortlog -se | cut -f2 | cut -d'<' -f1 | uniq -d'.++Adam Langley                <agl@imperialviolet.org>+Alistair Bailey             <alistair@abayley.org>                 alistair <alistair@abayley.org>+Alson Kemp                  <alson@alsonkemp.com>                  alson <alson@alsonkemp.com>+Andy Craze                  <accraze@gmail.com>+Andres Löh                  <andres.loeh@gmail.com>+Andres Löh                  <andres.loeh@gmail.com>                <andres@cs.uu.nl>+Andres Löh                  <andres.loeh@gmail.com>                <andres@well-typed.com>+Andres Löh                  <andres.loeh@gmail.com>                <ksgithub@andres-loeh.de>+Andres Löh                  <andres.loeh@gmail.com>                <mail@andres-loeh.de>+Audrey Tang                 <audreyt@audreyt.org>                  audreyt <audreyt@audreyt.org>+Austin Seipp                <aseipp@pobox.com>+Austin Seipp                <aseipp@pobox.com>                     <aseipp@well-typed.com>+Austin Seipp                <aseipp@pobox.com>                     austin seipp <as@0xff.ath.cx>+Ben Gamari                  <ben@smart-cactus.org>+Ben Gamari                  <ben@smart-cactus.org>                 <ben@well-typed.com>+Ben Gamari                  <ben@smart-cactus.org>                 <bgamari.foss@gmail.com>+Ben Millwood                <thebenmachine+git@gmail.com>          <haskell@benmachine.co.uk>+Benedikt Huber              <benedikt.huber@gmail.com>             benedikt.huber <benedikt.huber@gmail.com>+Benno Fünfstück             <benno.fuenfstueck@gmail.com>          <bneno.fuenfstueck@gmail.com>+Björn Bringert              <bjorn@bringert.net>+Björn Bringert              <bjorn@bringert.net>                   bjorn <bjorn@maggie>+Björn Bringert              <bjorn@bringert.net>                   bringert <bringert@cs.chalmers.se>+Bram Schuur                 <bramschuur@gmail.com>+Brendan Hay                 <brendan.g.hay@gmail.com>              <brendanhay@users.noreply.github.com>+Brent Yorgey                <byorgey@gmail.com>                    <byorgey@cis.upenn.edu>+Brian Smith                 <brianlsmith@gmail.com>                brianlsmith <brianlsmith@gmail.com>+David Himmelstrup           <lemmih@gmail.com>+David Luposchainsky         <dluposchainsky@gmail.com>             <quchen@users.noreply.github.com>+David Waern                 <davve@dtek.chalmers.se>               David Waern <unknown>+Dennis Gosnell              <cdep.illabout@gmail.com>+Duncan Coutts               <duncan@community.haskell.org>+Duncan Coutts               <duncan@community.haskell.org>         <Duncan Coutts duncan@community.haskell.org>+Duncan Coutts               <duncan@community.haskell.org>         <duncan.coutts@worc.ox.ac.uk>+Duncan Coutts               <duncan@community.haskell.org>         <duncan@community.haskell.org>+Duncan Coutts               <duncan@community.haskell.org>         <duncan@haskell.org>+Duncan Coutts               <duncan@community.haskell.org>         <duncan@well-typed.com>+Duncan Coutts               <duncan@community.haskell.org>         unknown <unknown> # 04e9fcc80bc68b72126e33b20f08050df28e727d+Edward Z. Yang              <ezyang@cs.stanford.edu>               <ezyang@mit.edu>+Einar Karttunen             <ekarttun@cs.helsinki.fi>+Federico Mastellone         <fmaste@users.noreply.github.com>+Ganesh Sittampalam          <ganesh.sittampalam@credit-suisse.com> <ganesh@earth.li>+Geoff Nixon                 <geoff-codes@users.noreply.github.com> <geoff.nixon@aol.com>+Gershom Bazerman            <gershomb@gmail.com>+Gershom Bazerman            <gershomb@gmail.com>                   Gershom <gershom@mbp.local>+Gershom Bazerman            <gershomb@gmail.com>                   U-CIQDEV\gbazerman <gbazerman@GBAZERMAN-T35.ciqdev.com>+Gershom Bazerman            <gershomb@gmail.com>                   gbaz <gershomb@gmail.com>+Gleb Alexeev                <gleb.alexeev@gmail.com>+Gleb Alexeev                <gleb.alexeev@gmail.com>               gleb.alexeev <gleb.alexeev@gmail.com>+Gwern Branwen               <gwern0@gmail.com>                     gwern0 <gwern0@gmail.com>+Heather                     <heather@live.ru>                      <Heather@cynede.net>+Heather                     <heather@live.ru>                      <Heather@users.noreply.github.com>+Henning Günther             <der_eq@freenet.de>+Henning Thielemann          <lemming@henning-thielemann.de>        <haskell@henning-thielemann.de>+Henning Thielemann          <lemming@henning-thielemann.de>        cabal <cabal@henning-thielemann.de>+Ian Lynagh                  <igloo@earth.li>                       <ian@well-typed.com>+Isaac Potoczny-Jones        <ijones@syntaxpolice.org>+JP Moresmau                 <jp@moresmau.fr>+Jacco Krijnen               <jaccokrijnen@gmail.com>+Jake Wheat                  <jakewheatmail@gmail.com>+Jean-Philippe Bernardy      <jeanphilippe.bernardy@gmail.com>      jeanphilippe.bernardy <jeanphilippe.bernardy@gmail.com>+Jens Petersen               <juhpetersen@gmail.com>                <juhp@community.haskell.org>+Jens Petersen               <juhpetersen@gmail.com>                <petersen@haskell.org>+Jens Petersen               <juhpetersen@gmail.com>                <petersen@redhat.com>+Jeremy Shaw                 <jeremy.shaw@linspireinc.com>+Jeremy Shaw                 <jeremy.shaw@linspireinc.com>          <jeremy@n-heptane.com>+Jim Burton                  <jim@sdf-eu.org>+Joe Quinn                   <headprogrammingczar@gmail.com>+Joel Stanley                <intractable@gmail.com>+Joeri van Eekelen           <tchakkazulu@gmail.com>+John D. Ramsdell            <ramsdell@mitre.org>+John Dias                   <dias@eecs.harvard.edu>                dias <dias@eecs.harvard.edu>+Josh Hoyt                   <josh.hoyt@galois.com>+Judah Jacobson              <judah.jacobson@gmail.com>+Jürgen Nicklisch-Franken    <jnf@arcor.de>+Ken Bateman                 <novadenizen@gmail.com>+Keegan McAllister           <mcallister.keegan@gmail.com>          mcallister.keegan <mcallister.keegan@gmail.com>+Kido Takahiro               <shelarcy@gmail.com>+Krasimir Angelov            <kr.angelov@gmail.com>+Krasimir Angelov            <kr.angelov@gmail.com>                 ka2_mail <ka2_mail@yahoo.com>+Lennart Kolmodin            <kolmodin@gmail.com>                   <kolmodin@dtek.chalmers.se>+Lennart Kolmodin            <kolmodin@gmail.com>                   <kolmodin@gentoo.org>+Lennart Kolmodin            <kolmodin@gmail.com>                   <kolmodin@google.com>+Lennart Spitzner            <lsp@informatik.uni-kiel.de>+Malcolm Wallace             <Malcolm.Wallace@me.com>               Malcolm.Wallace <Malcolm.Wallace@cs.york.ac.uk>+Mark Weber                  <marco-oweber@gmx.de>                  marco-oweber <marco-oweber@gmx.de>+Martin Sjögren              <msjogren@gmail.com>                   md9ms <md9ms@mdstud.chalmers.se>+Mikhail Glushenkov          <mikhail.glushenkov@gmail.com>         <c05mgv@cs.umu.se>+Mikhail Glushenkov          <mikhail.glushenkov@gmail.com>         <the.dead.shall.rise@gmail.com>+Neil Mitchell               <ndmitchell@gmail.com>                 Neil Mitchell <unknown>+Niklas Broberg              <niklas.broberg@gmail.com>             <d00nibro@chalmers.se>+Niklas Broberg              <niklas.broberg@gmail.com>             <git@nand.wakku.to>+Peter Higley                <phigley@gmail.com>+Peter Simons                <simons@cryp.to>+Peter Trško                 <peter.trsko@gmail.com>                Peter Trsko <peter.trsko@ixperta.com>+Philipp Schuster            <pschuster@uni-koblenz.de>+Randy Polen                 <randen@users.noreply.github.com>+Ryan Scott                  <ryan.gl.scott@gmail.com>              <ryan.gl.scott@ku.edu>+Samuel Gélineau             <gelisam+github@gmail.com>+Sergei Trofimovich          <slyfox@community.haskell.org>         <slyfox@gentoo.org>+Sigbjorn Finne              <sof@galois.com>+Simon Marlow                <marlowsd@gmail.com>                   <simonmar@microsoft.com>+Simon Marlow                <marlowsd@gmail.com>                   <smarlow@fb.com>+Simon Peyton Jones          <simonpj@microsoft.com>+Simon Peyton Jones          <simonpj@microsoft.com>                simonpj <simonpj@microsoft/com>+Stephen Blackheath          <stephen.blackheath@ipwnstudios.com>   <grossly.sensitive.stephen@blacksapphire.com>+Stephen Blackheath          <stephen.blackheath@ipwnstudios.com>   <oversensitive.pastors.stephen@blacksapphire.com>+Stephen Blackheath          <stephen.blackheath@ipwnstudios.com>   rubbernecking.trumpet.stephen <rubbernecking.trumpet.stephen@blacksapphire.com>+Sven Panne                  <sven.panne@aedion.de>+Thomas M. DuBuisson         <thomas.dubuisson@gmail.com>+Thomas M. DuBuisson         <thomas.dubuisson@gmail.com>           Thomas M. DuBuisson <tommd@galois.com>+Thomas Schilling            <nominolo@gmail.com>                   <nominolo@googlemail.com>
+ cabal/.mention-bot view
@@ -0,0 +1,6 @@+{+  "userBlacklist": [+    "BardurArantsson"+  , "SyntaxPolice"+  ]+}
cabal/.travis.yml view
@@ -1,28 +1,107 @@ # NB: don't set `language: haskell` here+# We specify language: c, so it doesn't default to e.g. ruby+language: c +sudo: false++# Remember to add release branches+# we whitelist branches, as we don't really need to build dev-branches.+branches:+  only:+    - master+    - "1.24"+    - "1.22"+    - "1.20"+    - "1.18"+ # The following enables several GHC versions to be tested; often it's enough to # test only against the last release in a major GHC version. Feel free to omit # lines listings versions you don't need/want testing for.-env:- - GHCVER=7.4.2- - GHCVER=7.6.3- - GHCVER=7.8.4- - GHCVER=7.10.3- - GHCVER=8.0.1 TEST_OLDER=YES+matrix:+  include:+   - env: GHCVER=8.0.1 SCRIPT=meta BUILDER=none+     os: linux+     sudo: required+   # These don't have -dyn/-prof whitelisted yet, so we have to+   # do the old-style installation+   - env: GHCVER=7.4.2 SCRIPT=script CABAL_LIB_ONLY=YES+     os: linux+     sudo: required+   - env: GHCVER=7.6.3 SCRIPT=script+     os: linux+     sudo: required+   - env: GHCVER=7.8.4 SCRIPT=script+     os: linux+     sudo: required+   # Ugh, we'd like to drop 'sudo: required' and use the+   # apt plugin for the next two+   # but the GCE instance we get has more memory, which makes+   # a big difference+   - env: GHCVER=7.10.3 SCRIPT=script+     os: linux+     sudo: required+   - env: GHCVER=8.0.1 SCRIPT=script DEPLOY_DOCS=YES TEST_OTHER_VERSIONS=YES+     sudo: required+     os: linux+   - env: GHCVER=8.0.1 SCRIPT=solver-debug-flags+     sudo: required+     os: linux+   - env: GHCVER=8.0.1 SCRIPT=script PARSEC=YES TEST_OTHER_VERSIONS=YES+     os: linux+     sudo: required+   - env: GHCVER=8.0.1 SCRIPT=bootstrap+     sudo: required+     os: linux++   # We axed GHC 7.6 and earlier because it's not worth the trouble to+   # make older GHC work with clang's cpp.  See+   # https://ghc.haskell.org/trac/ghc/ticket/8493+   - env: GHCVER=7.8.4 SCRIPT=script+     os: osx+     osx_image: xcode6.4 # We need 10.10++   # TODO: We might want to specify OSX version+   # https://docs.travis-ci.com/user/osx-ci-environment/#OS-X-Version+   - env: GHCVER=7.10.3 SCRIPT=script+     os: osx+   - env: GHCVER=8.0.1 SCRIPT=script+     os: osx+   - env: GHCVER=8.0.1 SCRIPT=bootstrap+     os: osx++   - env: GHCVER=via-stack SCRIPT=stack STACKAGE_RESOLVER=lts+     os: linux+     addons:+        apt:+            packages:+                - libgmp-dev++  allow_failures:+   - env: GHCVER=via-stack SCRIPT=stack STACKAGE_RESOLVER=lts+  # TODO add PARSEC_BUNDLED=YES when it's so- - GHCVER=head+ # It seems pointless to run head if we're going to ignore the results.+ #- GHCVER=head  # Note: the distinction between `before_install` and `install` is not important. before_install:- - travis_retry sudo add-apt-repository -y ppa:hvr/ghc- - travis_retry sudo apt-get update- - travis_retry sudo apt-get install cabal-install-1.24 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy- - if [ "$TEST_OLDER" == "YES" ]; then travis_retry sudo apt-get install ghc-7.0.4-prof ghc-7.0.4-dyn ghc-7.2.2-prof ghc-7.2.2-dyn; fi- - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/1.24/bin:$PATH- - git version+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH+ - export PATH=$HOME/.ghc-install/$GHCVER/bin:$PATH+ - export PATH=$HOME/bin:$PATH+ - export PATH=$HOME/.cabal/bin:$PATH+ - export PATH=$HOME/.local/bin:$PATH+ - export PATH=/opt/cabal/1.24/bin:$PATH+ - export PATH=/opt/happy/1.19.5/bin:$PATH+ - export PATH=/opt/alex/3.1.7/bin:$PATH+ - ./travis-install.sh + # Set up deployment to the haskell/cabal-website repo.+ # NB: these commands MUST be in .travis.yml, otherwise the secret key can be+ # leaked! See https://github.com/travis-ci/travis.rb/issues/423.+ # umask to get the permissions to be 400.+ - if [ "x$TRAVIS_REPO_SLUG" = "xhaskell/cabal" -a "x$TRAVIS_PULL_REQUEST" = "xfalse" -a "x$TRAVIS_BRANCH" = "xmaster" -a "x$DEPLOY_DOCS" = "xYES"  ]; then (umask 377 && openssl aes-256-cbc -K $encrypted_edaf6551664d_key -iv $encrypted_edaf6551664d_iv -in id_rsa_cabal_website.aes256.enc -out ~/.ssh/id_rsa -d); fi+ install:- - cabal update  # We intentionally do not install anything before trying to build Cabal because  # it should build with each supported GHC version out-of-the-box. @@ -31,8 +110,34 @@ # ./dist/setup/setup here instead of cabal-install to avoid breakage when the # build config format changed. script:- - ./travis-script.sh+ - ./travis-${SCRIPT}.sh -matrix:-  allow_failures:-   - env: GHCVER=head+cache:+ directories:+ - $HOME/.cabal/packages+ - $HOME/.cabal/store+ - $HOME/.cabal/bin++ - $HOME/.stack/bin+ - $HOME/.stack/precompiled+ - $HOME/.stack/programs+ - $HOME/.stack/setup-exe-cache+ - $HOME/.stack/snapshots++# We remove the index because it churns quite a bit and we don't want+# to pay the cost of repeatedly caching it even though we don't care+# about most changing packages.+before_cache:+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index*+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json++# Deploy Haddocks to the haskell/cabal-website repo.+after_success:+ - ./travis-deploy.sh++notifications:+  irc:+    channels:+      - "chat.freenode.net##haskell-cabal"+  slack: haskell-cabal:sCq6GLfy9N8MJrInosg871n4
+ cabal/AUTHORS view
@@ -0,0 +1,265 @@+Abhinav Gupta            <mail@abhinavg.net>+Adam Bergmark            <adam@bergmark.nl>+Adam C. Foltzer          <acfoltzer@galois.com>+Adam Gundry              <adam@well-typed.com>+Adam Langley             <agl@imperialviolet.org>+Adam Sandberg Eriksson   <adam@sandbergericsson.se>+Alan Zimmerman           <alan.zimm@gmail.com>+Albert Krewinkel         <tarleb@moltkeplatz.de>+Alexander Kjeldaas       <alexander.kjeldaas@gmail.com>+Alexander Vershilov      <alexander.vershilov@gmail.com>+Alistair Bailey          <alistair@abayley.org>+Alson Kemp               <alson@alsonkemp.com>+Anders Kaseorg           <andersk@mit.edu>+Andrea Vezzosi           <sanzhiyan@gmail.com>+Andres Löh               <andres.loeh@gmail.com>+Andrzej Rybczak          <electricityispower@gmail.com>+Andrés Sicard-Ramírez    <andres.sicard.ramirez@gmail.com>+Andy Craze               <accraze@gmail.com>+Angus Lepper             <angus.lepper@gmail.com>+Antoine Latter           <aslatter@gmail.com>+Anton Dessiatov          <anton.dessiatov@gmail.com>+Antonio Nikishaev        <a@lelf.me>+Arian van Putten         <aeroboy94@gmail.com>+Arun Tejasvi Chaganty    <arunchaganty@gmail.com>+Atze Dijkstra            <atze@cs.uu.nl>+Audrey Tang              <audreyt@audreyt.org>+Austin Seipp             <aseipp@pobox.com>+Bardur Arantsson         <bardur@scientician.net>+Bartosz Nitka            <bnitka@fb.com>+Bas van Dijk             <v.dijk.bas@gmail.com>+Ben Armston              <ben.armston@googlemail.com>+Ben Doyle                <benjamin.peter.doyle@gmail.com>+Ben Gamari               <ben@smart-cactus.org>+Ben Millwood             <thebenmachine+git@gmail.com>+Benedikt Huber           <benedikt.huber@gmail.com>+Benjamin Herr            <ben@0x539.de>+Benno Fünfstück          <benno.fuenfstueck@gmail.com>+Bertram Felgenhauer      <int-e@gmx.de>+Björn Bringert           <bjorn@bringert.net>+Björn Peemöller          <bjp@informatik.uni-kiel.de>+Bob Ippolito             <bob@redivi.com>+Bram Schuur              <bramschuur@gmail.com>+Brendan Hay              <brendan.g.hay@gmail.com>+Brent Yorgey             <byorgey@gmail.com>+Brian Smith              <brianlsmith@gmail.com>+Bryan O'Sullivan         <bos@serpentine.com>+Bryan Richter            <bryan.richter@gmail.com>+Carter Tazio Schonwald   <carter.schonwald@gmail.com>+Chris Allen              <cma@bitemyapp.com>+Chris Wong               <lambda.fairy@gmail.com>+Christiaan Baaij         <christiaan.baaij@gmail.com>+Clemens Fruhwirth        <clemens@endorphin.org>+Clint Adams              <clint@debian.org>+Conal Elliott            <conal@conal.net>+Curtis Gagliardi         <curtis@curtis.io>+Dan Burton               <danburton.email@gmail.com>+Daniel Buckmaster        <dan.buckmaster@gmail.com>+Daniel Trstenjak         <daniel.trstenjak@gmail.com>+Daniel Velkov            <norcobg@gmail.com>+Daniel Wagner            <daniel@wagner-home.com>+Danny Navarro            <j@dannynavarro.net>+David Feuer              <David.Feuer@gmail.com>+David Fox                <dsf@seereason.com>+David Himmelstrup        <lemmih@gmail.com>+David Lazar              <lazar6@illinois.edu>+David Luposchainsky      <dluposchainsky@gmail.com>+David McFarland          <corngood@gmail.com>+David Terei              <davidterei@gmail.com>+David Waern              <davve@dtek.chalmers.se>+Dennis Gosnell           <cdep.illabout@gmail.com>+Dino Morelli             <dino@ui3.info>+Dmitry Astapov           <dastapov@gmail.com>+Dominic Steinitz         <dominic@steinitz.org>+Don Stewart              <dons@galois.com>+Doug Beardsley           <mightybyte@gmail.com>+Duncan Coutts            <duncan@community.haskell.org>+Echo Nolan               <echo@echonolan.net>+Edsko de Vries           <edsko@well-typed.com>+Edward Z. Yang           <ezyang@cs.stanford.edu>+Einar Karttunen          <ekarttun@cs.helsinki.fi>+Eric Kow                 <eric.kow@gmail.com>+Eric Seidel              <gridaphobe@gmail.com>+Erik Hesselink           <hesselink@gmail.com>+Erik Rantapaa            <erantapaa@gmail.com>+Erik de Castro Lopo      <erikd@mega-nerd.com>+Esa Ilari Vuokko         <ei@vuokko.info>+Eugene Sukhodolin        <eugene@sukhodolin.com>+Eyal Lotem               <eyal.lotem@gmail.com>+Fabián Orccón            <fabian.orccon@pucp.pe>+Federico Mastellone      <fmaste@users.noreply.github.com>+Florian Hartwig          <florian.j.hartwig@gmail.com>+Franz Thoma              <franz.thoma@tngtech.com>+Fujimura Daisuke         <me@fujimuradaisuke.com>+Gabor Greif              <ggreif@gmail.com>+Gabor Pali               <pali.gabor@gmail.com>+Ganesh Sittampalam       <ganesh.sittampalam@credit-suisse.com>+Geoff Nixon              <geoff-codes@users.noreply.github.com>+Gershom Bazerman         <gershomb@gmail.com>+Getty Ritter             <gdritter@galois.com>+Gleb Alexeev             <gleb.alexeev@gmail.com>+Gregory Collins          <greg@gregorycollins.net>+Gwern Branwen            <gwern0@gmail.com>+Haisheng.Wu              <freizl@gmail.com>+Harry Garrood            <harry@garrood.me>+Heather                  <heather@live.ru>+Henk-Jan van Tuyl        <hjgtuyl@chello.nl>+Henning Günther          <der_eq@freenet.de>+Henning Thielemann       <lemming@henning-thielemann.de>+Herbert Valerio Riedel   <hvr@gnu.org>+Iain Nicol               <iain@iainnicol.com>+Ian D. Bollinger         <ian.bollinger@gmail.com>+Ian Lynagh               <igloo@earth.li>+Ian Ross                 <ian@skybluetrades.net>+Ilya Smelkov             <triplepointfive@gmail.com>+Isaac Potoczny-Jones     <ijones@syntaxpolice.org>+Isamu Mogi               <saturday6c@gmail.com>+Iustin Pop               <iusty@k1024.org>+Iñaki García Etxebarria  <garetxe@gmail.com>+JP Moresmau              <jp@moresmau.fr>+Jacco Krijnen            <jaccokrijnen@gmail.com>+Jack Henahan             <jhenahan@uvm.edu>+Jake Wheat               <jakewheatmail@gmail.com>+Jason Dagit              <dagitj@gmail.com>+Jean-Philippe Bernardy   <jeanphilippe.bernardy@gmail.com>+Jens Petersen            <juhpetersen@gmail.com>+Jeremy Shaw              <jeremy.shaw@linspireinc.com>+Jim Burton               <jim@sdf-eu.org>+Joachim Breitner         <mail@joachim-breitner.de>+Joe Quinn                <headprogrammingczar@gmail.com>+Joel Stanley             <intractable@gmail.com>+Joeri van Eekelen        <tchakkazulu@gmail.com>+Johan Tibell             <johan.tibell@gmail.com>+John Chee                <cheecheeo@gmail.com>+John D. Ramsdell         <ramsdell@mitre.org>+John Dias                <dias@eecs.harvard.edu>+John Ericson             <Ericson2314@yahoo.com>+John Lato                <jwlato@tsurucapital.com>+John Wiegley             <johnw@fpcomplete.com>+Jonathan Daugherty       <jtd@galois.com>+Jookia                   <166291@gmail.com>+Josef Svenningsson       <josef.svenningsson@gmail.com>+Josh Hoyt                <josh.hoyt@galois.com>+Judah Jacobson           <judah.jacobson@gmail.com>+Jürgen Nicklisch-Franken <jnf@arcor.de>+Karel Gardas             <karel.gardas@centrum.cz>+Keegan McAllister        <mcallister.keegan@gmail.com>+Ken Bateman              <novadenizen@gmail.com>+Keshav Kini              <kkini@galois.com>+Kido Takahiro            <shelarcy@gmail.com>+Krasimir Angelov         <kr.angelov@gmail.com>+Kristen Kozak            <grayjay@wordroute.com>+Lennart Kolmodin         <kolmodin@gmail.com>+Lennart Spitzner         <lsp@informatik.uni-kiel.de>+Leonid Onokhov           <sopvop@gmail.com>+Liyang HU                <git@liyang.hu>+Luite Stegeman           <stegeman@gmail.com>+Luke Iannini             <lukexi@me.com>+M Farkas-Dyck            <strake888@gmail.com>+Maciek Makowski          <maciek.makowski@gmail.com>+Magnus Jonsson           <magnus@smartelectronix.com>+Malcolm Wallace          <Malcolm.Wallace@me.com>+Mark Lentczner           <markl@glyphic.com>+Mark Weber               <marco-oweber@gmx.de>+Markus Pfeiffer          <markusp@mcs.st-andrews.ac.uk>+Martin Sjögren           <msjogren@gmail.com>+Martin Vlk               <martin@vlkk.cz>+Masahiro Yamauchi        <sgt.yamauchi@gmail.com>+Mathieu Boespflug        <mboes@tweag.net>+Matthew William Cox      <matt@mattcox.ca>+Matthias Fischmann       <mf@zerobuzz.net>+Matthias Kilian          <kili@outback.escape.de>+Matthias Pronk           <git@masida.nl>+Max Amanshauser          <max@lambdalifting.org>+Max Bolingbroke          <batterseapower@hotmail.com>+Maximilian Tagher        <feedback.tagher@gmail.com>+Maxwell Swadling         <maxwellswadling@gmail.com>+Merijn Verstraaten       <merijn@inconsistent.nl>+Michael Sloan            <mgsloan@gmail.com>+Michael Snoyman          <michael@snoyman.com>+Michael Thompson         <what_is_it_to_do_anything@yahoo.com>+Michael Tolly            <miketolly@gmail.com>+Mike Craig               <mcraig@groupon.com>+Mikhail Glushenkov       <mikhail.glushenkov@gmail.com>+Misty De Meo             <mistydemeo@gmail.com>+Miëtek Bak               <mietek@bak.io>+Mohit Agarwal            <mohit@sdf.org>+Moritz Kiefer            <moritz.kiefer@purelyfunctional.org>+Nathan Howell            <nhowell@alphaheavy.com>+Neil Mitchell            <ndmitchell@gmail.com>+Neil Vice                <sardonicpresence@gmail.com>+Nick Alexander           <ncalexan@uci.edu>+Nick Smallbone           <nick.smallbone@gmail.com>+Nikita Karetnikov        <nikita@karetnikov.org>+Niklas Broberg           <niklas.broberg@gmail.com>+Niklas Hambüchen         <mail@nh2.me>+Oleg Grenrus             <oleg.grenrus@iki.fi>+Oleksandr Manzyuk        <manzyuk@gmail.com>+Omar Mefire              <omefire@gmail.com>+Owen Stephens            <owen@owenstephens.co.uk>+Paolo Capriotti          <p.capriotti@gmail.com>+Paolo G. Giarrusso       <p.giarrusso@gmail.com>+Paolo Losi               <paolo.losi@gmail.com>+Paolo Martini            <paolo@nemail.it>+Patrick Premont          <ppremont@cognimeta.com>+Patryk Zadarnowski       <pat@jantar.org>+Pepe Iborra              <mnislaih@gmail.com>+Peter Higley             <phigley@gmail.com>+Peter Robinson           <thaldyron@gmail.com>+Peter Selinger           <selinger@mathstat.dal.ca>+Peter Simons             <simons@cryp.to>+Peter Trško              <peter.trsko@gmail.com>+Phil Ruffwind            <rf@rufflewind.com>+Philipp Schuster         <pschuster@uni-koblenz.de>+Prayag Verma             <prayag.verma@gmail.com>+Randy Polen              <randen@users.noreply.github.com>+Reid Barton              <rwbarton@gmail.com>+Richard Eisenberg        <eir@cis.upenn.edu>+Ricky Elrod              <ricky@elrod.me>+Robert Collins           <robertc@robertcollins.net>+Roberto Zunino           <zunrob@users.sf.net>+Robin Green              <greenrd@greenrd.org>+Robin KAY                <komadori@gekkou.co.uk>+Roman Cheplyaka          <roma@ro-che.info>+Ross Paterson            <ross@soi.city.ac.uk>+Rudy Matela              <rudy@matela.com.br>+Ryan Desfosses           <ryan@desfo.org>+Ryan Mulligan            <ryan@ryantm.com>+Ryan Newton              <rrnewton@gmail.com>+Ryan Scott               <ryan.gl.scott@gmail.com>+Ryan Trinkle             <ryan.trinkle@gmail.com>+RyanGlScott              <ryan.gl.scott@gmail.com>+Samuel Bronson           <naesten@gmail.com>+Samuel Gélineau          <gelisam+github@gmail.com>+Sergei Trofimovich       <slyfox@community.haskell.org>+Sergey Vinokurov         <serg.foo@gmail.com>+Sigbjorn Finne           <sof@galois.com>+Simon Hengel             <sol@typeful.net>+Simon Jakobi             <simon.jakobi@gmail.com>+Simon Marlow             <marlowsd@gmail.com>+Simon Meier              <iridcode@gmail.com>+Simon Peyton Jones       <simonpj@microsoft.com>+Spencer Janssen          <sjanssen@cse.unl.edu>+Stephen Blackheath       <stephen.blackheath@ipwnstudios.com>+Sven Panne               <sven.panne@aedion.de>+Sönke Hahn               <shahn@joyridelabs.de>+Taru Karttunen           <taruti@taruti.net>+Thomas Dziedzic          <gostrc@gmail.com>+Thomas M. DuBuisson      <thomas.dubuisson@gmail.com>+Thomas Miedema           <thomasmiedema@gmail.com>+Thomas Schilling         <nominolo@gmail.com>+Thomas Tuegel            <ttuegel@gmail.com>+Tillmann Rendel          <rendel@informatik.uni-marburg.de>+Tim Chevalier            <chevalier@alum.wellesley.edu>+Tim Humphries            <tim.humphries@ambiata.com>+Tomas Vestelind          <tomas.vestelind@gmail.com>+Toshio Ito               <debug.ito@gmail.com>+Travis Cardwell          <travis.cardwell@extellisys.com>+Tuncer Ayaz              <tuncer.ayaz@gmail.com>+Vincent Hanquez          <vincent@snarc.org>+Vo Minh Thu              <noteed@gmail.com>+Wojciech Danilo          <wojtek.danilo@gmail.com>+Yitzchak Gale            <gale@sefer.org>+Yuras Shumovich          <shumovichy@gmail.com>+capsjac                  <capsjac@gmail.com>+Łukasz Dąbek             <sznurek@gmail.com>
cabal/Cabal/Cabal.cabal view
@@ -1,15 +1,13 @@-name: Cabal-version: 1.25.0.0-copyright: 2003-2006, Isaac Jones-           2005-2011, Duncan Coutts-license: BSD3-license-file: LICENSE-author: Isaac Jones <ijones@syntaxpolice.org>-        Duncan Coutts <duncan@community.haskell.org>-maintainer: cabal-devel@haskell.org-homepage: http://www.haskell.org/cabal/-bug-reports: https://github.com/haskell/cabal/issues-synopsis: A framework for packaging Haskell software+name:          Cabal+version:       1.25.0.0+copyright:     2003-2016, Cabal Development Team (see AUTHORS file)+license:       BSD3+license-file:  LICENSE+author:        Cabal Development Team <cabal-devel@haskell.org>+maintainer:    cabal-devel@haskell.org+homepage:      http://www.haskell.org/cabal/+bug-reports:   https://github.com/haskell/cabal/issues+synopsis:      A framework for packaging Haskell software description:   The Haskell Common Architecture for Building Applications and   Libraries: a framework defining a common interface for authors to more@@ -17,187 +15,37 @@   .   The Haskell Cabal is part of a larger infrastructure for distributing,   organizing, and cataloging Haskell libraries and tools.-category: Distribution-cabal-version: >=1.10-build-type: Simple+category:       Distribution+cabal-version:  >=1.10+build-type:     Simple -- If we use a new Cabal feature, this needs to be changed to Custom so -- we can bootstrap.  extra-source-files:   README.md tests/README.md changelog-  doc/developing-packages.markdown doc/index.markdown-  doc/installing-packages.markdown-  doc/misc.markdown+  doc/bugs-and-stability.rst doc/concepts-and-development.rst+  doc/conf.py doc/config-and-install.rst doc/developing-packages.rst+  doc/images/Cabal-dark.png doc/index.rst doc/installing-packages.rst+  doc/intro.rst doc/misc.rst doc/nix-local-build-overview.rst+  doc/nix-local-build.rst doc/README.md doc/references.inc    -- Generated with 'misc/gen-extra-source-files.sh'   -- Do NOT edit this section manually; instead, run the script.   -- BEGIN gen-extra-source-files-  tests/PackageTests/AllowNewer/AllowNewer.cabal-  tests/PackageTests/AllowNewer/benchmarks/Bench.hs-  tests/PackageTests/AllowNewer/src/Foo.hs-  tests/PackageTests/AllowNewer/tests/Test.hs-  tests/PackageTests/BenchmarkExeV10/Foo.hs-  tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs-  tests/PackageTests/BenchmarkExeV10/my.cabal-  tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal-  tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs-  tests/PackageTests/BenchmarkStanza/my.cabal-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal-  tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs-  tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal-  tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs-  tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal-  tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal-  tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal-  tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs-  tests/PackageTests/BuildableField/BuildableField.cabal-  tests/PackageTests/BuildableField/Main.hs-  tests/PackageTests/CMain/Bar.hs-  tests/PackageTests/CMain/foo.c-  tests/PackageTests/CMain/my.cabal-  tests/PackageTests/Configure/A.hs-  tests/PackageTests/Configure/Setup.hs-  tests/PackageTests/Configure/X11.cabal-  tests/PackageTests/CopyComponent/Exe/Main.hs-  tests/PackageTests/CopyComponent/Exe/Main2.hs-  tests/PackageTests/CopyComponent/Exe/myprog.cabal-  tests/PackageTests/CopyComponent/Lib/Main.hs-  tests/PackageTests/CopyComponent/Lib/p.cabal-  tests/PackageTests/CopyComponent/Lib/src/P.hs-  tests/PackageTests/CustomPreProcess/Hello.hs-  tests/PackageTests/CustomPreProcess/MyCustomPreprocessor.hs-  tests/PackageTests/CustomPreProcess/Setup.hs-  tests/PackageTests/CustomPreProcess/internal-preprocessor-test.cabal-  tests/PackageTests/DeterministicAr/Lib.hs-  tests/PackageTests/DeterministicAr/my.cabal-  tests/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal-  tests/PackageTests/DuplicateModuleName/src/Foo.hs-  tests/PackageTests/DuplicateModuleName/tests/Foo.hs-  tests/PackageTests/DuplicateModuleName/tests2/Foo.hs-  tests/PackageTests/EmptyLib/empty/empty.cabal-  tests/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal-  tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-  tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg-  tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal-  tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10-  tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10-  tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal-  tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10-  tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10-  tests/PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal-  tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc-  tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg-  tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal-  tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10-  tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10-  tests/PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal-  tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10-  tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10-  tests/PackageTests/Haddock/CPP.hs-  tests/PackageTests/Haddock/Literate.lhs-  tests/PackageTests/Haddock/NoCPP.hs-  tests/PackageTests/Haddock/Simple.hs-  tests/PackageTests/Haddock/my.cabal-  tests/PackageTests/HaddockNewline/A.hs-  tests/PackageTests/HaddockNewline/HaddockNewline.cabal-  tests/PackageTests/HaddockNewline/Setup.hs-  tests/PackageTests/InternalLibraries/Executable/exe/Main.hs-  tests/PackageTests/InternalLibraries/Executable/foo.cabal-  tests/PackageTests/InternalLibraries/Executable/src/Foo.hs-  tests/PackageTests/InternalLibraries/Library/fooexe/Main.hs-  tests/PackageTests/InternalLibraries/Library/fooexe/fooexe.cabal-  tests/PackageTests/InternalLibraries/Library/foolib/Foo.hs-  tests/PackageTests/InternalLibraries/Library/foolib/foolib.cabal-  tests/PackageTests/InternalLibraries/Library/foolib/private/Internal.hs-  tests/PackageTests/InternalLibraries/p/Foo.hs-  tests/PackageTests/InternalLibraries/p/p.cabal-  tests/PackageTests/InternalLibraries/p/p/P.hs-  tests/PackageTests/InternalLibraries/p/q/Q.hs-  tests/PackageTests/InternalLibraries/q/Q.hs-  tests/PackageTests/InternalLibraries/q/q.cabal-  tests/PackageTests/Macros/A.hs-  tests/PackageTests/Macros/B.hs-  tests/PackageTests/Macros/Main.hs-  tests/PackageTests/Macros/macros.cabal-  tests/PackageTests/Macros/src/C.hs-  tests/PackageTests/Options.hs-  tests/PackageTests/OrderFlags/Foo.hs-  tests/PackageTests/OrderFlags/my.cabal-  tests/PackageTests/PathsModule/Executable/Main.hs-  tests/PackageTests/PathsModule/Executable/my.cabal-  tests/PackageTests/PathsModule/Library/my.cabal-  tests/PackageTests/PreProcess/Foo.hsc-  tests/PackageTests/PreProcess/Main.hs-  tests/PackageTests/PreProcess/my.cabal-  tests/PackageTests/PreProcessExtraSources/Foo.hsc-  tests/PackageTests/PreProcessExtraSources/Main.hs-  tests/PackageTests/PreProcessExtraSources/my.cabal-  tests/PackageTests/ReexportedModules/ReexportedModules.cabal-  tests/PackageTests/TemplateHaskell/dynamic/Exe.hs-  tests/PackageTests/TemplateHaskell/dynamic/Lib.hs-  tests/PackageTests/TemplateHaskell/dynamic/TH.hs-  tests/PackageTests/TemplateHaskell/dynamic/my.cabal-  tests/PackageTests/TemplateHaskell/profiling/Exe.hs-  tests/PackageTests/TemplateHaskell/profiling/Lib.hs-  tests/PackageTests/TemplateHaskell/profiling/TH.hs-  tests/PackageTests/TemplateHaskell/profiling/my.cabal-  tests/PackageTests/TemplateHaskell/vanilla/Exe.hs-  tests/PackageTests/TemplateHaskell/vanilla/Lib.hs-  tests/PackageTests/TemplateHaskell/vanilla/TH.hs-  tests/PackageTests/TemplateHaskell/vanilla/my.cabal-  tests/PackageTests/TestNameCollision/child/Child.hs-  tests/PackageTests/TestNameCollision/child/child.cabal-  tests/PackageTests/TestNameCollision/child/tests/Test.hs-  tests/PackageTests/TestNameCollision/parent/Parent.hs-  tests/PackageTests/TestNameCollision/parent/parent.cabal-  tests/PackageTests/TestOptions/TestOptions.cabal-  tests/PackageTests/TestOptions/test-TestOptions.hs-  tests/PackageTests/TestStanza/my.cabal-  tests/PackageTests/TestSuiteTests/ExeV10/Foo.hs-  tests/PackageTests/TestSuiteTests/ExeV10/my.cabal-  tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs-  tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs-  tests/PackageTests/TestSuiteTests/LibV09/Lib.hs-  tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal-  tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs-  tests/PackageTests/Tests.hs-  tests/PackageTests/UniqueIPID/P1/M.hs-  tests/PackageTests/UniqueIPID/P1/my.cabal-  tests/PackageTests/UniqueIPID/P2/M.hs-  tests/PackageTests/UniqueIPID/P2/my.cabal-  tests/PackageTests/multInst/my.cabal-  tests/Setup.hs+  tests/ParserTests/warnings/bom.cabal+  tests/ParserTests/warnings/bool.cabal+  tests/ParserTests/warnings/deprecatedfield.cabal+  tests/ParserTests/warnings/extratestmodule.cabal+  tests/ParserTests/warnings/gluedop.cabal+  tests/ParserTests/warnings/nbsp.cabal+  tests/ParserTests/warnings/newsyntax.cabal+  tests/ParserTests/warnings/oldsyntax.cabal+  tests/ParserTests/warnings/subsection.cabal+  tests/ParserTests/warnings/trailingfield.cabal+  tests/ParserTests/warnings/unknownfield.cabal+  tests/ParserTests/warnings/unknownsection.cabal+  tests/ParserTests/warnings/utf8.cabal+  tests/ParserTests/warnings/versiontag.cabal   tests/hackage/check.sh   tests/hackage/download.sh   tests/hackage/unpack.sh@@ -212,6 +60,20 @@ flag bundled-binary-generic   default: False +flag old-directory+  description:  Use directory < 1.2 and old-time+  default:      False++flag parsec+  description:  Use parsec parser+  default:      False+  manual:       True++flag parsec-struct-diff+  description:  Use StructDiff in parsec tests. Affects only parsec tests.+  default:      False+  manual:       True+ library   build-depends:     array      >= 0.1 && < 0.6,@@ -219,12 +81,18 @@     bytestring >= 0.9 && < 1,     containers >= 0.4 && < 0.6,     deepseq    >= 1.3 && < 1.5,-    directory  >= 1.1 && < 1.3,     filepath   >= 1.3 && < 1.5,     pretty     >= 1.1 && < 1.2,     process    >= 1.1.0.1 && < 1.5,     time       >= 1.4 && < 1.7 +  if flag(old-directory)+    build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2,+                   process   >= 1.0.1.1  && < 1.1.0.2+  else+    build-depends: directory >= 1.2 && < 1.3,+                   process   >= 1.1.0.2  && < 1.5+   if flag(bundled-binary-generic)     build-depends: binary >= 0.5 && < 0.7   else@@ -248,18 +116,34 @@                  -Wnoncanonical-monadfail-instances    exposed-modules:+    Distribution.Backpack+    Distribution.Backpack.Configure+    Distribution.Backpack.ComponentsGraph+    Distribution.Backpack.ConfiguredComponent+    Distribution.Backpack.FullUnitId+    Distribution.Backpack.LinkedComponent+    Distribution.Backpack.ModSubst+    Distribution.Backpack.ModuleShape+    Distribution.Utils.LogProgress+    Distribution.Utils.MapAccum     Distribution.Compat.CreatePipe     Distribution.Compat.Environment     Distribution.Compat.Exception+    Distribution.Compat.Graph     Distribution.Compat.Internal.TempFile+    Distribution.Compat.Prelude.Internal     Distribution.Compat.ReadP     Distribution.Compat.Semigroup+    Distribution.Compat.Stack+    Distribution.Compat.Time+    Distribution.Compat.DList     Distribution.Compiler     Distribution.InstalledPackageInfo     Distribution.License     Distribution.Make     Distribution.ModuleName     Distribution.Package+    Distribution.Package.TextClass     Distribution.PackageDescription     Distribution.PackageDescription.Check     Distribution.PackageDescription.Configuration@@ -267,6 +151,7 @@     Distribution.PackageDescription.PrettyPrint     Distribution.PackageDescription.Utils     Distribution.ParseUtils+    Distribution.PrettyUtils     Distribution.ReadE     Distribution.Simple     Distribution.Simple.Bench@@ -319,17 +204,81 @@     Distribution.System     Distribution.TestSuite     Distribution.Text+    Distribution.Types.Benchmark+    Distribution.Types.BenchmarkInterface+    Distribution.Types.BenchmarkType+    Distribution.Types.BuildInfo+    Distribution.Types.BuildType+    Distribution.Types.Executable+    Distribution.Types.Library+    Distribution.Types.ForeignLib+    Distribution.Types.ForeignLibType+    Distribution.Types.ForeignLibOption+    Distribution.Types.ModuleReexport+    Distribution.Types.ModuleRenaming+    Distribution.Types.IncludeRenaming+    Distribution.Types.Mixin+    Distribution.Types.SetupBuildInfo+    Distribution.Types.TestSuite+    Distribution.Types.TestSuiteInterface+    Distribution.Types.TestType+    Distribution.Types.ComponentName+    Distribution.Types.GenericPackageDescription+    Distribution.Types.HookedBuildInfo+    Distribution.Types.PackageDescription+    Distribution.Types.SourceRepo+    Distribution.Types.Component+    Distribution.Types.ComponentLocalBuildInfo+    Distribution.Types.LocalBuildInfo+    Distribution.Types.ComponentRequestedSpec+    Distribution.Types.TargetInfo     Distribution.Utils.NubList+    Distribution.Utils.ShortText+    Distribution.Utils.Progress+    Distribution.Utils.BinaryWithFingerprint     Distribution.Verbosity     Distribution.Version     Language.Haskell.Extension     Distribution.Compat.Binary +  if flag(parsec)+    cpp-options: -DCABAL_PARSEC+    build-depends:+      transformers,+      parsec >= 3.1.9 && <3.2+    build-tools:+      alex >=3.1.4 && <3.3+    exposed-modules:+      Distribution.Compat.Parsec+      Distribution.PackageDescription.Parsec+      Distribution.PackageDescription.Parsec.FieldDescr+      Distribution.Parsec.Class+      Distribution.Parsec.ConfVar+      Distribution.Parsec.Lexer+      Distribution.Parsec.LexerMonad+      Distribution.Parsec.Parser+      Distribution.Parsec.Types.Common+      Distribution.Parsec.Types.Field+      Distribution.Parsec.Types.FieldDescr+      Distribution.Parsec.Types.ParseResult+   other-modules:+    Distribution.Backpack.PreExistingComponent+    Distribution.Backpack.ReadyComponent+    Distribution.Backpack.MixLink+    Distribution.Backpack.ModuleScope+    Distribution.Backpack.UnifyM+    Distribution.Backpack.Id+    Distribution.Utils.UnionFind+    Distribution.Utils.Base62     Distribution.Compat.CopyFile+    Distribution.Compat.GetShortPathName     Distribution.Compat.MonadFail+    Distribution.Compat.Prelude+    Distribution.Compat.SnocList     Distribution.GetOpt     Distribution.Lex+    Distribution.Utils.String     Distribution.Simple.GHC.Internal     Distribution.Simple.GHC.IPI642     Distribution.Simple.GHC.IPIConvert@@ -341,11 +290,37 @@       Distribution.Compat.Binary.Class       Distribution.Compat.Binary.Generic -  default-language: Haskell98-  -- starting with GHC 7.0, rely on {-# LANGUAGE CPP #-} instead-  if !impl(ghc >= 7.0)-    default-extensions: CPP+  default-language: Haskell2010+  other-extensions:+    BangPatterns+    CPP+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    GeneralizedNewtypeDeriving+    ImplicitParams+    KindSignatures+    NondecreasingIndentation+    OverloadedStrings+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    Trustworthy+    TypeFamilies+    TypeOperators+    TypeSynonymInstances+    UndecidableInstances +  if impl(ghc >= 7.11)+    other-extensions: PatternSynonyms+ -- Small, fast running tests. test-suite unit-tests   type: exitcode-stdio-1.0@@ -355,51 +330,77 @@     Test.QuickCheck.Utils     UnitTests.Distribution.Compat.CreatePipe     UnitTests.Distribution.Compat.ReadP+    UnitTests.Distribution.Compat.Time+    UnitTests.Distribution.Compat.Graph     UnitTests.Distribution.Simple.Program.Internal     UnitTests.Distribution.Simple.Utils     UnitTests.Distribution.System     UnitTests.Distribution.Utils.NubList+    UnitTests.Distribution.Utils.ShortText     UnitTests.Distribution.Version   main-is: UnitTests.hs   build-depends:+    array,     base,+    containers,     directory,+    filepath,     tasty,     tasty-hunit,     tasty-quickcheck,+    tagged,     pretty,-    QuickCheck >= 2.7 && < 2.9,+    QuickCheck >= 2.7 && < 2.10,     Cabal   ghc-options: -Wall-  default-language: Haskell98+  default-language: Haskell2010 --- Large, system tests that build packages.-test-suite package-tests+test-suite parser-tests+  if !flag(parsec)+    buildable: False+   type: exitcode-stdio-1.0-  main-is: PackageTests.hs-  other-modules:-    PackageTests.BenchmarkStanza.Check-    PackageTests.TestStanza.Check-    PackageTests.DeterministicAr.Check-    PackageTests.TestSuiteTests.ExeV10.Check-    PackageTests.PackageTester   hs-source-dirs: tests+  main-is: ParserTests.hs   build-depends:     base,-    containers,-    tagged,+    bytestring,+    filepath,     tasty,     tasty-hunit,-    transformers,-    Cabal,-    process,+    tasty-quickcheck,+    Cabal+  ghc-options: -Wall+  default-language: Haskell2010++test-suite parser-hackage-tests+  if !flag(parsec)+    buildable: False++  type: exitcode-stdio-1.0+  main-is: ParserHackageTests.hs++  hs-source-dirs: tests+  build-depends:+    base,+    containers,+    tar >=0.5 && <0.6,+    bytestring,     directory,     filepath,-    bytestring,-    regex-posix,-    old-time-  if !os(windows)-    build-depends: unix+    Cabal++  if flag(parsec-struct-diff)+    build-depends:+      generics-sop ==0.2.*,+      these >=0.7.1 && <0.8,+      singleton-bool >=0.1.1.0 && <0.2,+      keys+    other-modules:+      DiffInstances+      StructDiff+    cpp-options: -DHAS_STRUCT_DIFF+   ghc-options: -Wall -rtsopts   default-extensions: CPP-  default-language: Haskell98+  default-language: Haskell2010
+ cabal/Cabal/Distribution/Backpack.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | This module defines the core data types for Backpack.  For more+-- details, see:+--+--  <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>++module Distribution.Backpack (+    -- * OpenUnitId+    OpenUnitId(..),+    openUnitIdFreeHoles,+    mkOpenUnitId,++    -- * DefUnitId+    DefUnitId,+    unDefUnitId,+    mkDefUnitId,++    -- * OpenModule+    OpenModule(..),+    openModuleFreeHoles,++    -- * OpenModuleSubst+    OpenModuleSubst,+    dispOpenModuleSubst,+    dispOpenModuleSubstEntry,+    parseOpenModuleSubst,+    parseOpenModuleSubstEntry,+    openModuleSubstFreeHoles,++    -- * Conversions to 'UnitId'+    abstractUnitId,+    hashModuleSubst,+) where++import Prelude ()+import Distribution.Compat.Prelude hiding (mod)+import Distribution.Compat.ReadP+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint (hcat)++import Distribution.ModuleName+import Distribution.Package+import Distribution.Text+import Distribution.Utils.Base62++import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++-----------------------------------------------------------------------+-- OpenUnitId++-- | An 'OpenUnitId' describes a (possibly partially) instantiated+-- Backpack component, with a description of how the holes are filled+-- in.  Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured+-- form that allows for substitution (which fills in holes.) This form+-- of unit cannot be installed. It must first be converted to a+-- 'UnitId'.+--+-- In the absence of Backpack, there are no holes to fill, so any such+-- component always has an empty module substitution; thus we can lossly+-- represent it as an 'OpenUnitId uid'.+--+-- For a source component using Backpack, however, there is more+-- structure as components may be parametrized over some signatures, and+-- these \"holes\" may be partially or wholly filled.+--+-- OpenUnitId plays an important role when we are mix-in linking,+-- and is recorded to the installed packaged database for indefinite+-- packages; however, for compiled packages that are fully instantiated,+-- we instantiate 'OpenUnitId' into 'UnitId'.+--+-- For more details see the Backpack spec+-- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+--++data OpenUnitId+    -- | Identifies a component which may have some unfilled holes;+    -- specifying its 'ComponentId' and its 'OpenModuleSubst'.+    -- TODO: Invariant that 'OpenModuleSubst' is non-empty?+    -- See also the Text instance.+    = IndefFullUnitId ComponentId OpenModuleSubst+    -- | Identifies a fully instantiated component, which has+    -- been compiled and abbreviated as a hash.  The embedded 'UnitId'+    -- MUST NOT be for an indefinite component; an 'OpenUnitId'+    -- is guaranteed not to have any holes.+    | DefiniteUnitId DefUnitId+  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)+-- TODO: cache holes?++instance Binary OpenUnitId++instance NFData OpenUnitId where+    rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst+    rnf (DefiniteUnitId uid) = rnf uid++instance Text OpenUnitId where+    disp (IndefFullUnitId cid insts)+        -- TODO: arguably a smart constructor to enforce invariant would be+        -- better+        | Map.null insts = disp cid+        | otherwise      = disp cid <<>> Disp.brackets (dispOpenModuleSubst insts)+    disp (DefiniteUnitId uid) = disp uid+    parse = parseOpenUnitId <++ fmap DefiniteUnitId parse+      where+        parseOpenUnitId = do+            cid <- parse+            insts <- Parse.between (Parse.char '[') (Parse.char ']')+                       parseOpenModuleSubst+            return (IndefFullUnitId cid insts)++-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.+openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName+openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts+openUnitIdFreeHoles _ = Set.empty++-- | Safe constructor from a UnitId.  The only way to do this safely+-- is if the instantiation is provided.+mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId+mkOpenUnitId uid cid insts =+    if Set.null (openModuleSubstFreeHoles insts)+        then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!+        else IndefFullUnitId cid insts++-----------------------------------------------------------------------+-- DefUnitId++-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation+-- with no holes.+mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId+mkDefUnitId cid insts =+    unsafeMkDefUnitId (mkUnitId+        (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts)))+        -- impose invariant!++-----------------------------------------------------------------------+-- OpenModule++-- | Unlike a 'Module', an 'OpenModule' is either an ordinary+-- module from some unit, OR an 'OpenModuleVar', representing a+-- hole that needs to be filled in.  Substitutions are over+-- module variables.+data OpenModule+    = OpenModule OpenUnitId ModuleName+    | OpenModuleVar ModuleName+  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)++instance Binary OpenModule++instance NFData OpenModule where+    rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name+    rnf (OpenModuleVar mod_name) = rnf mod_name++instance Text OpenModule where+    disp (OpenModule uid mod_name) =+        hcat [disp uid, Disp.text ":", disp mod_name]+    disp (OpenModuleVar mod_name) =+        hcat [Disp.char '<', disp mod_name, Disp.char '>']+    parse = parseModuleVar <++ parseOpenModule+      where+        parseOpenModule = do+            uid <- parse+            _ <- Parse.char ':'+            mod_name <- parse+            return (OpenModule uid mod_name)+        parseModuleVar = do+            _ <- Parse.char '<'+            mod_name <- parse+            _ <- Parse.char '>'+            return (OpenModuleVar mod_name)++-- | Get the set of holes ('ModuleVar') embedded in a 'Module'.+openModuleFreeHoles :: OpenModule -> Set ModuleName+openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name+openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid++-----------------------------------------------------------------------+-- OpenModuleSubst++-- | An explicit substitution on modules.+--+-- NB: These substitutions are NOT idempotent, for example, a+-- valid substitution is (A -> B, B -> A).+type OpenModuleSubst = Map ModuleName OpenModule++-- | Pretty-print the entries of a module substitution, suitable+-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@.+dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc+dispOpenModuleSubst subst+    = Disp.hcat+    . Disp.punctuate Disp.comma+    $ map dispOpenModuleSubstEntry (Map.toAscList subst)++-- | Pretty-print a single entry of a module substitution.+dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc+dispOpenModuleSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v++-- | Inverse to 'dispModSubst'.+parseOpenModuleSubst :: ReadP r OpenModuleSubst+parseOpenModuleSubst = fmap Map.fromList+      . flip Parse.sepBy (Parse.char ',')+      $ parseOpenModuleSubstEntry++-- | Inverse to 'dispModSubstEntry'.+parseOpenModuleSubstEntry :: ReadP r (ModuleName, OpenModule)+parseOpenModuleSubstEntry =+    do k <- parse+       _ <- Parse.char '='+       v <- parse+       return (k, v)++-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.+-- This is NOT the domain of the substitution.+openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName+openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts))++-----------------------------------------------------------------------+-- Conversions to UnitId++-- | When typechecking, we don't demand that a freshly instantiated+-- 'IndefFullUnitId' be compiled; instead, we just depend on the+-- installed indefinite unit installed at the 'ComponentId'.+abstractUnitId :: OpenUnitId -> UnitId+abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid+abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid++-- | Take a module substitution and hash it into a string suitable for+-- 'UnitId'.  Note that since this takes 'Module', not 'OpenModule',+-- you are responsible for recursively converting 'OpenModule'+-- into 'Module'.  See also "Distribution.Backpack.ReadyComponent".+hashModuleSubst :: Map ModuleName Module -> Maybe String+hashModuleSubst subst+  | Map.null subst = Nothing+  | otherwise =+      Just . hashToBase62 $+        concat [ display mod_name ++ "=" ++ display m ++ "\n"+               | (mod_name, m) <- Map.toList subst]
+ cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs view
@@ -0,0 +1,77 @@+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>++module Distribution.Backpack.ComponentsGraph (+    ComponentsGraph,+    dispComponentsGraph,+    toComponentsGraph,+    componentCycleMsg+) where++import Distribution.Package+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.Simple.LocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Simple.Utils+import Distribution.Compat.Graph (Node(..))+import qualified Distribution.Compat.Graph as Graph++import Distribution.Text+    ( Text(disp) )+import Text.PrettyPrint++------------------------------------------------------------------------------+-- Components graph+------------------------------------------------------------------------------++-- | A components graph is a source level graph tracking the+-- dependencies between components in a package.+type ComponentsGraph = [(Component, [ComponentName])]++-- | Pretty-print a 'ComponentsGraph'.+dispComponentsGraph :: ComponentsGraph -> Doc+dispComponentsGraph graph =+    vcat [ hang (text "component" <+> disp (componentName c)) 4+                (vcat [ text "dependency" <+> disp cdep | cdep <- cdeps ])+         | (c, cdeps) <- graph ]++-- | Given the package description and a 'PackageDescription' (used+-- to determine if a package name is internal or not), create a graph of+-- dependencies between the components.  This is NOT necessarily the+-- build order (although it is in the absence of Backpack.)+toComponentsGraph :: ComponentRequestedSpec+                  -> PackageDescription+                  -> Either [ComponentName] ComponentsGraph+toComponentsGraph enabled pkg_descr =+    let g = Graph.fromList [ N c (componentName c) (componentDeps c)+                           | c <- pkgBuildableComponents pkg_descr+                           , componentEnabled enabled c ]+    in case Graph.cycles g of+          []     -> Right (map (\(N c _ cs) -> (c, cs)) (Graph.revTopSort g))+          ccycles -> Left  [ componentName c | N c _ _ <- concat ccycles ]+  where+    -- The dependencies for the given component+    componentDeps component =+         [ CExeName toolname+         | LegacyExeDependency name _ <- buildTools bi+         , let toolname = mkUnqualComponentName name+         , toolname `elem` map exeName (executables pkg_descr) ]++      ++ [ if pkgname == packageName pkg_descr+           then CLibName+           else CSubLibName toolname+         | Dependency pkgname _ <- targetBuildDepends bi+         , let toolname = packageNameToUnqualComponentName pkgname+         , toolname `elem` internalPkgDeps ]+      where+        bi = componentBuildInfo component+        internalPkgDeps = map (conv . libName) (allLibraries pkg_descr)+        conv Nothing = packageNameToUnqualComponentName $ packageName pkg_descr+        conv (Just s) = s++-- | Error message when there is a cycle; takes the SCC of components.+componentCycleMsg :: [ComponentName] -> Doc+componentCycleMsg cnames =+    text $ "Components in the package depend on each other in a cyclic way:\n  "+       ++ intercalate " depends on "+            [ "'" ++ showComponentName cname ++ "'"+            | cname <- cnames ++ [head cnames] ]
+ cabal/Cabal/Distribution/Backpack/Configure.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE NondecreasingIndentation #-}++-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+--+-- WARNING: The contents of this module are HIGHLY experimental.+-- We may refactor it under you.+module Distribution.Backpack.Configure (+    configureComponentLocalBuildInfos,+) where++import Prelude ()+import Distribution.Compat.Prelude hiding ((<>))++import Distribution.Backpack+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.PreExistingComponent+import Distribution.Backpack.ConfiguredComponent+import Distribution.Backpack.LinkedComponent+import Distribution.Backpack.ReadyComponent+import Distribution.Backpack.ComponentsGraph++import Distribution.Simple.Compiler hiding (Flag)+import Distribution.Package+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.InstalledPackageInfo (InstalledPackageInfo+                                         ,emptyInstalledPackageInfo)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.ModuleName+import Distribution.Simple.Setup as Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Verbosity+import qualified Distribution.Compat.Graph as Graph+import Distribution.Compat.Graph (Graph, IsNode(..))+import Distribution.Utils.Progress+import Distribution.Utils.LogProgress++import Data.Either+    ( lefts )+import qualified Data.Set as Set+import qualified Data.Map as Map+import Distribution.Text+    ( display )+import Text.PrettyPrint++------------------------------------------------------------------------------+-- Pipeline+------------------------------------------------------------------------------++configureComponentLocalBuildInfos+    :: Verbosity+    -> Bool                   -- use_external_internal_deps+    -> ComponentRequestedSpec+    -> Flag String            -- configIPID+    -> Flag ComponentId       -- configCID+    -> PackageDescription+    -> [PreExistingComponent]+    -> FlagAssignment         -- configConfigurationsFlags+    -> [(ModuleName, Module)] -- configInstantiateWith+    -> InstalledPackageIndex+    -> Compiler+    -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)+configureComponentLocalBuildInfos+    verbosity use_external_internal_deps enabled ipid_flag cid_flag pkg_descr+    prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do+    -- NB: In single component mode, this returns a *single* component.+    -- In this graph, the graph is NOT closed.+    graph0 <- case toComponentsGraph enabled pkg_descr of+                Left ccycle -> failProgress (componentCycleMsg ccycle)+                Right comps -> return comps+    infoProgress $ hang (text "Source component graph:") 4+                        (dispComponentsGraph graph0)++    let conf_pkg_map = Map.fromList+            [(pc_pkgname pkg, (pc_cid pkg, pc_pkgid pkg))+            | pkg <- prePkgDeps]+        graph1 = toConfiguredComponents use_external_internal_deps+                    flagAssignment+                    ipid_flag cid_flag pkg_descr+                    conf_pkg_map (map fst graph0)+    infoProgress $ hang (text "Configured component graph:") 4+                        (vcat (map dispConfiguredComponent graph1))++    let shape_pkg_map = Map.fromList+            [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))+            | pkg <- prePkgDeps]+        uid_lookup def_uid+            | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid+            = FullUnitId (Installed.installedComponentId pkg)+                 (Map.fromList (Installed.instantiatedWith pkg))+            | otherwise = error ("uid_lookup: " ++ display uid)+          where uid = unDefUnitId def_uid+    graph2 <- toLinkedComponents verbosity uid_lookup+                    (package pkg_descr) shape_pkg_map graph1++    infoProgress $+        hang (text "Linked component graph:") 4+             (vcat (map dispLinkedComponent graph2))++    let pid_map = Map.fromList $+            [ (pc_uid pkg, pc_pkgid pkg)+            | pkg <- prePkgDeps] +++            [ (Installed.installedUnitId pkg, Installed.sourcePackageId pkg)+            | (_, Module uid _) <- instantiate_with+            , Just pkg <- [PackageIndex.lookupUnitId+                                installedPackageSet (unDefUnitId uid)] ]+        subst = Map.fromList instantiate_with+        graph3 = toReadyComponents pid_map subst graph2+        graph4 = Graph.revTopSort (Graph.fromList graph3)++    infoProgress $ hang (text "Ready component graph:") 4+                        (vcat (map dispReadyComponent graph4))++    toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4++------------------------------------------------------------------------------+-- ComponentLocalBuildInfo+------------------------------------------------------------------------------++toComponentLocalBuildInfos+    :: Compiler+    -> InstalledPackageIndex -- FULL set+    -> PackageDescription+    -> [PreExistingComponent] -- external package deps+    -> [ReadyComponent]+    -> LogProgress ([ComponentLocalBuildInfo],+                    InstalledPackageIndex) -- only relevant packages+toComponentLocalBuildInfos+    comp installedPackageSet pkg_descr externalPkgDeps graph = do+    -- Check and make sure that every instantiated component exists.+    -- We have to do this now, because prior to linking/instantiating+    -- we don't actually know what the full set of 'UnitId's we need+    -- are.+    let -- TODO: This is actually a bit questionable performance-wise,+        -- since we will pay for the ALL installed packages even if+        -- they are not related to what we are building.  This was true+        -- in the old configure code.+        external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)+        external_graph = Graph.fromList+                       . map Left+                       $ PackageIndex.allPackages installedPackageSet+        internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)+        internal_graph = Graph.fromList+                       . map Right+                       $ graph+        combined_graph = Graph.unionRight external_graph internal_graph+        Just local_graph = Graph.closure combined_graph (map nodeKey graph)+        -- The database of transitively reachable installed packages that the+        -- external components the package (as a whole) depends on.  This will be+        -- used in several ways:+        --+        --      * We'll use it to do a consistency check so we're not depending+        --        on multiple versions of the same package (TODO: someday relax+        --        this for private dependencies.)  See right below.+        --+        --      * We'll pass it on in the LocalBuildInfo, where preprocessors+        --        and other things will incorrectly use it to determine what+        --        the include paths and everything should be.+        --+        packageDependsIndex = PackageIndex.fromList (lefts local_graph)+        fullIndex = Graph.fromList local_graph+    case Graph.broken fullIndex of+        [] -> return ()+        broken ->+          -- TODO: ppr this+          failProgress . text $+                "The following packages are broken because other"+             ++ " packages they depend on are missing. These broken "+             ++ "packages must be rebuilt before they can be used.\n"+             -- TODO: Undupe.+             ++ unlines [ "installed package "+                       ++ display (packageId pkg)+                       ++ " is broken due to missing package "+                       ++ intercalate ", " (map display deps)+                        | (Left pkg, deps) <- broken ]+             ++ unlines [ "planned package "+                       ++ display (packageId pkg)+                       ++ " is broken due to missing package "+                       ++ intercalate ", " (map display deps)+                        | (Right pkg, deps) <- broken ]++    -- In this section, we'd like to look at the 'packageDependsIndex'+    -- and see if we've picked multiple versions of the same+    -- installed package (this is bad, because it means you might+    -- get an error could not match foo-0.1:Type with foo-0.2:Type).+    --+    -- What is pseudoTopPkg for? I have no idea.  It was used+    -- in the very original commit which introduced checking for+    -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012,+    -- and then moved out of PackageIndex and put here later.+    -- TODO: Try this code without it...+    --+    -- TODO: Move this into a helper function+    --+    -- TODO: This is probably wrong for Backpack+    let pseudoTopPkg :: InstalledPackageInfo+        pseudoTopPkg = emptyInstalledPackageInfo {+            Installed.installedUnitId =+               mkLegacyUnitId (packageId pkg_descr),+            Installed.sourcePackageId = packageId pkg_descr,+            Installed.depends =+              map pc_uid externalPkgDeps+          }+    case PackageIndex.dependencyInconsistencies+       . PackageIndex.insert pseudoTopPkg+       $ packageDependsIndex of+      [] -> return ()+      inconsistencies ->+        warnProgress . text $+             "This package indirectly depends on multiple versions of the same "+          ++ "package. This is highly likely to cause a compile failure.\n"+          ++ unlines [ "package " ++ display pkg ++ " requires "+                    ++ display (PackageIdentifier name ver)+                     | (name, uses) <- inconsistencies+                     , (pkg, ver) <- uses ]+    let clbis = mkLinkedComponentsLocalBuildInfo comp graph+    -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)+    return (clbis, packageDependsIndex)++-- Build ComponentLocalBuildInfo for each component we are going+-- to build.+--+-- This conversion is lossy; we lose some invariants from ReadyComponent+mkLinkedComponentsLocalBuildInfo+    :: Compiler+    -> [ReadyComponent]+    -> [ComponentLocalBuildInfo]+mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs+  where+    internalUnits = Set.fromList (map rc_uid rcs)+    isInternal x = Set.member x internalUnits+    go rc =+      case rc_component rc of+      CLib _ ->+        let convModuleExport (modname', (Module uid modname))+              | this_uid == unDefUnitId uid+              , modname' == modname+              = Installed.ExposedModule modname' Nothing+              | otherwise+              = Installed.ExposedModule modname'+                  (Just (OpenModule (DefiniteUnitId uid) modname))+            convOpenModuleExport (modname', modu@(OpenModule uid modname))+              | uid == this_open_uid+              , modname' == modname+              = Installed.ExposedModule modname' Nothing+              | otherwise+              = Installed.ExposedModule modname' (Just modu)+            convOpenModuleExport (_, OpenModuleVar _)+                = error "convOpenModuleExport: top-level modvar"+            exports =+                -- Loses invariants+                case rc_i rc of+                    Left indefc -> map convOpenModuleExport+                                 $ Map.toList (indefc_provides indefc)+                    Right instc -> map convModuleExport+                                 $ Map.toList (instc_provides instc)+            insts =+                case rc_i rc of+                    Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ]+                    Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m')+                                   | (m, Module uid' m') <- instc_insts instc ]+        in LibComponentLocalBuildInfo {+          componentPackageDeps = cpds,+          componentUnitId = this_uid,+          componentComponentId = this_cid,+          componentInstantiatedWith = insts,+          componentIsIndefinite_ = is_indefinite,+          componentLocalName = cname,+          componentInternalDeps = internal_deps,+          componentExeDeps = map unDefUnitId (rc_internal_build_tools rc),+          componentIncludes = includes,+          componentExposedModules = exports,+          componentIsPublic = rc_public rc,+          componentCompatPackageKey = rc_compat_key rc comp,+          componentCompatPackageName = rc_compat_name rc+        }+      CFLib _ ->+        FLibComponentLocalBuildInfo {+          componentUnitId = this_uid,+          componentComponentId = this_cid,+          componentLocalName = cname,+          componentPackageDeps = cpds,+          componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,+          componentInternalDeps = internal_deps,+          componentIncludes = includes+        }+      CExe _ ->+        ExeComponentLocalBuildInfo {+          componentUnitId = this_uid,+          componentComponentId = this_cid,+          componentLocalName = cname,+          componentPackageDeps = cpds,+          componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,+          componentInternalDeps = internal_deps,+          componentIncludes = includes+        }+      CTest _ ->+        TestComponentLocalBuildInfo {+          componentUnitId = this_uid,+          componentComponentId = this_cid,+          componentLocalName = cname,+          componentPackageDeps = cpds,+          componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,+          componentInternalDeps = internal_deps,+          componentIncludes = includes+        }+      CBench _ ->+        BenchComponentLocalBuildInfo {+          componentUnitId = this_uid,+          componentComponentId = this_cid,+          componentLocalName = cname,+          componentPackageDeps = cpds,+          componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,+          componentInternalDeps = internal_deps,+          componentIncludes = includes+        }+     where+      this_uid      = rc_uid rc+      this_open_uid = rc_open_uid rc+      this_cid      = rc_cid rc+      cname = componentName (rc_component rc)+      cpds = rc_depends rc+      is_indefinite =+        case rc_i rc of+            Left _ -> True+            Right _ -> False+      includes =+        case rc_i rc of+            Left indefc ->+                indefc_includes indefc+            Right instc ->+                map (\(x,y) -> (DefiniteUnitId x,y)) (instc_includes instc)+      internal_deps =+              filter isInternal (nodeNeighbors rc)+           ++ map unDefUnitId (rc_internal_build_tools rc)++
+ cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE PatternGuards #-}+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.ConfiguredComponent (+    ConfiguredComponent(..),+    toConfiguredComponent,+    toConfiguredComponents,+    dispConfiguredComponent,++    ConfiguredComponentMap,+    extendConfiguredComponentMap,++    -- TODO: Should go somewhere else+    newPackageDepsBehaviour+) where++import Prelude ()+import Distribution.Compat.Prelude hiding ((<>))++import Distribution.Backpack.Id++import Distribution.Types.IncludeRenaming+import Distribution.Types.Mixin+import Distribution.Package+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.Simple.Setup as Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.Version++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Traversable+    ( mapAccumL )+import Distribution.Text+import Text.PrettyPrint++-- | A configured component, we know exactly what its 'ComponentId' is,+-- and the 'ComponentId's of the things it depends on.+data ConfiguredComponent+    = ConfiguredComponent {+        cc_cid :: ComponentId,+        -- The package this component came from.+        cc_pkgid :: PackageId,+        cc_component :: Component,+        cc_public :: Bool,+        -- ^ Is this the public library component of the package?+        -- (THIS is what the hole instantiation applies to.)+        -- Note that in one-component configure mode, this is+        -- always True, because any component is the "public" one.)+        cc_internal_build_tools :: [ComponentId],+        -- Not resolved yet; component configuration only looks at ComponentIds.+        cc_includes :: [(ComponentId, PackageId, IncludeRenaming)]+      }++cc_name :: ConfiguredComponent -> ComponentName+cc_name = componentName . cc_component++dispConfiguredComponent :: ConfiguredComponent -> Doc+dispConfiguredComponent cc =+    hang (text "component" <+> disp (cc_cid cc)) 4+         (vcat [ hsep $ [ text "include", disp cid, disp incl_rn ]+               | (cid, _, incl_rn) <- cc_includes cc+               ])+++-- | Construct a 'ConfiguredComponent', given that the 'ComponentId'+-- and library/executable dependencies are known.  The primary+-- work this does is handling implicit @backpack-include@ fields.+mkConfiguredComponent+    :: PackageId+    -> ComponentId+    -> [(PackageName, (ComponentId, PackageId))]+    -> [ComponentId]+    -> Component+    -> ConfiguredComponent+mkConfiguredComponent this_pid this_cid lib_deps exe_deps component =+    ConfiguredComponent {+        cc_cid = this_cid,+        cc_pkgid = this_pid,+        cc_component = component,+        cc_public = is_public,+        cc_internal_build_tools = exe_deps,+        cc_includes = explicit_includes ++ implicit_includes+    }+  where+    bi = componentBuildInfo component+    deps = map snd lib_deps+    deps_map = Map.fromList lib_deps++    -- Resolve each @backpack-include@ into the actual dependency+    -- from @lib_deps@.+    explicit_includes+        = [ (cid, pid { pkgName = name }, rns)+        | Mixin name rns <- mixins bi+        , Just (cid, pid) <- [Map.lookup name deps_map] ]++    -- Any @build-depends@ which is not explicitly mentioned in+    -- @backpack-include@ is converted into an "implicit" include.+    used_explicitly = Set.fromList (map (\(cid,_,_) -> cid) explicit_includes)+    implicit_includes+        = map (\(cid, pid) -> (cid, pid, defaultIncludeRenaming))+        $ filter (flip Set.notMember used_explicitly . fst) deps++    is_public = componentName component == CLibName++type ConfiguredComponentMap =+        (Map PackageName (ComponentId, PackageId), -- libraries+         Map UnqualComponentName ComponentId)      -- executables++-- Executable map must be different because an executable can+-- have the same name as a library. Ew.++-- | Given some ambient environment of package names that+-- are "in scope", looks at the 'BuildInfo' to decide+-- what the packages actually resolve to, and then builds+-- a 'ConfiguredComponent'.+toConfiguredComponent+    :: PackageDescription+    -> ComponentId+    -> Map PackageName (ComponentId, PackageId) -- external+    -> ConfiguredComponentMap+    -> Component+    -> ConfiguredComponent+toConfiguredComponent pkg_descr this_cid+       external_lib_map (lib_map, exe_map) component =+    mkConfiguredComponent+       (package pkg_descr) this_cid+       lib_deps exe_deps component+  where+    bi = componentBuildInfo component+    find_it :: PackageName -> (ComponentId, PackageId)+    find_it name =+        fromMaybe (error ("toConfiguredComponent: " ++ display (packageName pkg_descr) +++                            " " ++ display name)) $+            Map.lookup name lib_map <|>+            Map.lookup name external_lib_map+    lib_deps+        | newPackageDepsBehaviour pkg_descr+        = [ (name, find_it name)+          | Dependency name _ <- targetBuildDepends bi ]+        | otherwise+        = Map.toList external_lib_map+    exe_deps = [ cid+               | LegacyExeDependency name _ <- buildTools bi+               , Just cid <- [ Map.lookup (mkUnqualComponentName name) exe_map ] ]++-- | Also computes the 'ComponentId', and sets cc_public if necessary.+-- This is Cabal-only; cabal-install won't use this.+toConfiguredComponent'+    :: Bool -- use_external_internal_deps+    -> FlagAssignment+    -> PackageDescription+    -> Flag String      -- configIPID (todo: remove me)+    -> Flag ComponentId -- configCID+    -> Map PackageName (ComponentId, PackageId) -- external+    -> ConfiguredComponentMap+    -> Component+    -> ConfiguredComponent+toConfiguredComponent' use_external_internal_deps flags+                pkg_descr ipid_flag cid_flag+                external_lib_map (lib_map, exe_map) component =+    let cc = toConfiguredComponent+                pkg_descr this_cid+                external_lib_map (lib_map, exe_map) component+    in if use_external_internal_deps+        then cc { cc_public = True }+        else cc+  where+    this_cid = computeComponentId ipid_flag cid_flag (package pkg_descr)+                (componentName component) (Just (deps, flags))+    deps = [ cid | (cid, _) <- Map.elems external_lib_map ]++extendConfiguredComponentMap+    :: ConfiguredComponent+    -> ConfiguredComponentMap+    -> ConfiguredComponentMap+extendConfiguredComponentMap cc (lib_map, exe_map) =+    (lib_map', exe_map')+  where+    lib_map'+      = case cc_name cc of+          CLibName ->+            Map.insert (pkgName (cc_pkgid cc))+                       (cc_cid cc, cc_pkgid cc) lib_map+          CSubLibName str ->+            Map.insert (unqualComponentNameToPackageName str)+                       (cc_cid cc, cc_pkgid cc) lib_map+          _ -> lib_map+    exe_map'+      = case cc_name cc of+          CExeName str ->+            Map.insert str (cc_cid cc) exe_map+          _ -> exe_map++-- Compute the 'ComponentId's for a graph of 'Component's.  The+-- list of internal components must be topologically sorted+-- based on internal package dependencies, so that any internal+-- dependency points to an entry earlier in the list.+toConfiguredComponents+    :: Bool -- use_external_internal_deps+    -> FlagAssignment+    -> Flag String -- configIPID+    -> Flag ComponentId -- configCID+    -> PackageDescription+    -> Map PackageName (ComponentId, PackageId)+    -> [Component]+    -> [ConfiguredComponent]+toConfiguredComponents+    use_external_internal_deps flags ipid_flag cid_flag pkg_descr+    external_lib_map comps+    = snd (mapAccumL go (Map.empty, Map.empty) comps)+  where+    go m component = (extendConfiguredComponentMap cc m, cc)+      where cc = toConfiguredComponent'+                        use_external_internal_deps flags pkg_descr ipid_flag cid_flag+                        external_lib_map m component+++newPackageDepsBehaviourMinVersion :: Version+newPackageDepsBehaviourMinVersion = mkVersion [1,7,1]+++-- In older cabal versions, there was only one set of package dependencies for+-- the whole package. In this version, we can have separate dependencies per+-- target, but we only enable this behaviour if the minimum cabal version+-- specified is >= a certain minimum. Otherwise, for compatibility we use the+-- old behaviour.+newPackageDepsBehaviour :: PackageDescription -> Bool+newPackageDepsBehaviour pkg =+   specVersion pkg >= newPackageDepsBehaviourMinVersion
+ cabal/Cabal/Distribution/Backpack/FullUnitId.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Backpack.FullUnitId (+    FullUnitId(..),+    FullDb,+    expandOpenUnitId,+    expandUnitId+) where++import Distribution.Backpack+import Distribution.Package+import Distribution.Compat.Prelude++-- Unlike OpenUnitId, which could direct to a UnitId.+data FullUnitId = FullUnitId ComponentId OpenModuleSubst+    deriving (Show, Generic)++type FullDb = DefUnitId -> FullUnitId++expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId+expandOpenUnitId _db (IndefFullUnitId cid subst)+    = FullUnitId cid subst+expandOpenUnitId db (DefiniteUnitId uid)+    = expandUnitId db uid++expandUnitId :: FullDb -> DefUnitId -> FullUnitId+expandUnitId db uid = db uid
+ cabal/Cabal/Distribution/Backpack/Id.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternGuards #-}+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.Id(+    computeComponentId,+    computeCompatPackageKey,+    computeCompatPackageName,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Simple.Compiler hiding (Flag)+import Distribution.Package+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.Simple.Setup as Setup+import qualified Distribution.Simple.InstallDirs as InstallDirs+import Distribution.Simple.LocalBuildInfo+import Distribution.Utils.Base62+import Distribution.Version++import Distribution.Text+    ( display, simpleParse )++-- | This method computes a default, "good enough" 'ComponentId'+-- for a package.  The intent is that cabal-install (or the user) will+-- specify a more detailed IPID via the @--ipid@ flag if necessary.+computeComponentId+    :: Flag String+    -> Flag ComponentId+    -> PackageIdentifier+    -> ComponentName+    -- This is used by cabal-install's legacy codepath+    -> Maybe ([ComponentId], FlagAssignment)+    -> ComponentId+computeComponentId mb_ipid mb_cid pid cname mb_details =+    -- show is found to be faster than intercalate and then replacement of+    -- special character used in intercalating. We cannot simply hash by+    -- doubly concating list, as it just flatten out the nested list, so+    -- different sources can produce same hash+    let hash_suffix+            | Just (dep_ipids, flags) <- mb_details+            = "-" ++ hashToBase62+                -- For safety, include the package + version here+                -- for GHC 7.10, where just the hash is used as+                -- the package key+                    (    display pid+                      ++ show dep_ipids+                      ++ show flags     )+            | otherwise = ""+        generated_base = display pid ++ hash_suffix+        explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env+                                                    (toPathTemplate cid0))+            -- Hack to reuse install dirs machinery+            -- NB: no real IPID available at this point+          where env = packageTemplateEnv pid (mkUnitId "")+        actual_base = case mb_ipid of+                        Flag ipid0 -> explicit_base ipid0+                        NoFlag -> generated_base+    in case mb_cid of+          Flag cid -> cid+          NoFlag -> mkComponentId $ actual_base+                        ++ (case componentNameString cname of+                                Nothing -> ""+                                Just s -> "-" ++ unUnqualComponentName s)++-- | Computes the package name for a library.  If this is the public+-- library, it will just be the original package name; otherwise,+-- it will be a munged package name recording the original package+-- name as well as the name of the internal library.+--+-- A lot of tooling in the Haskell ecosystem assumes that if something+-- is installed to the package database with the package name 'foo',+-- then it actually is an entry for the (only public) library in package+-- 'foo'.  With internal packages, this is not necessarily true:+-- a public library as well as arbitrarily many internal libraries may+-- come from the same package.  To prevent tools from getting confused+-- in this case, the package name of these internal libraries is munged+-- so that they do not conflict the public library proper.  A particular+-- case where this matters is ghc-pkg: if we don't munge the package+-- name, the inplace registration will OVERRIDE a different internal+-- library.+--+-- We munge into a reserved namespace, "z-", and encode both the+-- component name and the package name of an internal library using the+-- following format:+--+--      compat-pkg-name ::= "z-" package-name "-z-" library-name+--+-- where package-name and library-name have "-" ( "z" + ) "-"+-- segments encoded by adding an extra "z".+--+-- When we have the public library, the compat-pkg-name is just the+-- package-name, no surprises there!+--+computeCompatPackageName :: PackageName -> ComponentName -> PackageName+-- First handle the cases where we can just use the original 'PackageName'.+-- This is for the PRIMARY library, and it is non-Backpack, or the+-- indefinite package for us.+computeCompatPackageName pkg_name CLibName = pkg_name+computeCompatPackageName pkg_name cname+    = mkPackageName $ "z-" ++ zdashcode (display pkg_name)+                 ++ (case componentNameString cname of+                        Just cname_u -> "-z-" ++ zdashcode cname_str+                          where cname_str = unUnqualComponentName cname_u+                        Nothing -> "")++zdashcode :: String -> String+zdashcode s = go s (Nothing :: Maybe Int) []+    where go [] _ r = reverse r+          go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)+          go ('-':z) _        r = go z (Just 0) ('-':r)+          go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)+          go (c:z)   _        r = go z Nothing (c:r)++-- | In GHC 8.0, the string we pass to GHC to use for symbol+-- names for a package can be an arbitrary, IPID-compatible string.+-- However, prior to GHC 8.0 there are some restrictions on what+-- format this string can be (due to how ghc-pkg parsed the key):+--+--      1. In GHC 7.10, the string had either be of the form+--      foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated+--      prefix and ABCD is two base-64 encoded 64-bit integers,+--      or a GHC 7.8 style identifier.+--+--      2. In GHC 7.8, the string had to be a valid package identifier+--      like foo-0.1.+--+-- So, the problem is that Cabal, in general, has a general IPID,+-- but needs to figure out a package key / package ID that the+-- old ghc-pkg will actually accept.  But there's an EVERY WORSE+-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx+-- as if it were a package identifier, which means it will SILENTLY+-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)+-- So we must CONNIVE to ensure that we don't pick something that+-- looks like this.+--+-- So this function attempts to define a mapping into the old formats.+--+-- The mapping for GHC 7.8 and before:+--+--      * We use the *compatibility* package name and version.  For+--        public libraries this is just the package identifier; for+--        internal libraries, it's something like "z-pkgname-z-libname-0.1".+--        See 'computeCompatPackageName' for more details.+--+-- The mapping for GHC 7.10:+--+--      * For CLibName:+--          If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would+--          validly parse as a package key, we pass "ABCDEF".  (NB: not+--          all hashes parse this way, because GHC 7.10 mandated that+--          these hashes be two base-62 encoded 64 bit integers),+--          but hashes that Cabal generated using 'computeComponentId'+--          are guaranteed to have this form.+--+--          If it is not of this form, we rehash the IPID into the+--          correct form and pass that.+--+--      * For sub-components, we rehash the IPID into the correct format+--        and pass that.+--+computeCompatPackageKey+    :: Compiler+    -> PackageName+    -> Version+    -> UnitId+    -> String+computeCompatPackageKey comp pkg_name pkg_version uid+    | not (packageKeySupported comp) =+        display pkg_name ++ "-" ++ display pkg_version+    | not (unifiedIPIDRequired comp) =+        let str = unUnitId uid -- assume no Backpack support+            mb_verbatim_key+                = case simpleParse str :: Maybe PackageId of+                    -- Something like 'foo-0.1', use it verbatim.+                    -- (NB: hash tags look like tags, so they are parsed,+                    -- so the extra equality check tests if a tag was dropped.)+                    Just pid0 | display pid0 == str -> Just str+                    _ -> Nothing+            mb_truncated_key+                = let cand = reverse (takeWhile isAlphaNum (reverse str))+                  in if length cand == 22 && all isAlphaNum cand+                        then Just cand+                        else Nothing+            rehashed_key = hashToBase62 str+        in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)+    | otherwise = display uid
+ cabal/Cabal/Distribution/Backpack/LinkedComponent.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.LinkedComponent (+    LinkedComponent(..),+    toLinkedComponent,+    toLinkedComponents,+    dispLinkedComponent,+    LinkedComponentMap,+    extendLinkedComponentMap,+) where++import Prelude ()+import Distribution.Compat.Prelude hiding ((<>))++import Distribution.Backpack+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.ConfiguredComponent+import Distribution.Backpack.ModSubst+import Distribution.Backpack.ModuleShape+import Distribution.Backpack.ModuleScope+import Distribution.Backpack.UnifyM+import Distribution.Backpack.MixLink+import Distribution.Utils.MapAccum++import Distribution.Types.ModuleRenaming+import Distribution.Types.IncludeRenaming+import Distribution.Package+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.ModuleName+import Distribution.Simple.LocalBuildInfo+import Distribution.Verbosity+import Distribution.Utils.Progress+import Distribution.Utils.LogProgress++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Traversable+    ( mapM )+import Distribution.Text+    ( Text(disp) )+import Text.PrettyPrint++-- | A linked component, we know how it is instantiated and thus how we are+-- going to build it.+data LinkedComponent+    = LinkedComponent {+        lc_uid :: OpenUnitId,+        lc_cid :: ComponentId,+        lc_pkgid :: PackageId,+        lc_insts :: [(ModuleName, OpenModule)],+        lc_component :: Component,+        lc_shape :: ModuleShape,+        -- | Local buildTools dependencies+        lc_internal_build_tools :: [OpenUnitId],+        lc_public :: Bool,+        lc_includes :: [(OpenUnitId, ModuleRenaming)],+        -- PackageId here is a bit dodgy, but its just for+        -- BC so it shouldn't matter.+        lc_depends :: [(OpenUnitId, PackageId)]+      }++dispLinkedComponent :: LinkedComponent -> Doc+dispLinkedComponent lc =+    hang (text "unit" <+> disp (lc_uid lc)) 4 $+         vcat [ text "include" <+> disp uid <+> disp prov_rn+              | (uid, prov_rn) <- lc_includes lc ]+            -- YARRR $+$ dispModSubst (modShapeProvides (lc_shape lc))++instance Package LinkedComponent where+    packageId = lc_pkgid++instance ModSubst LinkedComponent where+    modSubst subst lc+        = lc {+            lc_uid = modSubst subst (lc_uid lc),+            lc_insts = modSubst subst (lc_insts lc),+            lc_shape = modSubst subst (lc_shape lc),+            lc_includes = map (\(uid, rns) -> (modSubst subst uid, rns)) (lc_includes lc),+            lc_depends = map (\(uid, pkgid) -> (modSubst subst uid, pkgid)) (lc_depends lc)+          }++{-+instance IsNode LinkedComponent where+    type Key LinkedComponent = UnitId+    nodeKey = lc_uid+    nodeNeighbors n =+        if Set.null (openUnitIdFreeHoles (lc_uid n))+            then map fst (lc_depends n)+            else ordNub (map (generalizeUnitId . fst) (lc_depends n))+-}++-- We can't cache these values because they need to be changed+-- when we substitute over a 'LinkedComponent'.  By varying+-- these over 'UnitId', we can support old GHCs. Nice!++toLinkedComponent+    :: Verbosity+    -> FullDb+    -> PackageId+    -> LinkedComponentMap+    -> ConfiguredComponent+    -> LogProgress LinkedComponent+toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {+    cc_cid = this_cid,+    cc_pkgid = pkgid,+    cc_component = component,+    cc_internal_build_tools = btools,+    cc_public = is_public,+    cc_includes = cid_includes+   } = do+    let+        -- The explicitly specified requirements, provisions and+        -- reexports from the Cabal file.  These are only non-empty for+        -- libraries; everything else is trivial.+        (src_reqs      :: [ModuleName],+         src_provs     :: [ModuleName],+         src_reexports :: [ModuleReexport]) =+            case component of+                CLib lib -> (signatures lib,+                             exposedModules lib,+                             reexportedModules lib)+                _ -> ([], [], [])++        -- Take each included ComponentId and resolve it into an+        -- *unlinked* unit identity.  We will use unification (relying+        -- on the ModuleShape) to resolve these into linked identities.+        unlinked_includes :: [((OpenUnitId, ModuleShape), PackageId, IncludeRenaming)]+        unlinked_includes = [ (lookupUid cid, pid, rns)+                            | (cid, pid, rns) <- cid_includes ]++        lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)+        lookupUid cid = fromMaybe (error "linkComponent: lookupUid")+                                    (Map.lookup cid pkg_map)++    let orErr (Right x) = return x+        orErr (Left err) = failProgress (text err)++    -- OK, actually do unification+    -- TODO: the unification monad might return errors, in which+    -- case we have to deal.  Use monadic bind for now.+    (linked_shape0   :: ModuleScope,+     linked_deps     :: [(OpenUnitId, PackageId)],+     linked_includes :: [(OpenUnitId, ModuleRenaming)]) <- orErr $ runUnifyM verbosity db $ do+        -- The unification monad is implemented using mutable+        -- references.  Thus, we must convert our *pure* data+        -- structures into mutable ones to perform unification.+        --+        let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)+            convertReq req = do+                req_u <- convertModule (OpenModuleVar req)+                return (Map.empty, Map.singleton req req_u)+            -- NB: We DON'T convert locally defined modules, as in the+            -- absence of mutual recursion across packages they+            -- cannot participate in mix-in linking.+        (shapes_u, includes_u) <- fmap unzip (mapM convertInclude unlinked_includes)+        src_reqs_u <- mapM convertReq src_reqs+        -- Mix-in link everything!  mixLink is the real workhorse.+        shape_u <- foldM mixLink emptyModuleScopeU (shapes_u ++ src_reqs_u)+        -- Read out all the final results by converting back+        -- into a pure representation.+        let convertIncludeU (uid_u, pid, rns) = do+                uid <- convertUnitIdU uid_u+                return ((uid, rns), (uid, pid))+        shape <- convertModuleScopeU shape_u+        includes_deps <- mapM convertIncludeU includes_u+        let (incls, deps) = unzip includes_deps+        return (shape, deps, incls)++    -- linked_shape0 is almost complete, but it doesn't contain+    -- the actual modules we export ourselves.  Add them!+    let reqs = modScopeRequires linked_shape0+        -- check that there aren't pre-filled requirements...+        insts = [ (req, OpenModuleVar req)+                | req <- Set.toList reqs ]+        this_uid = IndefFullUnitId this_cid . Map.fromList $ insts++        -- add the local exports to the scope+        local_exports = Map.fromListWith (++) $+          [ (mod_name, [ModuleSource (packageName this_pid)+                                     defaultIncludeRenaming+                                     (OpenModule this_uid mod_name)])+          | mod_name <- src_provs ]+          -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg+          -- won't allow it (since someone could directly synthesize+          -- an 'InstalledPackageInfo' that violates abstraction.)+          -- Though, maybe it should be relaxed?+        linked_shape = linked_shape0 {+                          modScopeProvides =+                            Map.unionWith (++)+                              local_exports+                              (modScopeProvides linked_shape0)+                        }++    -- OK, compute the reexports+    -- TODO: This code reports the errors for reexports one reexport at+    -- a time.  Better to collect them all up and report them all at+    -- once.+    reexports_list <- for src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do+      let err :: Doc -> LogProgress a+          err s = failProgress+            $ hang (text "Problem with module re-export" <> quotes (disp reex)+                        <+> colon) 2 s+      case Map.lookup from (modScopeProvides linked_shape) of+        Just cands@(x0:xs0) -> do+          -- Make sure there is at least one candidate+          (x, xs) <-+            case mb_pn of+              Just pn ->+                case filter ((pn==) . msrc_pkgname) cands of+                  (x1:xs1) -> return (x1, xs1)+                  _ -> err (brokenReexportMsg reex)+              Nothing -> return (x0, xs0)+          -- Test that all the candidates are consistent+          case filter (\x' -> msrc_module x /= msrc_module x') xs of+            [] -> return ()+            _ -> err $ ambiguousReexportMsg reex (x:xs)+          return (to, msrc_module x)+        _ ->+          err (brokenReexportMsg reex)++    -- TODO: maybe check this earlier; it's syntactically obvious.+    let build_reexports m (k, v)+            | Map.member k m =+                failProgress $ hsep+                    [ text "Module name ", disp k, text " is exported multiple times." ]+            | otherwise = return (Map.insert k v m)+    provs <- foldM build_reexports Map.empty $+                -- TODO: doublecheck we have checked for+                -- src_provs duplicates already!+                [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] +++                reexports_list++    let final_linked_shape = ModuleShape provs (modScopeRequires linked_shape)++    return $ LinkedComponent {+                lc_uid = this_uid,+                lc_cid = this_cid,+                lc_insts = insts,+                lc_pkgid = pkgid,+                lc_component = component,+                lc_public = is_public,+                -- These must be executables+                lc_internal_build_tools = map (\cid -> IndefFullUnitId cid Map.empty) btools,+                lc_shape = final_linked_shape,+                lc_includes = linked_includes,+                lc_depends = linked_deps+           }++-- Handle mix-in linking for components.  In the absence of Backpack,+-- every ComponentId gets converted into a UnitId by way of SimpleUnitId.+toLinkedComponents+    :: Verbosity+    -> FullDb+    -> PackageId+    -> LinkedComponentMap+    -> [ConfiguredComponent]+    -> LogProgress [LinkedComponent]+toLinkedComponents verbosity db this_pid lc_map0 comps+   = fmap snd (mapAccumM go lc_map0 comps)+ where+  go :: Map ComponentId (OpenUnitId, ModuleShape)+     -> ConfiguredComponent+     -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)+  go lc_map cc = do+    lc <- toLinkedComponent verbosity db this_pid lc_map cc+    return (extendLinkedComponentMap lc lc_map, lc)++type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape)++extendLinkedComponentMap :: LinkedComponent+                         -> LinkedComponentMap+                         -> LinkedComponentMap+extendLinkedComponentMap lc m =+    Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m++brokenReexportMsg :: ModuleReexport -> Doc+brokenReexportMsg (ModuleReexport (Just pn) from _to) =+    text "The package" <+> disp pn <+>+    text "does not export a module" <+> disp from+brokenReexportMsg (ModuleReexport Nothing from _to) =+    text "The module" <+> disp from <+>+    text "is not exported by any suitable package." <+>+    text "It occurs in neither the 'exposed-modules' of this package," <+>+    text "nor any of its 'build-depends' dependencies."++ambiguousReexportMsg :: ModuleReexport -> [ModuleSource] -> Doc+ambiguousReexportMsg (ModuleReexport mb_pn from _to) ys =+    text "The module" <+> disp from <+>+    text "is (differently) exported by more than one package" <+>+    parens (hsep (punctuate comma [displaySource y | y <- ys])) <+>+    text "making the re-export ambiguous." <+> help_msg mb_pn+  where+    help_msg Nothing =+        text "The ambiguity can be resolved by qualifying the" <+>+        text "re-export with a package name." <+>+        text "The syntax is 'packagename:ModuleName [as NewName]'."+    -- Qualifying won't help that much.+    help_msg (Just _) =+        text "The ambiguity can be resolved by introducing a" <+>+        text "backpack-include field to rename one of the module" <+>+        text "names differently."+    displaySource y+      | not (isDefaultIncludeRenaming (msrc_renaming y))+          = disp (msrc_pkgname y) <+> text "with renaming" <+>+            disp (includeProvidesRn (msrc_renaming y))+      | otherwise = disp (msrc_pkgname y)
+ cabal/Cabal/Distribution/Backpack/MixLink.hs view
@@ -0,0 +1,151 @@+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.MixLink (+    mixLink,+) where++import Prelude ()+import Distribution.Compat.Prelude hiding (mod)++import Distribution.Backpack+import Distribution.Backpack.UnifyM+import Distribution.Backpack.FullUnitId++import qualified Distribution.Utils.UnionFind as UnionFind+import Distribution.ModuleName+import Distribution.Text+import Distribution.Types.IncludeRenaming+import Distribution.Package++import Control.Monad+import qualified Data.Map as Map+import qualified Data.Foldable as F++-----------------------------------------------------------------------+-- Linking++-- | Given to scopes of provisions and requirements, link them together.+mixLink :: ModuleScopeU s -> ModuleScopeU s -> UnifyM s (ModuleScopeU s)+mixLink (provs1, reqs1) (provs2, reqs2) = do+    F.sequenceA_ (Map.intersectionWithKey linkProvision provs1 reqs2)+    F.sequenceA_ (Map.intersectionWithKey linkProvision provs2 reqs1)+    -- TODO: would be more efficient to collapse provision lists when we+    -- unify them.+    return (Map.unionWith (++) provs1 provs2,+            -- NB: NOT the difference of the unions.  That implies+            -- self-unification not allowed.  (But maybe requirement prov is disjoint+            -- from reqs makes this a moot point?)+            Map.union (Map.difference reqs1 provs2)+                      (Map.difference reqs2 provs1))++displaySource :: ModuleSourceU s -> String+displaySource src+ | isDefaultIncludeRenaming (usrc_renaming src)+ = display (usrc_pkgname src)+ | otherwise+ = display (usrc_pkgname src) ++ " with renaming " ++ display (usrc_renaming src)++-- | Link a list of possibly provided modules to a single+-- requirement.  This applies a side-condition that all+-- of the provided modules at the same name are *actually*+-- the same module.+linkProvision :: ModuleName -> [ModuleSourceU s] -> ModuleU s+              -> UnifyM s [ModuleSourceU s]+linkProvision _ [] _reqs = error "linkProvision"+linkProvision mod_name ret@(prov:provs) req = do+    forM_ provs $ \prov' -> do+        let msg = "Ambiguous module " ++ display mod_name ++ " " +++                  "when trying to fill requirement. It could refer to " +++                  "a module included from " ++ displaySource prov ++ " " +++                  "or module included from " ++ displaySource prov' ++ ". " +++                  "Ambiguity occurred because "+        withContext msg (usrc_module prov) (usrc_module prov') $+            unifyModule (usrc_module prov) (usrc_module prov')+    let msg = "Could not fill requirement " ++ display mod_name ++ "because "+    withContext msg (usrc_module prov) req $+        unifyModule (usrc_module prov) req+    return ret++++-----------------------------------------------------------------------+-- The unification algorithm++-- This is based off of https://gist.github.com/amnn/559551517d020dbb6588+-- which is a translation from Huet's thesis.++unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s ()+unifyUnitId uid1_u uid2_u+    | uid1_u == uid2_u = return ()+    | otherwise = do+        xuid1 <- liftST $ UnionFind.find uid1_u+        xuid2 <- liftST $ UnionFind.find uid2_u+        case (xuid1, xuid2) of+            (UnitIdThunkU u1, UnitIdThunkU u2)+                | u1 == u2  -> return ()+                | otherwise ->+                    unifyFail $+                        "pre-installed unit IDs " ++ display u1 +++                        " and " ++ display u2 ++ " do not match."+            (UnitIdThunkU uid1, UnitIdU _ cid2 insts2)+                -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u+            (UnitIdU _ cid1 insts1, UnitIdThunkU uid2)+                -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u+            (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2)+                -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u++unifyThunkWith :: ComponentId+               -> Map ModuleName (ModuleU s)+               -> UnitIdU s+               -> DefUnitId+               -> UnitIdU s+               -> UnifyM s ()+unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do+    db <- fmap unify_db getUnifEnv+    let FullUnitId cid2 insts2' = expandUnitId db uid2+    insts2 <- convertModuleSubst insts2'+    unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u++unifyInner :: ComponentId+           -> Map ModuleName (ModuleU s)+           -> UnitIdU s+           -> ComponentId+           -> Map ModuleName (ModuleU s)+           -> UnitIdU s+           -> UnifyM s ()+unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do+    when (cid1 /= cid2) $+        -- TODO: if we had a package identifier, could be an+        -- easier to understand error message.+        unifyFail $+            "component IDs " +++            display cid1 ++ " and " ++ display cid2 ++ " do not match."+    -- The KEY STEP which makes this a Huet-style unification+    -- algorithm.  (Also a payoff of using union-find.)+    -- We can build infinite unit IDs this way, which is necessary+    -- for support mutual recursion. NB: union keeps the SECOND+    -- descriptor, so we always arrange for a UnitIdThunkU to live+    -- there.+    liftST $ UnionFind.union uid1_u uid2_u+    F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2++-- | Imperatively unify two modules.+unifyModule :: ModuleU s -> ModuleU s -> UnifyM s ()+unifyModule mod1_u mod2_u+    | mod1_u == mod2_u = return ()+    | otherwise = do+        mod1 <- liftST $ UnionFind.find mod1_u+        mod2 <- liftST $ UnionFind.find mod2_u+        case (mod1, mod2) of+            (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u+            (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u+            (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do+                when (mod_name1 /= mod_name2) $+                    unifyFail $+                        "module names " +++                        display mod_name1 ++ " and " +++                        display mod_name2 ++ " disagree."+                -- NB: this is not actually necessary (because we'll+                -- detect loops eventually in 'unifyUnitId'), but it+                -- seems harmless enough+                liftST $ UnionFind.union mod1_u mod2_u+                unifyUnitId uid1 uid2
+ cabal/Cabal/Distribution/Backpack/ModSubst.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}++-- | A type class 'ModSubst' for objects which can have 'ModuleSubst'+-- applied to them.+--+-- See also <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>++module Distribution.Backpack.ModSubst (+    ModSubst(..),+) where++import Prelude ()+import Distribution.Compat.Prelude hiding (mod)++import Distribution.ModuleName++import Distribution.Backpack++import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++-- | Applying module substitutions to semantic objects.+class ModSubst a where+    -- In notation, substitution is postfix, which implies+    -- putting it on the right hand side, but for partial+    -- application it's more convenient to have it on the left+    -- hand side.+    modSubst :: OpenModuleSubst -> a -> a++instance ModSubst OpenModule where+    modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name+    modSubst subst mod@(OpenModuleVar mod_name)+        | Just mod' <- Map.lookup mod_name subst = mod'+        | otherwise = mod++instance ModSubst OpenUnitId where+    modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)+    modSubst _subst uid = uid++instance ModSubst (Set ModuleName) where+    modSubst subst reqs+        = Set.union (Set.difference reqs (Map.keysSet subst))+                    (openModuleSubstFreeHoles subst)++-- Substitutions are functorial.  NB: this means that+-- there is an @instance 'ModSubst' 'ModuleSubst'@!+instance ModSubst a => ModSubst (Map k a) where+    modSubst subst = fmap (modSubst subst)+instance ModSubst a => ModSubst [a] where+    modSubst subst = fmap (modSubst subst)+instance ModSubst a => ModSubst (k, a) where+    modSubst subst (x,y) = (x, modSubst subst y)
+ cabal/Cabal/Distribution/Backpack/ModuleScope.hs view
@@ -0,0 +1,86 @@+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.ModuleScope (+    -- * Module scopes+    ModuleScope(..),+    ModuleProvides,+    ModuleSource(..),+    emptyModuleScope,+) where++import Prelude ()++import Distribution.ModuleName+import Distribution.Package+import Distribution.Types.IncludeRenaming++import Distribution.Backpack+import Distribution.Backpack.ModSubst++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+++-----------------------------------------------------------------------+-- Module scopes++-- Why is ModuleProvides so complicated?  The basic problem is that+-- we want to support this:+--+--  package p where+--      include q (A)+--      include r (A)+--      module B where+--          import "q" A+--          import "r" A+--+-- Specifically, in Cabal today it is NOT an error have two modules in+-- scope with the same identifier.  So we need to preserve this for+-- Backpack.  The modification is that an ambiguous module name is+-- OK... as long as it is NOT used to fill a requirement!+--+-- So as a first try, we might try deferring unifying provisions that+-- are being glommed together, and check for equality after the fact.+-- But this doesn't work, because what if a multi-module provision+-- is used to fill a requirement?!  So you do the equality test+-- IMMEDIATELY before a requirement fill happens... or never at all.+--+-- Alternate strategy: go ahead and unify, and then if it is revealed+-- that some requirements got filled "out-of-thin-air", error.+++-- | A 'ModuleScope' describes the modules and requirements that+-- are in-scope as we are processing a Cabal package.  Unlike+-- a 'ModuleShape', there may be multiple modules in scope at+-- the same 'ModuleName'; this is only an error if we attempt+-- to use those modules to fill a requirement.  A 'ModuleScope'+-- can influence the 'ModuleShape' via a reexport.+data ModuleScope = ModuleScope {+    modScopeProvides :: ModuleProvides,+    modScopeRequires :: Set ModuleName+    }++-- | Every 'Module' in scope at a 'ModuleName' is annotated with+-- the 'PackageName' it comes from.+type ModuleProvides = Map ModuleName [ModuleSource]+data ModuleSource =+    ModuleSource {+        -- We don't have line numbers, but if we did the+        -- package name and renaming could be associated+        -- with that as well+        msrc_pkgname :: PackageName,+        msrc_renaming :: IncludeRenaming,+        msrc_module :: OpenModule+    }++instance ModSubst ModuleScope where+    modSubst subst (ModuleScope provs reqs)+        = ModuleScope (modSubst subst provs) (modSubst subst reqs)++-- | An empty 'ModuleScope'.+emptyModuleScope :: ModuleScope+emptyModuleScope = ModuleScope Map.empty Set.empty++instance ModSubst ModuleSource where+    modSubst subst src = src { msrc_module = modSubst subst (msrc_module src) }
+ cabal/Cabal/Distribution/Backpack/ModuleShape.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveGeneric #-}+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.ModuleShape (+    -- * Module shapes+    ModuleShape(..),+    emptyModuleShape,+    shapeInstalledPackage,+) where++import Prelude ()+import Distribution.Compat.Prelude hiding (mod)++import Distribution.ModuleName+import Distribution.InstalledPackageInfo as IPI++import Distribution.Backpack.ModSubst+import Distribution.Backpack++import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++-----------------------------------------------------------------------+-- Module shapes++-- | A 'ModuleShape' describes the provisions and requirements of+-- a library.  We can extract a 'ModuleShape' from an+-- 'InstalledPackageInfo'.+data ModuleShape = ModuleShape {+    modShapeProvides :: OpenModuleSubst,+    modShapeRequires :: Set ModuleName+    }+    deriving (Eq, Show, Generic)++instance Binary ModuleShape++instance ModSubst ModuleShape where+    modSubst subst (ModuleShape provs reqs)+        = ModuleShape (modSubst subst provs) (modSubst subst reqs)++-- | The default module shape, with no provisions and no requirements.+emptyModuleShape :: ModuleShape+emptyModuleShape = ModuleShape Map.empty Set.empty++-- Food for thought: suppose we apply the Merkel tree optimization.+-- Imagine this situation:+--+--      component p+--          signature H+--          module P+--      component h+--          module H+--      component a+--          signature P+--          module A+--      component q(P)+--          include p+--          include h+--      component r+--          include q (P)+--          include p (P) requires (H)+--          include h (H)+--          include a (A) requires (P)+--+-- Component r should not have any conflicts, since after mix-in linking+-- the two P imports will end up being the same, so we can properly+-- instantiate it.  But to know that q's P is p:P instantiated with h:H,+-- we have to be able to expand its unit id.  Maybe we can expand it+-- lazily but in some cases it will need to be expanded.+--+-- FWIW, the way that GHC handles this is by improving unit IDs as+-- soon as it sees an improved one in the package database.  This+-- is a bit disgusting.+shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape+shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs+  where+    uid = installedOpenUnitId ipi+    provs = map shapeExposedModule (IPI.exposedModules ipi)+    reqs = requiredSignatures ipi+    shapeExposedModule (IPI.ExposedModule mod_name Nothing)+        = (mod_name, OpenModule uid mod_name)+    shapeExposedModule (IPI.ExposedModule mod_name (Just mod))+        = (mod_name, mod)
+ cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs view
@@ -0,0 +1,49 @@+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.PreExistingComponent (+    PreExistingComponent(..),+    ipiToPreExistingComponent,+) where++import Prelude ()++import Distribution.Backpack.ModuleShape+import Distribution.Backpack++import qualified Data.Map as Map+import Distribution.Package+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.InstalledPackageInfo (InstalledPackageInfo)++-- | Stripped down version of 'LinkedComponent' for things+-- we don't need to know how to build.+data PreExistingComponent+    = PreExistingComponent {+        -- | The 'PackageName' that, when we see it in 'PackageDescription',+        -- we should map this to.  This may DISAGREE with 'pc_pkgid' for+        -- internal dependencies: e.g., an internal component @lib@+        -- may be munged to @z-pkg-z-lib@, but we still want to use+        -- it when we see @lib@ in @build-depends@+        pc_pkgname :: PackageName,+        pc_pkgid :: PackageId,+        pc_uid   :: UnitId,+        pc_cid   :: ComponentId,+        pc_open_uid :: OpenUnitId,+        pc_shape :: ModuleShape+    }++-- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent',+-- which was brought into scope under the 'PackageName' (important for+-- a package qualified reference.)+ipiToPreExistingComponent :: (PackageName, InstalledPackageInfo) -> PreExistingComponent+ipiToPreExistingComponent (pn, ipi) =+    PreExistingComponent {+        pc_pkgname = pn,+        pc_pkgid = Installed.sourcePackageId ipi,+        pc_uid   = Installed.installedUnitId ipi,+        pc_cid   = Installed.installedComponentId ipi,+        pc_open_uid =+            IndefFullUnitId (Installed.installedComponentId ipi)+                            (Map.fromList (Installed.instantiatedWith ipi)),+        pc_shape = shapeInstalledPackage ipi+    }+
+ cabal/Cabal/Distribution/Backpack/ReadyComponent.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternGuards #-}+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.ReadyComponent (+    ReadyComponent(..),+    InstantiatedComponent(..),+    IndefiniteComponent(..),+    rc_compat_name,+    rc_compat_key,+    dispReadyComponent,+    toReadyComponents,+) where++import Prelude ()+import Distribution.Compat.Prelude hiding ((<>))++import Distribution.Backpack+import Distribution.Backpack.Id+import Distribution.Backpack.LinkedComponent+import Distribution.Backpack.ModuleShape++import Distribution.Types.ModuleRenaming+import Distribution.Types.Component+import Distribution.Compat.Graph (IsNode(..))++import Distribution.ModuleName+import Distribution.Package+import Distribution.Simple.Utils+import Distribution.Simple.Compiler++import qualified Control.Applicative as A+import qualified Data.Traversable as T++import Control.Monad+import Text.PrettyPrint+import qualified Data.Map as Map++import Distribution.Version+import Distribution.Text++-- | An instantiated component is simply a linked component which+-- may have a fully instantiated 'UnitId'. When we do mix-in linking,+-- we only do each component in its most general form; instantiation+-- then takes all of the fully instantiated components and recursively+-- discovers what other instantiated components we need to build+-- before we can build them.+--++data InstantiatedComponent+    = InstantiatedComponent {+        instc_insts    :: [(ModuleName, Module)],+        instc_provides :: Map ModuleName Module,+        instc_includes :: [(DefUnitId, ModuleRenaming)]+    }++data IndefiniteComponent+    = IndefiniteComponent {+        indefc_requires :: [ModuleName],+        indefc_provides :: Map ModuleName OpenModule,+        indefc_includes :: [(OpenUnitId, ModuleRenaming)]+    }++data ReadyComponent+    = ReadyComponent {+        rc_uid          :: UnitId,+        rc_open_uid     :: OpenUnitId,+        rc_cid          :: ComponentId,+        rc_pkgid        :: PackageId,+        rc_component    :: Component,+        -- build-tools don't participate in mix-in linking.+        -- (but what if they cold?)+        rc_internal_build_tools :: [DefUnitId],+        rc_public       :: Bool,+        -- PackageId here is a bit dodgy, but its just for+        -- BC so it shouldn't matter.+        rc_depends      :: [(UnitId, PackageId)],+        rc_i :: Either IndefiniteComponent InstantiatedComponent+    }++instance Package ReadyComponent where+    packageId = rc_pkgid++instance HasUnitId ReadyComponent where+    installedUnitId = rc_uid++instance IsNode ReadyComponent where+    type Key ReadyComponent = UnitId+    nodeKey = rc_uid+    nodeNeighbors rc =+      (case rc_i rc of+        Right inst | [] <- instc_insts inst+                   -> []+                   | otherwise+                   -> [newSimpleUnitId (rc_cid rc)]+        _ -> []) +++      ordNub (map fst (rc_depends rc))++rc_compat_name :: ReadyComponent -> PackageName+rc_compat_name ReadyComponent{+        rc_pkgid = PackageIdentifier pkg_name _,+        rc_component = component+    }+    = computeCompatPackageName pkg_name (componentName component)++rc_compat_key :: ReadyComponent -> Compiler -> String+rc_compat_key rc@ReadyComponent {+        rc_pkgid = PackageIdentifier _ pkg_ver,+        rc_uid = uid+    } comp -- TODO: A wart. But the alternative is to store+           -- the Compiler in the LinkedComponent+    = computeCompatPackageKey comp (rc_compat_name rc) pkg_ver uid++dispReadyComponent :: ReadyComponent -> Doc+dispReadyComponent rc =+    hang (text (case rc_i rc of+                    Left  _ -> "indefinite"+                    Right _ -> "definite")+            <+> disp (nodeKey rc)+            {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $+        vcat [ text "depends" <+> disp uid+             | uid <- nodeNeighbors rc ]++-- | The state of 'InstM'; a mapping from 'UnitId's to their+-- ready component, or @Nothing@ if its an external+-- component which we don't know how to build.+type InstS = Map UnitId (Maybe ReadyComponent)++-- | A state monad for doing instantiations (can't use actual+-- State because that would be an extra dependency.)+newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) }++instance Functor InstM where+    fmap f (InstM m) = InstM $ \s -> let (x, s') = m s+                                     in (f x, s')++instance A.Applicative InstM where+    pure a = InstM $ \s -> (a, s)+    InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s+                                            (x', s'') = x s'+                                        in (f' x', s'')++instance Monad InstM where+    return = A.pure+    InstM m >>= f = InstM $ \s -> let (x, s') = m s+                                  in runInstM (f x) s'++-- | Given a list of 'LinkedComponent's, expand the module graph+-- so that we have an instantiated graph containing all of the+-- instantiated components we need to build.+--+-- Instantiation intuitively follows the following algorithm:+--+--      instantiate a definite unit id p[S]:+--          recursively instantiate each module M in S+--          recursively instantiate modules exported by this unit+--          recursively instantiate dependencies substituted by S+--+-- The implementation is a bit more involved to memoize instantiation+-- if we have done it already.+--+-- We also call 'improveUnitId' during this process, so that fully+-- instantiated components are given 'HashedUnitId'.+--+toReadyComponents+    :: Map UnitId PackageId+    -> Map ModuleName Module -- subst for the public component+    -> [LinkedComponent]+    -> [ReadyComponent]+toReadyComponents pid_map subst0 comps+    = catMaybes (Map.elems ready_map)+  where+    cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ]++    instantiateUnitId :: ComponentId -> Map ModuleName Module+                      -> InstM DefUnitId+    instantiateUnitId cid insts = InstM $ \s ->+        case Map.lookup uid s of+            Nothing ->+                -- Knot tied+                let (r, s') = runInstM (instantiateComponent uid cid insts)+                                       (Map.insert uid r s)+                in (def_uid, Map.insert uid r s')+            Just _ -> (def_uid, s)+      where+        -- The mkDefUnitId here indicates that we assume+        -- that Cabal handles unit id hash allocation.+        -- Good thing about hashing here: map is only on string.+        -- Bad thing: have to repeatedly hash.+        def_uid = mkDefUnitId cid insts+        uid = unDefUnitId def_uid++    instantiateComponent+        :: UnitId -> ComponentId -> Map ModuleName Module+        -> InstM (Maybe ReadyComponent)+    instantiateComponent uid cid insts+      | Just lc <- Map.lookup cid cmap = do+            deps <- forM (lc_depends lc) $ \(x, y) -> do+                x' <- substUnitId insts x+                return (x', y)+            provides <- T.mapM (substModule insts) (modShapeProvides (lc_shape lc))+            includes <- forM (lc_includes lc) $ \(x, y) -> do+                x' <- substUnitId insts x+                return (x', y)+            build_tools <- mapM (substUnitId insts) (lc_internal_build_tools lc)+            s <- InstM $ \s -> (s, s)+            let getDep (Module dep_def_uid _)+                    | let dep_uid = unDefUnitId dep_def_uid+                    -- Lose DefUnitId invariant for rc_depends+                    = [(dep_uid,+                          fromMaybe err_pid $+                            Map.lookup dep_uid pid_map A.<|>+                            fmap rc_pkgid (join (Map.lookup dep_uid s)))]+                  where+                    err_pid =+                      PackageIdentifier+                        (mkPackageName "nonexistent-package-this-is-a-cabal-bug")+                        (mkVersion [0])+                instc = InstantiatedComponent {+                            instc_insts = Map.toList insts,+                            instc_provides = provides,+                            instc_includes = includes+                        }+            return $ Just ReadyComponent {+                    rc_uid          = uid,+                    rc_open_uid     = DefiniteUnitId (unsafeMkDefUnitId uid),+                    rc_cid          = lc_cid lc,+                    rc_pkgid        = lc_pkgid lc,+                    rc_component    = lc_component lc,+                    rc_internal_build_tools = build_tools,+                    rc_public       = lc_public lc,+                    rc_depends      = ordNub $+                                        -- NB: don't put the dep on the indef+                                        -- package here, since we DO NOT want+                                        -- to put it in 'depends' in the IPI+                                        map (\(x,y) -> (unDefUnitId x, y)) deps +++                                        concatMap getDep (Map.elems insts),+                    rc_i            = Right instc+                   }+      | otherwise = return Nothing++    substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId+    substUnitId _ (DefiniteUnitId uid) =+        return uid+    substUnitId subst (IndefFullUnitId cid insts) = do+        insts' <- substSubst subst insts+        instantiateUnitId cid insts'++    -- NB: NOT composition+    substSubst :: Map ModuleName Module+               -> Map ModuleName OpenModule+               -> InstM (Map ModuleName Module)+    substSubst subst insts = T.mapM (substModule subst) insts++    substModule :: Map ModuleName Module -> OpenModule -> InstM Module+    substModule subst (OpenModuleVar mod_name)+        | Just m <- Map.lookup mod_name subst = return m+        | otherwise = error "substModule: non-closing substitution"+    substModule subst (OpenModule uid mod_name) = do+        uid' <- substUnitId subst uid+        return (Module uid' mod_name)++    indefiniteUnitId :: ComponentId -> InstM UnitId+    indefiniteUnitId cid = do+        let uid = newSimpleUnitId cid+        r <- indefiniteComponent uid cid+        InstM $ \s -> (uid, Map.insert uid r s)++    indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)+    indefiniteComponent uid cid+      | Just lc <- Map.lookup cid cmap = do+            -- TODO: Goofy+            build_tools <- mapM (substUnitId Map.empty) (lc_internal_build_tools lc)+            let indefc = IndefiniteComponent {+                        indefc_requires = map fst (lc_insts lc),+                        indefc_provides = modShapeProvides (lc_shape lc),+                        indefc_includes = lc_includes lc+                    }+            return $ Just ReadyComponent {+                    rc_uid          = uid,+                    rc_open_uid     = lc_uid lc,+                    rc_cid = lc_cid lc,+                    rc_pkgid        = lc_pkgid lc,+                    rc_component    = lc_component lc,+                    rc_internal_build_tools = build_tools,+                    rc_public       = lc_public lc,+                    rc_depends      = ordNub (map (\(x,y) -> (abstractUnitId x, y)) (lc_depends lc)),+                    rc_i            = Left indefc+                }+      | otherwise = return Nothing++    ready_map = snd $ runInstM work Map.empty++    work+        | not (Map.null subst0)+        , [lc] <- filter lc_public (Map.elems cmap)+        = do _ <- instantiateUnitId (lc_cid lc) subst0+             return ()+        | otherwise+        = forM_ (Map.elems cmap) $ \lc ->+            if null (lc_insts lc)+                then instantiateUnitId (lc_cid lc) Map.empty >> return ()+                else indefiniteUnitId (lc_cid lc) >> return ()
+ cabal/Cabal/Distribution/Backpack/UnifyM.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE Rank2Types #-}+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.UnifyM (+    -- * Unification monad+    UnifyM,+    runUnifyM,+    unifyFail,+    withContext,+    liftST,++    UnifEnv(..),+    getUnifEnv,++    -- * Modules and unit IDs+    ModuleU,+    ModuleU'(..),+    convertModule,+    convertModuleU,++    UnitIdU,+    UnitIdU'(..),+    convertUnitId,+    convertUnitIdU,++    ModuleSubstU,+    convertModuleSubstU,+    convertModuleSubst,++    ModuleScopeU,+    emptyModuleScopeU,+    convertModuleScopeU,++    ModuleSourceU(..),++    convertInclude,+    convertModuleProvides,+    convertModuleProvidesU,++) where++import Prelude ()+import Distribution.Compat.Prelude hiding (mod)++import Distribution.Backpack.ModuleShape+import Distribution.Backpack.ModuleScope+import Distribution.Backpack.ModSubst+import Distribution.Backpack.FullUnitId+import Distribution.Backpack++import qualified Distribution.Utils.UnionFind as UnionFind+import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Text+import Distribution.Types.IncludeRenaming+import Distribution.Verbosity++import Data.STRef+import Control.Monad.ST+import Control.Monad+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.Traversable as T++-- TODO: more detailed trace output on high verbosity would probably+-- be appreciated by users debugging unification errors.  Collect+-- some good examples!++-- | The unification monad, this monad encapsulates imperative+-- unification.+newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Either String a) }++-- | Run a computation in the unification monad.+runUnifyM :: Verbosity -> FullDb -> (forall s. UnifyM s a) -> Either String a+runUnifyM verbosity db m+    = runST $ do i    <- newSTRef 0+                 hmap <- newSTRef Map.empty+                 unUnifyM m (UnifEnv i hmap verbosity Nothing db)+-- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'.++-- | The unification environment.+data UnifEnv s = UnifEnv {+        -- | A supply of unique integers to label 'UnitIdU'+        -- cells.  This is used to determine loops in unit+        -- identifiers (which can happen with mutual recursion.)+        unify_uniq :: UnifRef s UnitIdUnique,+        -- | The set of requirements in scope.  When+        -- a provision is brought into scope, we unify with+        -- the requirement at the same module name to fill it.+        -- This mapping grows monotonically.+        unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)),+        -- | How verbose the error message should be+        unify_verbosity :: Verbosity,+        -- | The error reporting context+        unify_ctx :: Maybe (String, ModuleU s, ModuleU s),+        -- | The package index for expanding unit identifiers+        unify_db :: FullDb+    }++instance Functor (UnifyM s) where+    fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)++instance Applicative (UnifyM s) where+    pure = UnifyM . pure . pure . pure+    UnifyM f <*> UnifyM x = UnifyM $ \r -> do+        f' <- f r+        case f' of+          Left err -> return (Left err)+          Right f'' -> do+              x' <- x r+              case x' of+                  Left err -> return (Left err)+                  Right x'' -> return (Right (f'' x''))++instance Monad (UnifyM s) where+    return = pure+    UnifyM m >>= f = UnifyM $ \r -> do+        x <- m r+        case x of+            Left err -> return (Left err)+            Right x' -> unUnifyM (f x') r++-- | Lift a computation from 'ST' monad to 'UnifyM' monad.+-- Internal use only.+liftST :: ST s a -> UnifyM s a+liftST m = UnifyM $ \_ -> fmap Right m++unifyFail :: String -> UnifyM s a+unifyFail err = do+    env <- getUnifEnv+    msg <- case unify_ctx env of+        Nothing -> return ("Unspecified unification error: " ++ err)+        Just (ctx, mod1, mod2)+            | unify_verbosity env > normal+            -> do mod1' <- convertModuleU mod1+                  mod2' <- convertModuleU mod2+                  let extra = " (was unifying " ++ display mod1'+                                     ++ " and " ++ display mod2' ++ ")"+                  return (ctx ++ err ++ extra)+            | otherwise+            -> return (ctx ++ err ++ " (for more information, pass -v flag)")+    UnifyM $ \_ -> return (Left msg)++-- | A convenient alias for mutable references in the unification monad.+type UnifRef s a = STRef s a++-- | Imperatively read a 'UnifRef'.+readUnifRef :: UnifRef s a -> UnifyM s a+readUnifRef = liftST . readSTRef++-- | Imperatively write a 'UnifRef'.+writeUnifRef :: UnifRef s a -> a -> UnifyM s ()+writeUnifRef x = liftST . writeSTRef x++-- | Get the current unification environment.+getUnifEnv :: UnifyM s (UnifEnv s)+getUnifEnv = UnifyM $ \r -> return (Right r)++-- | Run a unification in some context+withContext :: String -> ModuleU s -> ModuleU s -> UnifyM s a -> UnifyM s a+withContext ctx mod1 mod2 m =+    UnifyM $ \r -> unUnifyM m r { unify_ctx = Just (ctx, mod1, mod2) }++-----------------------------------------------------------------------+-- The "unifiable" variants of the data types+--+-- In order to properly do unification over infinite trees, we+-- need to union find over 'Module's and 'UnitId's.  The pure+-- representation is ill-equipped to do this, so we convert+-- from the pure representation into one which is indirected+-- through union-find.  'ModuleU' handles hole variables;+-- 'UnitIdU' handles mu-binders.++-- | Contents of a mutable 'ModuleU' reference.+data ModuleU' s+    = ModuleU (UnitIdU s) ModuleName+    | ModuleVarU ModuleName++-- | Contents of a mutable 'UnitIdU' reference.+data UnitIdU' s+    = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))+    | UnitIdThunkU DefUnitId++-- | A mutable version of 'Module' which can be imperatively unified.+type ModuleU s = UnionFind.Point s (ModuleU' s)++-- | A mutable version of 'UnitId' which can be imperatively unified.+type UnitIdU s = UnionFind.Point s (UnitIdU' s)++-- | An integer for uniquely labeling 'UnitIdU' nodes.  We need+-- these labels in order to efficiently serialize 'UnitIdU's into+-- 'UnitId's (we use the label to check if any parent is the+-- node in question, and if so insert a deBruijn index instead.)+-- These labels must be unique across all 'UnitId's/'Module's which+-- participate in unification!+type UnitIdUnique = Int+++-----------------------------------------------------------------------+-- Conversion to the unifiable data types++-- An environment for tracking the mu-bindings in scope.+-- The invariant for a state @(m, i)@ is that [0..i] are+-- keys of @m@; in fact, the @i-k@th entry is the @k@th+-- de Bruijn index (this saves us from having to shift as+-- we enter mu-binders.)+type MuEnv s = (IntMap (UnitIdU s), Int)++extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s+extendMuEnv (m, i) x =+    (IntMap.insert (i + 1) x m, i + 1)++{-+lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s+lookupMuEnv (m, i) k =+    case IntMap.lookup (i - k) m of+        -- Technically a user can trigger this by giving us a+        -- bad 'UnitId', so handle this better.+        Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)"+        Just v -> v+-}++emptyMuEnv :: MuEnv s+emptyMuEnv = (IntMap.empty, -1)++-- The workhorse functions.  These share an environment:+--   * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes+--   * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized)+--     environment containing the implicitly universally quantified+--     @hole:A@ binders.+--   * @MuEnv@ - the environment for mu-binders.++convertUnitId' :: MuEnv s+               -> OpenUnitId+               -> UnifyM s (UnitIdU s)+-- TODO: this could be more lazy if we know there are no internal+-- references+convertUnitId' _ (DefiniteUnitId uid) =+    liftST $ UnionFind.fresh (UnitIdThunkU uid)+convertUnitId' stk (IndefFullUnitId cid insts) = do+    fs <- fmap unify_uniq getUnifEnv+    x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later+    insts_u <- T.forM insts $ convertModule' (extendMuEnv stk x)+    u <- readUnifRef fs+    writeUnifRef fs (u+1)+    y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)+    liftST $ UnionFind.union x y+    return y+-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i)++convertModule' :: MuEnv s+               -> OpenModule -> UnifyM s (ModuleU s)+convertModule' _stk (OpenModuleVar mod_name) = do+    hmap <- fmap unify_reqs getUnifEnv+    hm <- readUnifRef hmap+    case Map.lookup mod_name hm of+        Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)+                      writeUnifRef hmap (Map.insert mod_name mod hm)+                      return mod+        Just mod -> return mod+convertModule' stk (OpenModule uid mod_name) = do+    uid_u <- convertUnitId' stk uid+    liftST $ UnionFind.fresh (ModuleU uid_u mod_name)++convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s)+convertUnitId = convertUnitId' emptyMuEnv++convertModule :: OpenModule -> UnifyM s (ModuleU s)+convertModule = convertModule' emptyMuEnv++++-----------------------------------------------------------------------+-- Substitutions++-- | The mutable counterpart of a 'ModuleSubst' (not defined here).+type ModuleSubstU s = Map ModuleName (ModuleU s)++-- | Conversion of 'ModuleSubst' to 'ModuleSubstU'+convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s))+convertModuleSubst = T.mapM convertModule++-- | Conversion of 'ModuleSubstU' to 'ModuleSubst'+convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst+convertModuleSubstU = T.mapM convertModuleU++-----------------------------------------------------------------------+-- Conversion from the unifiable data types++-- An environment for tracking candidates for adding a mu-binding.+-- The invariant for a state @(m, i)@, is that if we encounter a node+-- labeled @k@ such that @m[k -> v]@, then we can replace this+-- node with the de Bruijn index @i-v@ referring to an enclosing+-- mu-binder; furthermore, @range(m) = [0..i]@.+type MooEnv = (IntMap Int, Int)++emptyMooEnv :: MooEnv+emptyMooEnv = (IntMap.empty, -1)++extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv+extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1)++lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int+lookupMooEnv (m, i) k =+    case IntMap.lookup k m of+        Nothing -> Nothing+        Just v -> Just (i-v) -- de Bruijn indexize++-- The workhorse functions++convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId+convertUnitIdU' stk uid_u = do+    x <- liftST $ UnionFind.find uid_u+    case x of+        UnitIdThunkU uid -> return (DefiniteUnitId uid)+        UnitIdU u cid insts_u ->+            case lookupMooEnv stk u of+                Just _i -> error "convertUnitIdU': mutual recursion" -- return (UnitIdVar i)+                Nothing -> do+                    insts <- T.forM insts_u $ convertModuleU' (extendMooEnv stk u)+                    return (IndefFullUnitId cid insts)++convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule+convertModuleU' stk mod_u = do+    mod <- liftST $ UnionFind.find mod_u+    case mod of+        ModuleVarU mod_name -> return (OpenModuleVar mod_name)+        ModuleU uid_u mod_name -> do+            uid <- convertUnitIdU' stk uid_u+            return (OpenModule uid mod_name)++-- Helper functions++convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId+convertUnitIdU = convertUnitIdU' emptyMooEnv++convertModuleU :: ModuleU s -> UnifyM s OpenModule+convertModuleU = convertModuleU' emptyMooEnv++-- | An empty 'ModuleScopeU'.+emptyModuleScopeU :: ModuleScopeU s+emptyModuleScopeU = (Map.empty, Map.empty)+++-- | The mutable counterpart of 'ModuleScope'.+type ModuleScopeU s = (ModuleProvidesU s, ModuleSubstU s)+-- | The mutable counterpart of 'ModuleProvides'+type ModuleProvidesU s = Map ModuleName [ModuleSourceU s]+data ModuleSourceU s =+    ModuleSourceU {+        -- We don't have line numbers, but if we did the+        -- package name and renaming could be associated+        -- with that as well+        usrc_pkgname :: PackageName,+        usrc_renaming :: IncludeRenaming,+        usrc_module :: ModuleU s+    }++-- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do+-- unification on it.+convertInclude+    :: ((OpenUnitId, ModuleShape), PackageId, IncludeRenaming)+    -> UnifyM s (ModuleScopeU s, (UnitIdU s, PackageId, ModuleRenaming))+convertInclude ((uid, ModuleShape provs reqs), pid, incl@(IncludeRenaming prov_rns req_rns)) = do+    let pn = packageName pid++    -- Suppose our package has two requirements A and B, and+    -- we include it with @requires (A as X)@+    -- There are three closely related things we compute based+    -- off of @reqs@ and @reqs_rns@:+    --+    --      1. The requirement renaming (A -> X)+    --      2. The requirement substitution (A -> <X>, B -> <B>)++    -- Requirement renaming.  This is read straight off the syntax:+    --+    --      [nothing]          ==>  [empty]+    --      requires (B as Y)  ==>  B -> Y+    --+    -- Requirement renamings are NOT injective: if two requirements+    -- are mapped to the same name, the intent is to merge them+    -- together.  But they are *functions*, so @B as X, B as Y@ is+    -- illegal.+    let insertDistinct m (k,v) =+            if Map.member k m+                then error ("Duplicate requirement renaming " ++ display k)+                else return (Map.insert k v m)+    req_rename <- foldM insertDistinct Map.empty =<<+                      case req_rns of+                        DefaultRenaming -> return []+                        -- Not valid here, but whatever+                        HidingRenaming _ -> error "Cannot use hiding in requirement renaming"+                        ModuleRenaming rns -> return rns+    let req_rename_fn k = case Map.lookup k req_rename of+                            Nothing -> k+                            Just v  -> v++    -- Requirement substitution.+    --+    --      A -> X      ==>     A -> <X>+    let req_subst = fmap OpenModuleVar req_rename++    uid_u <- convertUnitId (modSubst req_subst uid)++    -- Requirement mapping.  This is just taking the range of the+    -- requirement substitution, and making a mapping so that it is+    -- convenient to merge things together.  It INCLUDES the implicit+    -- mappings.+    --+    --      A -> X      ==>     X -> <X>, B -> <B>+    reqs_u <- convertModuleSubst . Map.fromList $+                [ (k, OpenModuleVar k)+                | k <- map req_rename_fn (Set.toList reqs)+                ]++    -- Provision computation is more complex.+    -- For example, if we have:+    --+    --      include p (A as X) requires (B as Y)+    --          where A -> q[B=<B>]:A+    --+    -- Then we need:+    --+    --      X -> [("p", q[B=<B>]:A)]+    --+    -- There are a bunch of clever ways to present the algorithm+    -- but here is the simple one:+    --+    --      1. If we have a default renaming, apply req_subst+    --      to provs and use that.+    --+    --      2. Otherwise, build a map by successively looking+    --      up the referenced modules in the renaming in provs.+    --+    -- Importantly, overlapping rename targets get accumulated+    -- together.  It's not an (immediate) error.+    (pre_prov_scope, prov_rns') <-+        case prov_rns of+            DefaultRenaming -> return (Map.toList provs, prov_rns)+            HidingRenaming hides ->+                let hides_set = Set.fromList hides+                in let r = [ (k,v)+                           | (k,v) <- Map.toList provs+                           , not (k `Set.member` hides_set) ]+                   -- GHC doesn't understand hiding, so expand it out!+                   in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r))+            ModuleRenaming rns -> do+              r <- sequence+                [ case Map.lookup from provs of+                    Just m -> return (to, m)+                    Nothing -> error ("Tried to rename non-existent module " ++ display from)+                | (from, to) <- rns ]+              return (r, prov_rns)+    let prov_scope = modSubst req_subst+                   $ Map.fromListWith (++)+                   [ (k, [ModuleSource pn incl v])+                   | (k, v) <- pre_prov_scope ]++    provs_u <- convertModuleProvides prov_scope++    return ((provs_u, reqs_u), (uid_u, pid, prov_rns'))++-- | Convert a 'ModuleScopeU' to a 'ModuleScope'.+convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope+convertModuleScopeU (provs_u, reqs_u) = do+    provs <- convertModuleProvidesU provs_u+    reqs  <- convertModuleSubstU reqs_u+    -- TODO: Test that the requirements are still free. If they+    -- are not, they got unified, and that's dodgy at best.+    return (ModuleScope provs (Map.keysSet reqs))++-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU'+convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)+convertModuleProvides = T.mapM $ \ms ->+    mapM (\(ModuleSource pn incl m)+            -> do m' <- convertModule m+                  return (ModuleSourceU pn incl m')) ms++-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides'+convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides+convertModuleProvidesU = T.mapM $ \ms ->+    mapM (\(ModuleSourceU pn incl m)+            -> do m' <- convertModuleU m+                  return (ModuleSource pn incl m')) ms
cabal/Cabal/Distribution/Compat/Binary.hs view
@@ -9,14 +9,19 @@  module Distribution.Compat.Binary        ( decodeOrFailIO+       , decodeFileOrFail' #if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)        , module Data.Binary #else        , Binary(..)-       , decode, encode+       , decode, encode, encodeFile #endif        ) where +#if __GLASGOW_HASKELL__ < 706+import Prelude hiding (catch)+#endif+ import Control.Exception (catch, evaluate) #if __GLASGOW_HASKELL__ >= 711 import Control.Exception (pattern ErrorCall)@@ -25,23 +30,25 @@ #endif import Data.ByteString.Lazy (ByteString) -#if __GLASGOW_HASKELL__ < 706-import Prelude hiding (catch)-#endif- #if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)  import Data.Binary +-- | Lazily reconstruct a value previously written to a file.+decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a)+decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f+ #else  import Data.Binary.Get import Data.Binary.Put+import qualified Data.ByteString.Lazy as BSL  import Distribution.Compat.Binary.Class import Distribution.Compat.Binary.Generic () --- | Decode a value from a lazy ByteString, reconstructing the original structure.+-- | Decode a value from a lazy ByteString, reconstructing the+-- original structure. -- decode :: Binary a => ByteString -> a decode = runGet get@@ -51,6 +58,14 @@ encode :: Binary a => a -> ByteString encode = runPut . put {-# INLINE encode #-}++-- | Lazily reconstruct a value previously written to a file.+decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a)+decodeFileOrFail' f = decodeOrFailIO =<< BSL.readFile f++-- | Lazily serialise a value to a file+encodeFile :: Binary a => FilePath -> a -> IO ()+encodeFile f = BSL.writeFile f . encode  #endif
cabal/Cabal/Distribution/Compat/Binary/Class.hs view
@@ -36,8 +36,9 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L -import Data.Char    (chr,ord)-import Data.List    (unfoldr)+import Data.Char     (chr,ord)+import Data.List     (unfoldr)+import Data.Foldable (traverse_)  -- And needed for the instances: import qualified Data.ByteString as B@@ -389,7 +390,7 @@ -- Container types  instance Binary a => Binary [a] where-    put l  = put (length l) >> mapM_ put l+    put l  = put (length l) >> traverse_ put l     get    = do n <- get :: Get Int                 getMany n @@ -444,26 +445,26 @@ -- Maps and Sets  instance (Binary a) => Binary (Set.Set a) where-    put s = put (Set.size s) >> mapM_ put (Set.toAscList s)+    put s = put (Set.size s) >> traverse_ put (Set.toAscList s)     get   = liftM Set.fromDistinctAscList get  instance (Binary k, Binary e) => Binary (Map.Map k e) where-    put m = put (Map.size m) >> mapM_ put (Map.toAscList m)+    put m = put (Map.size m) >> traverse_ put (Map.toAscList m)     get   = liftM Map.fromDistinctAscList get  instance Binary IntSet.IntSet where-    put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)+    put s = put (IntSet.size s) >> traverse_ put (IntSet.toAscList s)     get   = liftM IntSet.fromDistinctAscList get  instance (Binary e) => Binary (IntMap.IntMap e) where-    put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)+    put m = put (IntMap.size m) >> traverse_ put (IntMap.toAscList m)     get   = liftM IntMap.fromDistinctAscList get  ------------------------------------------------------------------------ -- Queues and Sequences  instance (Binary e) => Binary (Seq.Seq e) where-    put s = put (Seq.length s) >> Fold.mapM_ put s+    put s = put (Seq.length s) >> Fold.traverse_ put s     get = do n <- get :: Get Int              rep Seq.empty n get       where rep xs 0 _ = return $! xs@@ -496,7 +497,7 @@     put a = do         put (bounds a)         put (rangeSize $ bounds a) -- write the length-        mapM_ put (elems a)        -- now the elems.+        traverse_ put (elems a)        -- now the elems.     get = do         bs <- get         n  <- get                  -- read the length@@ -510,7 +511,7 @@     put a = do         put (bounds a)         put (rangeSize $ bounds a) -- now write the length-        mapM_ put (elems a)+        traverse_ put (elems a)     get = do         bs <- get         n  <- get
cabal/Cabal/Distribution/Compat/CopyFile.hs view
@@ -11,11 +11,12 @@   setDirOrdinary,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Compat.Exception import Distribution.Compat.Internal.TempFile -import Control.Monad-         ( when, unless ) import Control.Exception          ( bracketOnError, throwIO ) import qualified Data.ByteString.Lazy as BSL@@ -41,16 +42,16 @@          ( throwErrnoPathIfMinus1_ ) #endif /* mingw32_HOST_OS */ -copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()+copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> NoCallStackIO () copyOrdinaryFile   src dest = copyFile src dest >> setFileOrdinary   dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest -setFileOrdinary,  setFileExecutable, setDirOrdinary  :: FilePath -> IO ()+setFileOrdinary,  setFileExecutable, setDirOrdinary  :: FilePath -> NoCallStackIO () #ifndef mingw32_HOST_OS setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r-- setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x -setFileMode :: FilePath -> FileMode -> IO ()+setFileMode :: FilePath -> FileMode -> NoCallStackIO () setFileMode name m =   withFilePath name $ \s -> do     throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)@@ -63,7 +64,7 @@  -- | Copies a file to a new destination. -- Often you should use `copyFileChanged` instead.-copyFile :: FilePath -> FilePath -> IO ()+copyFile :: FilePath -> FilePath -> NoCallStackIO () copyFile fromFPath toFPath =   copy     `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))@@ -87,14 +88,14 @@ -- | Like `copyFile`, but does not touch the target if source and destination -- are already byte-identical. This is recommended as it is useful for -- time-stamp based recompilation avoidance.-copyFileChanged :: FilePath -> FilePath -> IO ()+copyFileChanged :: FilePath -> FilePath -> NoCallStackIO () copyFileChanged src dest = do   equal <- filesEqual src dest   unless equal $ copyFile src dest  -- | Checks if two files are byte-identical. -- Returns False if either of the files do not exist.-filesEqual :: FilePath -> FilePath -> IO Bool+filesEqual :: FilePath -> FilePath -> NoCallStackIO Bool filesEqual f1 f2 = do   ex1 <- doesFileExist f1   ex2 <- doesFileExist f2
cabal/Cabal/Distribution/Compat/CreatePipe.hs view
@@ -1,10 +1,18 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ module Distribution.Compat.CreatePipe (createPipe) where  import System.IO (Handle, hSetEncoding, localeEncoding) +import Prelude ()+import Distribution.Compat.Prelude+import Distribution.Compat.Stack+ -- The mingw32_HOST_OS CPP macro is GHC-specific-#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS+import qualified Prelude import Control.Exception (onException) import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.Types (CInt(..), CUInt(..))@@ -15,7 +23,7 @@ import GHC.IO.Device (IODeviceType(Stream)) import GHC.IO.Handle.FD (mkHandleFromFD) import System.IO (IOMode(ReadMode, WriteMode))-#elif ghcjs_HOST_OS+#elif defined ghcjs_HOST_OS #else import System.Posix.IO (fdToHandle) import qualified System.Posix.IO as Posix@@ -23,7 +31,7 @@  createPipe :: IO (Handle, Handle) -- The mingw32_HOST_OS CPP macro is GHC-specific-#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS createPipe = do     (readfd, writefd) <- allocaArray 2 $ \ pfds -> do         throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)@@ -36,21 +44,26 @@         hSetEncoding writeh localeEncoding         return (readh, writeh)) `onException` (close readfd >> close writefd)   where-    fdToHandle :: CInt -> IOMode -> IO Handle+    fdToHandle :: CInt -> IOMode -> NoCallStackIO Handle     fdToHandle fd mode = do         (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False         mkHandleFromFD fd' deviceType "" mode False Nothing      close :: CInt -> IO ()     close = throwErrnoIfMinus1_ "_close" . c__close+      where _ = callStack -- TODO: attach call stack to exception +    _ = callStack -- TODO: attach call stack to exceptions+ foreign import ccall "io.h _pipe" c__pipe ::-    Ptr CInt -> CUInt -> CInt -> IO CInt+    Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt  foreign import ccall "io.h _close" c__close ::-    CInt -> IO CInt-#elif ghcjs_HOST_OS+    CInt -> Prelude.IO CInt+#elif defined ghcjs_HOST_OS createPipe = error "createPipe"+  where+    _ = callStack #else createPipe = do     (readfd, writefd) <- Posix.createPipe@@ -59,4 +72,6 @@     hSetEncoding readh localeEncoding     hSetEncoding writeh localeEncoding     return (readh, writeh)+  where+    _ = callStack #endif
+ cabal/Cabal/Distribution/Compat/DList.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Compat.DList+-- Copyright   :  (c) Ben Gamari 2015-2019+-- License     :  BSD3+--+-- Maintainer  :  cabal-dev@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- A very simple difference list.+module Distribution.Compat.DList (+    DList,+    runDList,+    singleton,+    snoc,+) where++import Prelude ()+import Distribution.Compat.Prelude++-- | Difference list.+newtype DList a = DList ([a] -> [a])++runDList :: DList a -> [a]+runDList (DList run) = run []++-- | Make 'DList' with containing single element.+singleton :: a -> DList a+singleton a = DList (a:)++snoc :: DList a -> a -> DList a+snoc xs x = xs <> singleton x++instance Monoid (DList a) where+  mempty = DList id+  mappend = (<>)++instance Semigroup (DList a) where+  DList a <> DList b = DList (a . b)
cabal/Cabal/Distribution/Compat/Environment.hs view
@@ -1,21 +1,36 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK hide #-}  module Distribution.Compat.Environment-       ( getEnvironment, lookupEnv, setEnv )+       ( getEnvironment, lookupEnv, setEnv, unsetEnv )        where +import Prelude ()+import qualified Prelude+import Distribution.Compat.Prelude++#ifndef mingw32_HOST_OS+#if __GLASGOW_HASKELL__ < 708+import Foreign.C.Error (throwErrnoIf_)+#endif+#endif+ import qualified System.Environment as System #if __GLASGOW_HASKELL__ >= 706 import System.Environment (lookupEnv)+#if __GLASGOW_HASKELL__ >= 708+import System.Environment (unsetEnv)+#endif #else import Distribution.Compat.Exception (catchIO) #endif +import Distribution.Compat.Stack+ #ifdef mingw32_HOST_OS-import Control.Monad-import qualified Data.Char as Char (toUpper) import Foreign.C import GHC.Windows #else@@ -25,7 +40,7 @@ import System.Posix.Internals ( withFilePath ) #endif /* mingw32_HOST_OS */ -getEnvironment :: IO [(String, String)]+getEnvironment :: NoCallStackIO [(String, String)] #ifdef mingw32_HOST_OS -- On Windows, the names of environment variables are case-insensitive, but are -- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise@@ -33,7 +48,7 @@ getEnvironment = fmap upcaseVars System.getEnvironment   where     upcaseVars = map upcaseVar-    upcaseVar (var, val) = (map Char.toUpper var, val)+    upcaseVar (var, val) = (map toUpper var, val) #else getEnvironment = System.getEnvironment #endif@@ -50,9 +65,7 @@ -- Throws `Control.Exception.IOException` if either @name@ or @value@ is the -- empty string or contains an equals sign. setEnv :: String -> String -> IO ()-setEnv key value_-  | null value = error "Distribuiton.Compat.setEnv: empty string"-  | otherwise  = setEnv_ key value+setEnv key value_ = setEnv_ key value   where     -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We     -- still strip it manually so that the null check above succeeds if a value@@ -66,6 +79,8 @@ setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do   success <- c_SetEnvironmentVariable k v   unless success (throwGetLastError "setEnv")+ where+  _ = callStack -- TODO: attach CallStack to exception  # if defined(i386_HOST_ARCH) #  define WINDOWS_CCONV stdcall@@ -76,14 +91,47 @@ # endif /* i386_HOST_ARCH */  foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"-  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool+  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool #else setEnv_ key value = do   withFilePath key $ \ keyP ->     withFilePath value $ \ valueP ->       throwErrnoIfMinus1_ "setenv" $         c_setenv keyP valueP (fromIntegral (fromEnum True))+ where+  _ = callStack -- TODO: attach CallStack to exception  foreign import ccall unsafe "setenv"-   c_setenv :: CString -> CString -> CInt -> IO CInt+   c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt #endif /* mingw32_HOST_OS */++#if __GLASGOW_HASKELL__ < 708++-- | @unsetEnv name@ removes the specified environment variable from the+-- environment of the current process.+--+-- Throws `Control.Exception.IOException` if @name@ is the empty string or+-- contains an equals sign.+--+-- @since 4.7.0.0+unsetEnv :: String -> IO ()+#ifdef mingw32_HOST_OS+unsetEnv key = withCWString key $ \k -> do+  success <- c_SetEnvironmentVariable k nullPtr+  unless success $ do+    -- We consider unsetting an environment variable that does not exist not as+    -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.+    err <- c_GetLastError+    unless (err == eRROR_ENVVAR_NOT_FOUND) $ do+      throwGetLastError "unsetEnv"+#else+unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)+#if __GLASGOW_HASKELL__ > 706+foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt+#else+-- HACK: We hope very hard that !UNSETENV_RETURNS_VOID+foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt+#endif+#endif++#endif
cabal/Cabal/Distribution/Compat/Exception.hs view
@@ -1,11 +1,16 @@+{-# LANGUAGE CPP #-} module Distribution.Compat.Exception (   catchIO,   catchExit,   tryIO,+  displayException,   ) where  import System.Exit import qualified Control.Exception as Exception+#if __GLASGOW_HASKELL__ >= 710+import Control.Exception (displayException)+#endif  tryIO :: IO a -> IO (Either Exception.IOException a) tryIO = Exception.try@@ -15,3 +20,8 @@  catchExit :: IO a -> (ExitCode -> IO a) -> IO a catchExit = Exception.catch++#if __GLASGOW_HASKELL__ < 710+displayException :: Exception.Exception e => e -> String+displayException = show+#endif
+ cabal/Cabal/Distribution/Compat/GetShortPathName.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Compat.GetShortPathName+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  Windows-only+--+-- Win32 API 'GetShortPathName' function.++module Distribution.Compat.GetShortPathName ( getShortPathName )+    where++import Prelude ()+import Distribution.Compat.Prelude++#ifdef mingw32_HOST_OS++import qualified Prelude+import qualified System.Win32 as Win32+import System.Win32          (LPCTSTR, LPTSTR, DWORD)+import Foreign.Marshal.Array (allocaArray)++#ifdef x86_64_HOST_ARCH+#define WINAPI ccall+#else+#define WINAPI stdcall+#endif++foreign import WINAPI unsafe "windows.h GetShortPathNameW"+  c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD++-- | On Windows, retrieves the short path form of the specified path. On+-- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185.+--+-- From MS's GetShortPathName docs:+--+--      Passing NULL for [the second] parameter and zero for cchBuffer+--      will always return the required buffer size for a+--      specified lpszLongPath.+--+getShortPathName :: FilePath -> NoCallStackIO FilePath+getShortPathName path =+  Win32.withTString path $ \c_path -> do+    c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $+      c_GetShortPathName c_path Win32.nullPtr 0+    let arr_len = fromIntegral c_len+    allocaArray arr_len $ \c_out -> do+      void $ Win32.failIfZero "GetShortPathName #2 failed!" $+        c_GetShortPathName c_path c_out c_len+      Win32.peekTString c_out++#else++getShortPathName :: FilePath -> NoCallStackIO FilePath+getShortPathName path = return path++#endif
+ cabal/Cabal/Distribution/Compat/Graph.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Compat.Graph+-- Copyright   :  (c) Edward Z. Yang 2016+-- License     :  BSD3+--+-- Maintainer  :  cabal-dev@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- A data type representing directed graphs, backed by "Data.Graph".+-- It is strict in the node type.+--+-- This is an alternative interface to "Data.Graph".  In this interface,+-- nodes (identified by the 'IsNode' type class) are associated with a+-- key and record the keys of their neighbors.  This interface is more+-- convenient than 'Data.Graph.Graph', which requires vertices to be+-- explicitly handled by integer indexes.+--+-- The current implementation has somewhat peculiar performance+-- characteristics.  The asymptotics of all map-like operations mirror+-- their counterparts in "Data.Map".  However, to perform a graph+-- operation, we first must build the "Data.Graph" representation, an+-- operation that takes /O(V + E log V)/.  However, this operation can+-- be amortized across all queries on that particular graph.+--+-- Some nodes may be broken, i.e., refer to neighbors which are not+-- stored in the graph.  In our graph algorithms, we transparently+-- ignore such edges; however, you can easily query for the broken+-- vertices of a graph using 'broken' (and should, e.g., to ensure that+-- a closure of a graph is well-formed.)  It's possible to take a closed+-- subset of a broken graph and get a well-formed graph.+--+-----------------------------------------------------------------------------++module Distribution.Compat.Graph (+    -- * Graph type+    Graph,+    IsNode(..),+    -- * Query+    null,+    size,+    member,+    lookup,+    -- * Construction+    empty,+    insert,+    deleteKey,+    deleteLookup,+    -- * Combine+    unionLeft,+    unionRight,+    -- * Graph algorithms+    stronglyConnComp,+    SCC(..),+    cycles,+    broken,+    neighbors,+    revNeighbors,+    closure,+    revClosure,+    topSort,+    revTopSort,+    -- * Conversions+    -- ** Maps+    toMap,+    -- ** Lists+    fromList,+    toList,+    keys,+    -- ** Sets+    keysSet,+    -- ** Graphs+    toGraph,+    -- * Node type+    Node(..),+    nodeValue,+) where++import Prelude ()+import qualified Distribution.Compat.Prelude as Prelude+import Distribution.Compat.Prelude hiding (lookup, null, empty)++import Data.Graph (SCC(..))+import qualified Data.Graph as G+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Array as Array+import Data.Array ((!))+import qualified Data.Tree as Tree+import Data.Either (partitionEithers)+import qualified Data.Foldable as Foldable++-- | A graph of nodes @a@.  The nodes are expected to have instance+-- of class 'IsNode'.+data Graph a+    = Graph {+        graphMap          :: !(Map (Key a) a),+        -- Lazily cached graph representation+        graphForward      :: G.Graph,+        graphAdjoint      :: G.Graph,+        graphVertexToNode :: G.Vertex -> a,+        graphKeyToVertex  :: Key a -> Maybe G.Vertex,+        graphBroken       :: [(a, [Key a])]+    }+    deriving (Typeable)++-- NB: Not a Functor! (or Traversable), because you need+-- to restrict Key a ~ Key b.  We provide our own mapping+-- functions.++-- General strategy is most operations are deferred to the+-- Map representation.++instance Show a => Show (Graph a) where+    show = show . toList++instance (IsNode a, Read a) => Read (Graph a) where+    readsPrec d s = map (\(a,r) -> (fromList a, r)) (readsPrec d s)++instance (IsNode a, Binary a) => Binary (Graph a) where+    put x = put (toList x)+    get = fmap fromList get++instance (Eq (Key a), Eq a) => Eq (Graph a) where+    g1 == g2 = graphMap g1 == graphMap g2++instance Foldable.Foldable Graph where+    fold = Foldable.fold . graphMap+    foldr f z = Foldable.foldr f z . graphMap+    foldl f z = Foldable.foldl f z . graphMap+    foldMap f = Foldable.foldMap f . graphMap+#ifdef MIN_VERSION_base+#if MIN_VERSION_base(4,6,0)+    foldl' f z = Foldable.foldl' f z . graphMap+    foldr' f z = Foldable.foldr' f z . graphMap+#endif+#if MIN_VERSION_base(4,8,0)+    length = Foldable.length . graphMap+    null   = Foldable.null   . graphMap+    toList = Foldable.toList . graphMap+    elem x = Foldable.elem x . graphMap+    maximum = Foldable.maximum . graphMap+    minimum = Foldable.minimum . graphMap+    sum     = Foldable.sum     . graphMap+    product = Foldable.product . graphMap+#endif+#endif++instance (NFData a, NFData (Key a)) => NFData (Graph a) where+    rnf Graph {+        graphMap = m,+        graphForward = gf,+        graphAdjoint = ga,+        graphVertexToNode = vtn,+        graphKeyToVertex = ktv,+        graphBroken = b+    } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m++-- TODO: Data instance?++-- | The 'IsNode' class is used for datatypes which represent directed+-- graph nodes.  A node of type @a@ is associated with some unique key of+-- type @'Key' a@; given a node we can determine its key ('nodeKey')+-- and the keys of its neighbors ('nodeNeighbors').+class Ord (Key a) => IsNode a where+    type Key a :: *+    nodeKey :: a -> Key a+    nodeNeighbors :: a -> [Key a]++instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where+    type Key (Either a b) = Key a+    nodeKey (Left x)  = nodeKey x+    nodeKey (Right x) = nodeKey x+    nodeNeighbors (Left x)  = nodeNeighbors x+    nodeNeighbors (Right x) = nodeNeighbors x++-- | A simple, trivial data type which admits an 'IsNode' instance.+data Node k a = N a k [k]+    deriving (Show, Eq)++-- | Get the value from a 'Node'.+nodeValue :: Node k a -> a+nodeValue (N a _ _) = a++instance Functor (Node k) where+    fmap f (N a k ks) = N (f a) k ks++instance Ord k => IsNode (Node k a) where+    type Key (Node k a) = k+    nodeKey (N _ k _) = k+    nodeNeighbors (N _ _ ks) = ks++-- TODO: Maybe introduce a typeclass for items which just+-- keys (so, Key associated type, and nodeKey method).  But+-- I didn't need it here, so I didn't introduce it.++-- Query++-- | /O(1)/. Is the graph empty?+null :: Graph a -> Bool+null = Map.null . toMap++-- | /O(1)/. The number of nodes in the graph.+size :: Graph a -> Int+size = Map.size . toMap++-- | /O(log V)/. Check if the key is in the graph.+member :: IsNode a => Key a -> Graph a -> Bool+member k g = Map.member k (toMap g)++-- | /O(log V)/. Lookup the node at a key in the graph.+lookup :: IsNode a => Key a -> Graph a -> Maybe a+lookup k g = Map.lookup k (toMap g)++-- Construction++-- | /O(1)/. The empty graph.+empty :: IsNode a => Graph a+empty = fromMap Map.empty++-- | /O(log V)/. Insert a node into a graph.+insert :: IsNode a => a -> Graph a -> Graph a+insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g))++-- | /O(log V)/. Delete the node at a key from the graph.+deleteKey :: IsNode a => Key a -> Graph a -> Graph a+deleteKey k g = fromMap (Map.delete k (toMap g))++-- | /O(log V)/. Lookup and delete.  This function returns the deleted+-- value if it existed.+deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a)+deleteLookup k g =+    let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g)+    in (r, fromMap m')++-- Combining++-- | /O(V + V')/. Right-biased union, preferring entries+-- from the second map when conflicts occur.+-- @'nodeKey' x = 'nodeKey' (f x)@.+unionRight :: IsNode a => Graph a -> Graph a -> Graph a+unionRight g g' = fromMap (Map.union (toMap g') (toMap g))++-- | /O(V + V')/. Left-biased union, preferring entries from+-- the first map when conflicts occur.+unionLeft :: IsNode a => Graph a -> Graph a -> Graph a+unionLeft = flip unionRight++-- Graph-like operations++-- | /Ω(V + E)/. Compute the strongly connected components of a graph.+-- Requires amortized construction of graph.+stronglyConnComp :: Graph a -> [SCC a]+stronglyConnComp g = map decode forest+  where+    forest = G.scc (graphForward g)+    decode (Tree.Node v [])+        | mentions_itself v = CyclicSCC  [graphVertexToNode g v]+        | otherwise         = AcyclicSCC (graphVertexToNode g v)+    decode other = CyclicSCC (dec other [])+        where dec (Tree.Node v ts) vs+                = graphVertexToNode g v : foldr dec vs ts+    mentions_itself v = v `elem` (graphForward g ! v)+-- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'.++-- | /Ω(V + E)/. Compute the cycles of a graph.+-- Requires amortized construction of graph.+cycles :: Graph a -> [[a]]+cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ]++-- | /O(1)/.  Return a list of nodes paired with their broken+-- neighbors (i.e., neighbor keys which are not in the graph).+-- Requires amortized construction of graph.+broken :: Graph a -> [(a, [Key a])]+broken g = graphBroken g++-- | Lookup the immediate neighbors from a key in the graph.+-- Requires amortized construction of graph.+neighbors :: Graph a -> Key a -> Maybe [a]+neighbors g k = do+    v <- graphKeyToVertex g k+    return (map (graphVertexToNode g) (graphForward g ! v))++-- | Lookup the immediate reverse neighbors from a key in the graph.+-- Requires amortized construction of graph.+revNeighbors :: Graph a -> Key a -> Maybe [a]+revNeighbors g k = do+    v <- graphKeyToVertex g k+    return (map (graphVertexToNode g) (graphAdjoint g ! v))++-- | Compute the subgraph which is the closure of some set of keys.+-- Returns @Nothing@ if one (or more) keys are not present in+-- the graph.+-- Requires amortized construction of graph.+closure :: Graph a -> [Key a] -> Maybe [a]+closure g ks = do+    vs <- traverse (graphKeyToVertex g) ks+    return (decodeVertexForest g (G.dfs (graphForward g) vs))++-- | Compute the reverse closure of a graph from some set+-- of keys.  Returns @Nothing@ if one (or more) keys are not present in+-- the graph.+-- Requires amortized construction of graph.+revClosure :: Graph a -> [Key a] -> Maybe [a]+revClosure g ks = do+    vs <- traverse (graphKeyToVertex g) ks+    return (decodeVertexForest g (G.dfs (graphAdjoint g) vs))++flattenForest :: Tree.Forest a -> [a]+flattenForest = concatMap Tree.flatten++decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a]+decodeVertexForest g = map (graphVertexToNode g) . flattenForest++-- | Topologically sort the nodes of a graph.+-- Requires amortized construction of graph.+topSort :: Graph a -> [a]+topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g)++-- | Reverse topologically sort the nodes of a graph.+-- Requires amortized construction of graph.+revTopSort :: Graph a -> [a]+revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g)++-- Conversions++-- | /O(1)/. Convert a map from keys to nodes into a graph.+-- The map must satisfy the invariant that+-- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@;+-- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@+-- instead.  The values of the map are assumed to already+-- be in WHNF.+fromMap :: IsNode a => Map (Key a) a -> Graph a+fromMap m+    = Graph { graphMap = m+            -- These are lazily computed!+            , graphForward = g+            , graphAdjoint = G.transposeG g+            , graphVertexToNode = vertex_to_node+            , graphKeyToVertex = key_to_vertex+            , graphBroken = broke+            }+  where+    try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)++    (brokenEdges, edges)+        = unzip+        $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))+          | n <- ns ]+    broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)++    g = Array.listArray bounds edges++    ns              = Map.elems m -- sorted ascending+    vertices        = zip (map nodeKey ns) [0..]+    vertex_map      = Map.fromAscList vertices+    key_to_vertex k = Map.lookup k vertex_map++    vertex_to_node vertex = nodeTable ! vertex++    nodeTable   = Array.listArray bounds ns+    bounds = (0, Map.size m - 1)++-- | /O(V log V)/. Convert a list of nodes into a graph.+fromList :: IsNode a => [a] -> Graph a+fromList ns = fromMap+            . Map.fromList+            . map (\n -> n `seq` (nodeKey n, n))+            $ ns++-- Map-like operations++-- | /O(V)/. Convert a graph into a list of nodes.+toList :: Graph a -> [a]+toList g = Map.elems (toMap g)++-- | /O(V)/. Convert a graph into a list of keys.+keys :: Graph a -> [Key a]+keys g = Map.keys (toMap g)++-- | /O(V)/. Convert a graph into a set of keys.+keysSet :: Graph a -> Set.Set (Key a)+keysSet g = Map.keysSet (toMap g)++-- | /O(1)/. Convert a graph into a map from keys to nodes.+-- The resulting map @m@ is guaranteed to have the property that+-- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@.+toMap :: Graph a -> Map (Key a) a+toMap = graphMap++-- Graph-like operations++-- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'.+-- Requires amortized construction of graph.+toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex)+toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g)
cabal/Cabal/Distribution/Compat/MonadFail.hs view
@@ -9,7 +9,7 @@ -- the following code corresponds to -- http://hackage.haskell.org/package/fail-4.9.0.0 import qualified Prelude as P-import Prelude hiding (fail)+import Distribution.Compat.Prelude hiding (fail)  import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadPrec@@ -25,7 +25,7 @@ instance MonadFail [] where     fail _ = [] -instance MonadFail IO where+instance MonadFail P.IO where     fail = P.fail  instance MonadFail ReadPrec where
+ cabal/Cabal/Distribution/Compat/Parsec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}+module Distribution.Compat.Parsec (+    P.Parsec,+    P.ParsecT,+    P.Stream,+    (P.<?>),++    P.runParser,++    -- * Combinators+    P.between,+    P.option,+    P.optional,+    P.optionMaybe,+    P.try,+    P.sepBy,+    P.sepBy1,+    P.choice,++    -- * Char+    integral,+    P.char,+    P.anyChar,+    P.satisfy,+    P.space,+    P.spaces,+    P.string,+    munch,+    munch1,+    P.oneOf,+    ) where++import           Distribution.Compat.Prelude+import           Prelude ()++import qualified Text.Parsec                 as P+import qualified Text.Parsec.Pos             as P++integral :: (P.Stream s m Char, Integral a) => P.ParsecT s u m a+integral = toNumber <$> some d P.<?> "integral"+  where+    toNumber = foldl' (\a b -> a * 10 + b) 0+    d = P.tokenPrim+          (\c -> show [c])+          (\pos c _cs -> P.updatePosChar pos c)+          f+    f '0' = Just 0+    f '1' = Just 1+    f '2' = Just 2+    f '3' = Just 3+    f '4' = Just 4+    f '5' = Just 5+    f '6' = Just 6+    f '7' = Just 7+    f '8' = Just 8+    f '9' = Just 9+    f _   = Nothing++-- | Greedily munch characters while predicate holds.+-- Require at least one character.+munch1+    :: P.Stream s m Char+    => (Char -> Bool)+    -> P.ParsecT s u m String+munch1 = some . P.satisfy++-- | Greedely munch characters while predicate holds.+-- Always succeeds.+munch+    :: P.Stream s m Char+    => (Char -> Bool)+    -> P.ParsecT s u m String+munch = many . P.satisfy
+ cabal/Cabal/Distribution/Compat/Prelude.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}++#ifdef MIN_VERSION_base+#define MINVER_base_48 MIN_VERSION_base(4,8,0)+#define MINVER_base_47 MIN_VERSION_base(4,7,0)+#define MINVER_base_46 MIN_VERSION_base(4,6,0)+#else+#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710)+#define MINVER_base_47 (__GLASGOW_HASKELL__ >= 708)+#define MINVER_base_46 (__GLASGOW_HASKELL__ >= 706)+#endif++-- | This module does two things:+--+-- * Acts as a compatiblity layer, like @base-compat@.+--+-- * Provides commonly used imports.+module Distribution.Compat.Prelude (+    -- * Prelude+    --+    -- Prelude is re-exported, following is hidden:+    module BasePrelude,++#if !MINVER_base_48+    -- * base 4.8 shim+    Applicative(..), (<$), (<$>),+    Monoid(..),+#endif++    -- * Common type-classes+    Semigroup (..),+    gmappend, gmempty,+    Typeable,+    Data,+    Generic,+    NFData (..), genericRnf,+    Binary (..),+    Alternative (..),+    MonadPlus (..),++    -- * Some types+    IO, NoCallStackIO,+    Map,++    -- * Data.Maybe+    catMaybes, mapMaybe,+    fromMaybe,+    maybeToList, listToMaybe,+    isNothing, isJust,++    -- * Data.List+    unfoldr,+    isPrefixOf, isSuffixOf,+    intercalate, intersperse,+    sort, sortBy,+    nub, nubBy,++    -- * Data.Foldable+    Foldable, foldMap, foldr,+    null, length,+    find, foldl',+    traverse_, for_,++    -- * Data.Traversable+    Traversable, traverse, sequenceA,+    for,++    -- * Control.Arrow+    first,++    -- * Control.Monad+    liftM, liftM2,+    unless, when,+    ap, void,+    foldM, filterM,++    -- * Data.Char+    isSpace, isDigit, isUpper, isAlpha, isAlphaNum,+    chr, ord,+    toLower, toUpper,++    -- * Data.Word & Data.Int+    Word,+    Word8, Word16, Word32, Word64,+    Int8, Int16, Int32, Int64,++    -- * Text.PrettyPrint+    (<<>>),+    ) where++-- We also could hide few partial function+import Prelude                       as BasePrelude hiding+  ( IO, mapM, mapM_, sequence, null, length, foldr+#if MINVER_base_48+  , Word+  -- We hide them, as we import only some members+  , Traversable, traverse, sequenceA+  , Foldable, foldMap+#endif+  )++#if !MINVER_base_48+import Control.Applicative           (Applicative (..), (<$), (<$>))+import Distribution.Compat.Semigroup (Monoid (..))+#else+import Data.Foldable                 (length, null)+#endif++import Data.Foldable                 (Foldable (foldMap, foldr), find, foldl', for_, traverse_)+import Data.Traversable              (Traversable (traverse, sequenceA), for)++import Control.Applicative           (Alternative (..))+import Control.DeepSeq               (NFData (..))+import Data.Data                     (Data)+import Data.Typeable                 (Typeable)+import Distribution.Compat.Binary    (Binary (..))+import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty)+import GHC.Generics                  (Generic, Rep(..),+                                      V1, U1(U1), K1(unK1), M1(unM1),+                                      (:*:)((:*:)), (:+:)(L1,R1))++import Data.Map                      (Map)++import Control.Arrow                 (first)+import Control.Monad                 hiding (mapM)+import Data.Char+import Data.List                     (intercalate, intersperse, isPrefixOf,+                                      isSuffixOf, nub, nubBy, sort, sortBy,+                                      unfoldr)+import Data.Maybe+import Data.Int+import Data.Word++import qualified Text.PrettyPrint as Disp++import qualified Prelude as OrigPrelude+import Distribution.Compat.Stack++type IO a = WithCallStack (OrigPrelude.IO a)+type NoCallStackIO a = OrigPrelude.IO a++-- | New name for 'Text.PrettyPrint.<>'+(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc+(<<>>) = (Disp.<>)++#if !MINVER_base_48+-- | Test whether the structure is empty. The default implementation is+-- optimized for structures that are similar to cons-lists, because there+-- is no general way to do better.+null :: Foldable t => t a -> Bool+null = foldr (\_ _ -> False) True++-- | Returns the size/length of a finite structure as an 'Int'.  The+-- default implementation is optimized for structures that are similar to+-- cons-lists, because there is no general way to do better.+length :: Foldable t => t a -> Int+length = foldl' (\c _ -> c+1) 0+#endif+++-- | "GHC.Generics"-based 'rnf' implementation+--+-- This is needed in order to support @deepseq < 1.4@ which didn't+-- have a 'Generic'-based default 'rnf' implementation yet.+--+-- In order to define instances, use e.g.+--+-- > instance NFData MyType where rnf = genericRnf+--+-- The implementation has been taken from @deepseq-1.4.2@'s default+-- 'rnf' implementation.+genericRnf :: (Generic a, GNFData (Rep a)) => a -> ()+genericRnf = grnf . from++-- | Hidden internal type-class+class GNFData f where+  grnf :: f a -> ()++instance GNFData V1 where+  grnf = error "Control.DeepSeq.rnf: uninhabited type"++instance GNFData U1 where+  grnf U1 = ()++instance NFData a => GNFData (K1 i a) where+  grnf = rnf . unK1+  {-# INLINEABLE grnf #-}++instance GNFData a => GNFData (M1 i c a) where+  grnf = grnf . unM1+  {-# INLINEABLE grnf #-}++instance (GNFData a, GNFData b) => GNFData (a :*: b) where+  grnf (x :*: y) = grnf x `seq` grnf y+  {-# INLINEABLE grnf #-}++instance (GNFData a, GNFData b) => GNFData (a :+: b) where+  grnf (L1 x) = grnf x+  grnf (R1 x) = grnf x+  {-# INLINEABLE grnf #-}
+ cabal/Cabal/Distribution/Compat/Prelude/Internal.hs view
@@ -0,0 +1,14 @@+-- | This module re-exports the non-exposed+-- "Distribution.Compat.Prelude" module for+-- reuse by @cabal-install@'s+-- "Distribution.Client.Compat.Prelude" module.+--+-- It is highly discouraged to rely on this module+-- for @Setup.hs@ scripts since its API is /not/+-- stable.+module Distribution.Compat.Prelude.Internal+    {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}+    ( module Distribution.Compat.Prelude+    ) where++import Distribution.Compat.Prelude
cabal/Cabal/Distribution/Compat/ReadP.hs view
@@ -37,6 +37,7 @@    -- * Other operations   pfail,      -- :: ReadP a+  eof,        -- :: ReadP ()   satisfy,    -- :: (Char -> Bool) -> ReadP Char   char,       -- :: Char -> ReadP Char   string,     -- :: String -> ReadP String@@ -69,11 +70,12 @@   )  where +import Prelude ()+import Distribution.Compat.Prelude hiding (many, get)+ import qualified Distribution.Compat.MonadFail as Fail -import Control.Monad( MonadPlus(..), liftM, liftM2, replicateM, ap, (>=>) )-import Data.Char (isSpace)-import Control.Applicative as AP (Applicative(..), Alternative(empty, (<|>)))+import Control.Monad( replicateM, (>=>) )  infixr 5 +++, <++ @@ -98,7 +100,7 @@   (<*>) = ap  instance Monad (P s) where-  return = AP.pure+  return = pure    (Get f)      >>= k = Get (f >=> k)   (Look f)     >>= k = Look (f >=> k)@@ -160,7 +162,7 @@   (<*>) = ap  instance Monad (Parser r s) where-  return = AP.pure+  return = pure   fail = Fail.fail   R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) @@ -202,6 +204,12 @@ pfail :: ReadP r a -- ^ Always fails. pfail = R (const Fail)++eof :: ReadP r ()+-- ^ Succeeds iff we are at the end of input+eof = do { s <- look+         ; if null s then return ()+                     else pfail }  (+++) :: ReadP r a -> ReadP r a -> ReadP r a -- ^ Symmetric choice.
+ cabal/Cabal/Distribution/Compat/SnocList.hs view
@@ -0,0 +1,33 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Compat.SnocList+-- License     :  BSD3+--+-- Maintainer  :  cabal-dev@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- A very reversed list. Has efficient `snoc`+module Distribution.Compat.SnocList (+    SnocList,+    runSnocList,+    snoc,+) where++import Prelude ()+import Distribution.Compat.Prelude++newtype SnocList a = SnocList [a]++snoc :: SnocList a -> a -> SnocList a+snoc (SnocList xs) x = SnocList (x : xs)++runSnocList :: SnocList a -> [a]+runSnocList (SnocList xs) = reverse xs++instance Semigroup (SnocList a) where+    SnocList xs <> SnocList ys = SnocList (ys <> xs)++instance Monoid (SnocList a) where+    mempty = SnocList []+    mappend = (<>)
+ cabal/Cabal/Distribution/Compat/Stack.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ImplicitParams #-}+module Distribution.Compat.Stack (+    WithCallStack,+    CallStack,+    withFrozenCallStack,+    withLexicalCallStack,+    callStack,+    prettyCallStack,+    parentSrcLocPrefix+) where++#ifdef MIN_VERSION_base+#if MIN_VERSION_base(4,8,1)+#define GHC_STACK_SUPPORTED 1+#endif+#endif++#ifdef GHC_STACK_SUPPORTED+import GHC.Stack+#endif++#ifdef GHC_STACK_SUPPORTED++#if MIN_VERSION_base(4,9,0)+type WithCallStack a = HasCallStack => a+#elif MIN_VERSION_base(4,8,1)+type WithCallStack a = (?callStack :: CallStack) => a+#endif++#if !MIN_VERSION_base(4,9,0)+-- NB: Can't say WithCallStack (WithCallStack a -> a);+-- Haskell doesn't support this kind of implicit parameter!+-- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html+-- Since this function doesn't do anything, it's OK to+-- give it a less good type.+withFrozenCallStack :: WithCallStack (a -> a)+withFrozenCallStack x = x++callStack :: (?callStack :: CallStack) => CallStack+callStack = ?callStack++prettyCallStack :: CallStack -> String+prettyCallStack = showCallStack+#endif++-- | Give the *parent* of the person who invoked this;+-- so it's most suitable for being called from a utility function.+-- You probably want to call this using 'withFrozenCallStack'; otherwise+-- it's not very useful.  We didn't implement this for base-4.8.1+-- because we cannot rely on freezing to have taken place.+--+parentSrcLocPrefix :: WithCallStack String+#if MIN_VERSION_base(4,9,0)+parentSrcLocPrefix =+  case getCallStack callStack of+    (_:(_, loc):_) -> showLoc loc+    [(_, loc)] -> showLoc loc+    [] -> error "parentSrcLocPrefix: empty call stack"+ where+  showLoc loc =+    srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": "+#else+parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "+#endif++-- Yeah, this uses skivvy implementation details.+withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)+withLexicalCallStack f =+    let stk = ?callStack+    in \x -> let ?callStack = stk in f x++#else++data CallStack = CallStack+    deriving (Eq, Show)++type WithCallStack a = a++withFrozenCallStack :: a -> a+withFrozenCallStack x = x++callStack :: CallStack+callStack = CallStack++prettyCallStack :: CallStack -> String+prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)"++parentSrcLocPrefix :: String+parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "++withLexicalCallStack :: (a -> IO b) -> a -> IO b+withLexicalCallStack f = f++#endif
+ cabal/Cabal/Distribution/Compat/Time.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Distribution.Compat.Time+       ( ModTime(..) -- Needed for testing+       , getModTime, getFileAge, getCurTime+       , posixSecondsToModTime+       , calibrateMtimeChangeDelay )+       where++import Prelude ()+import Distribution.Compat.Prelude++import System.Directory ( getModificationTime )++import Distribution.Simple.Utils ( withTempDirectory )+import Distribution.Verbosity ( silent )++import System.FilePath++import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )+import Data.Time             ( diffUTCTime, getCurrentTime )+#if MIN_VERSION_directory(1,2,0)+import Data.Time.Clock.POSIX ( posixDayLength )+#else+import System.Time ( getClockTime, diffClockTimes+                   , normalizeTimeDiff, tdDay, tdHour )+#endif++#if defined mingw32_HOST_OS++import qualified Prelude+import Data.Bits          ((.|.), unsafeShiftL)+#if MIN_VERSION_base(4,7,0)+import Data.Bits          (finiteBitSize)+#else+import Data.Bits          (bitSize)+#endif++import Foreign            ( allocaBytes, peekByteOff )+import System.IO.Error    ( mkIOError, doesNotExistErrorType )+import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )++#else++import System.Posix.Files ( FileStatus, getFileStatus )++#if MIN_VERSION_unix(2,6,0)+import System.Posix.Files ( modificationTimeHiRes )+#else+import System.Posix.Files ( modificationTime )+#endif++#endif++-- | An opaque type representing a file's modification time, represented+-- internally as a 64-bit unsigned integer in the Windows UTC format.+newtype ModTime = ModTime Word64+                deriving (Binary, Bounded, Eq, Ord)++instance Show ModTime where+  show (ModTime x) = show x++instance Read ModTime where+  readsPrec p str = map (first ModTime) (readsPrec p str)++-- | Return modification time of the given file. Works around the low clock+-- resolution problem that 'getModificationTime' has on GHC < 7.8.+--+-- This is a modified version of the code originally written for Shake by Neil+-- Mitchell. See module Development.Shake.FileInfo.+getModTime :: FilePath -> NoCallStackIO ModTime++#if defined mingw32_HOST_OS++-- Directly against the Win32 API.+getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do+  res <- getFileAttributesEx path info+  if not res+    then do+      let err = mkIOError doesNotExistErrorType+                "Distribution.Compat.Time.getModTime"+                Nothing (Just path)+      ioError err+    else do+      dwLow  <- peekByteOff info+                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+      dwHigh <- peekByteOff info+                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime+#if MIN_VERSION_base(4,7,0)+      let qwTime =+            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)+            .|. (fromIntegral (dwLow :: DWORD))+#else+      let qwTime =+            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)+            .|. (fromIntegral (dwLow :: DWORD))+#endif+      return $! ModTime (qwTime :: Word64)++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV "windows.h GetFileAttributesExW"+  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL++getFileAttributesEx :: String -> LPVOID -> NoCallStackIO BOOL+getFileAttributesEx path lpFileInformation =+  withTString path $ \c_path ->+      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation++getFileExInfoStandard :: Int32+getFileExInfoStandard = 0++size_WIN32_FILE_ATTRIBUTE_DATA :: Int+size_WIN32_FILE_ATTRIBUTE_DATA = 36++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24++#else++-- Directly against the unix library.+getModTime path = do+    st <- getFileStatus path+    return $! (extractFileTime st)++extractFileTime :: FileStatus -> ModTime+#if MIN_VERSION_unix(2,6,0)+extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)+#else+extractFileTime x = posixSecondsToModTime $ fromIntegral $ fromEnum $+                    modificationTime x+#endif++#endif++windowsTick, secToUnixEpoch :: Word64+windowsTick    = 10000000+secToUnixEpoch = 11644473600++-- | Convert POSIX seconds to ModTime.+posixSecondsToModTime :: Int64 -> ModTime+posixSecondsToModTime s =+  ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick++-- | Convert 'POSIXTime' to 'ModTime'.+posixTimeToModTime :: POSIXTime -> ModTime+posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision+                       + (secToUnixEpoch * windowsTick)++-- | Return age of given file in days.+getFileAge :: FilePath -> NoCallStackIO Double+getFileAge file = do+  t0 <- getModificationTime file+#if MIN_VERSION_directory(1,2,0)+  t1 <- getCurrentTime+  return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength+#else+  t1 <- getClockTime+  let dt = normalizeTimeDiff (t1 `diffClockTimes` t0)+  return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0+#endif++-- | Return the current time as 'ModTime'.+getCurTime :: NoCallStackIO ModTime+getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.++-- | Based on code written by Neil Mitchell for Shake. See+-- 'sleepFileTimeCalibrate' in 'Test.Type'.  Returns a pair+-- of microsecond values: first, the maximum delay seen, and the+-- recommended delay to use before testing for file modification change.+-- The returned delay is never smaller+-- than 10 ms, but never larger than 1 second.+calibrateMtimeChangeDelay :: IO (Int, Int)+calibrateMtimeChangeDelay =+  withTempDirectory silent "." "calibration-" $ \dir -> do+    let fileName = dir </> "probe"+    mtimes <- for [1..25] $ \(i::Int) -> time $ do+      writeFile fileName $ show i+      t0 <- getModTime fileName+      let spin j = do+            writeFile fileName $ show (i,j)+            t1 <- getModTime fileName+            unless (t0 < t1) (spin $ j + 1)+      spin (0::Int)+    let mtimeChange  = maximum mtimes+        mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2+    return (mtimeChange, mtimeChange')+  where+    time :: IO () -> IO Int+    time act = do+      t0 <- getCurrentTime+      act+      t1 <- getCurrentTime+      return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
cabal/Cabal/Distribution/Compiler.hs view
@@ -15,8 +15,8 @@ -- case analysis on this compiler flavour enumeration like: -- -- > case compilerFlavor comp of--- >   GHC -> GHC.getInstalledPackages verbosity packageDb progconf--- >   JHC -> JHC.getInstalledPackages verbosity packageDb progconf+-- >   GHC -> GHC.getInstalledPackages verbosity packageDb progdb+-- >   JHC -> JHC.getInstalledPackages verbosity packageDb progdb -- -- Obviously it would be better to use the proper 'Compiler' abstraction -- because that would keep all the compiler-specific code together.@@ -32,6 +32,7 @@   buildCompilerFlavor,   defaultCompilerFlavor,   parseCompilerFlavorCompat,+  classifyCompilerFlavor,    -- * Compiler id   CompilerId(..),@@ -42,27 +43,22 @@   AbiTag(..), abiTagString   ) where -import Distribution.Compat.Binary+import Prelude ()+import Distribution.Compat.Prelude+ import Language.Haskell.Extension -import Data.Data (Data)-import Data.Typeable (Typeable)-import Data.Maybe (fromMaybe)-import Distribution.Version (Version(..))-import GHC.Generics (Generic)+import Distribution.Version (Version, mkVersion', nullVersion)  import qualified System.Info (compilerName, compilerVersion) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>)) -import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)-import Control.Monad (when)--data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC-                    | HaskellSuite String -- string is the id of the actual compiler-                    | OtherCompiler String+data CompilerFlavor =+  GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC+  | HaskellSuite String -- string is the id of the actual compiler+  | OtherCompiler String   deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)  instance Binary CompilerFlavor@@ -77,8 +73,8 @@   disp other                = Disp.text (lowercase (show other))    parse = do-    comp <- Parse.munch1 Char.isAlphaNum-    when (all Char.isDigit comp) Parse.pfail+    comp <- Parse.munch1 isAlphaNum+    when (all isDigit comp) Parse.pfail     return (classifyCompilerFlavor comp)  classifyCompilerFlavor :: String -> CompilerFlavor@@ -103,8 +99,8 @@ -- parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor parseCompilerFlavorCompat = do-  comp <- Parse.munch1 Char.isAlphaNum-  when (all Char.isDigit comp) Parse.pfail+  comp <- Parse.munch1 isAlphaNum+  when (all isDigit comp) Parse.pfail   case lookup comp compilerMap of     Just compiler -> return compiler     Nothing       -> return (OtherCompiler comp)@@ -117,7 +113,7 @@ buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName  buildCompilerVersion :: Version-buildCompilerVersion = System.Info.compilerVersion+buildCompilerVersion = mkVersion' System.Info.compilerVersion  buildCompilerId :: CompilerId buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion@@ -143,31 +139,35 @@ instance Binary CompilerId  instance Text CompilerId where-  disp (CompilerId f (Version [] _)) = disp f-  disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v+  disp (CompilerId f v)+    | v == nullVersion = disp f+    | otherwise        = disp f <<>> Disp.char '-' <<>> disp v    parse = do     flavour <- parse-    version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] [])+    version <- (Parse.char '-' >> parse) Parse.<++ return nullVersion     return (CompilerId flavour version)  lowercase :: String -> String-lowercase = map Char.toLower+lowercase = map toLower  -- ------------------------------------------------------------ -- * Compiler Info -- ------------------------------------------------------------ --- | Compiler information used for resolving configurations. Some fields can be---   set to Nothing to indicate that the information is unknown.+-- | Compiler information used for resolving configurations. Some+--   fields can be set to Nothing to indicate that the information is+--   unknown.  data CompilerInfo = CompilerInfo {          compilerInfoId         :: CompilerId,          -- ^ Compiler flavour and version.          compilerInfoAbiTag     :: AbiTag,-         -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os.+         -- ^ Tag for distinguishing incompatible ABI's on the same+         -- architecture/os.          compilerInfoCompat     :: Maybe [CompilerId],-         -- ^ Other implementations that this compiler claims to be compatible with, if known.+         -- ^ Other implementations that this compiler claims to be+         -- compatible with, if known.          compilerInfoLanguages  :: Maybe [Language],          -- ^ Supported language standards, if known.          compilerInfoExtensions :: Maybe [Extension]@@ -189,7 +189,7 @@   disp (AbiTag tag) = Disp.text tag    parse = do-    tag <- Parse.munch (\c -> Char.isAlphaNum c || c == '_')+    tag <- Parse.munch (\c -> isAlphaNum c || c == '_')     if null tag then return NoAbiTag else return (AbiTag tag)  abiTagString :: AbiTag -> String
cabal/Cabal/Distribution/GetOpt.hs view
@@ -7,36 +7,19 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- This library provides facilities for parsing the command-line options--- in a standalone program.  It is essentially a Haskell port of the GNU--- @getopt@ library.+-- This is a fork of "System.Console.GetOpt" with the following changes: ----------------------------------------------------------------------------------{--Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small-changes Dec. 1997)--Two rather obscure features are missing: The Bash 2.0 non-option hack-(if you don't already know it, you probably don't want to hear about-it...) and the recognition of long options with a single dash-(e.g. '-help' is recognised as '--help', as long as there is no short-option 'h').--Other differences between GNU's getopt and this implementation:--* To enforce a coherent description of options and arguments, there-  are explanation fields in the option/argument descriptor.--* Error messages are now more informative, but no longer POSIX-  compliant... :-(--And a final Haskell advertisement: The GNU C implementation uses well-over 1100 lines, we need only 195 here, including a 46 line example!-:-)--}--{-# OPTIONS_HADDOCK hide #-}+-- * Treat "cabal --flag command" as "cabal command --flag" e.g.+--   "cabal -v configure" to mean "cabal configure -v" For flags that are+--   not recognised as global flags, pass them on to the sub-command. See+--   the difference in 'shortOpt'.+--+-- * Line wrapping in the 'usageInfo' output, plus a more compact+--   rendering of short options, and slightly less padding.+--+-- If you want to take on the challenge of merging this with the GetOpt+-- from the base package then go for it!+-- module Distribution.GetOpt (    -- * GetOpt    getOpt, getOpt',@@ -46,44 +29,13 @@    ArgDescr(..),     -- * Example--   -- $example+   -- | See "System.Console.GetOpt" for examples ) where -import Data.List ( isPrefixOf, intercalate, find )-import Data.Maybe ( isJust )---- |What to do with options following non-options-data ArgOrder a-  = RequireOrder                -- ^ no option processing after first non-option-  | Permute                     -- ^ freely intersperse options and non-options-  | ReturnInOrder (String -> a) -- ^ wrap non-options into options--{-|-Each 'OptDescr' describes a single option.--The arguments to 'Option' are:--* list of short option characters--* list of long option strings (without \"--\")--* argument descriptor--* explanation of option for user--}-data OptDescr a =              -- description of a single options:-   Option [Char]                --    list of short option characters-          [String]              --    list of long option strings (without "--")-          (ArgDescr a)          --    argument descriptor-          String                --    explanation of option for user---- |Describes whether an option takes an argument or not, and if so--- how the argument is injected into a value of type @a@.-data ArgDescr a-   = NoArg                   a         -- ^   no argument expected-   | ReqArg (String       -> a) String -- ^   option requires argument-   | OptArg (Maybe String -> a) String -- ^   optional argument+import Prelude ()+import Distribution.Compat.Prelude+import System.Console.GetOpt+         ( ArgOrder(..), OptDescr(..), ArgDescr(..) )  data OptKind a                -- kind of cmd line arg (internal use only):    = Opt       a                --    an option@@ -123,6 +75,7 @@ fmtShort (NoArg  _   ) so = "-" ++ [so] fmtShort (ReqArg _  _) so = "-" ++ [so] fmtShort (OptArg _  _) so = "-" ++ [so]+  -- unlike upstream GetOpt we omit the arg name for short options  fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg  _   ) lo = "--" ++ lo@@ -234,6 +187,11 @@         short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)         short []             [] rest     = (UnreqOpt optStr,rest)         short []             xs rest     = (UnreqOpt (optStr++xs),rest)+        -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)+        -- Apparently this was part of the change so that flags that are+        -- not recognised as global flags are passed on to the sub-command.+        -- But why was no equivalent change required for longOpt? So could+        -- this change go upstream?  -- miscellaneous error formatting @@ -249,87 +207,3 @@  errNoArg :: String -> OptKind a errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")--{---------------------------------------------------------------------------------------------- and here a small and hopefully enlightening example:--data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show--options :: [OptDescr Flag]-options =-   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",-    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",-    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",-    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]--out :: Maybe String -> Flag-out Nothing  = Output "stdout"-out (Just o) = Output o--test :: ArgOrder Flag -> [String] -> String-test order cmdline = case getOpt order options cmdline of-                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"-                        (_,_,errs) -> concat errs ++ usageInfo header options-   where header = "Usage: foobar [OPTION...] files..."---- example runs:--- putStr (test RequireOrder ["foo","-v"])---    ==> options=[]  args=["foo", "-v"]--- putStr (test Permute ["foo","-v"])---    ==> options=[Verbose]  args=["foo"]--- putStr (test (ReturnInOrder Arg) ["foo","-v"])---    ==> options=[Arg "foo", Verbose]  args=[]--- putStr (test Permute ["foo","--","-v"])---    ==> options=[]  args=["foo", "-v"]--- putStr (test Permute ["-?o","--name","bar","--na=baz"])---    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]--- putStr (test Permute ["--ver","foo"])---    ==> option `--ver' is ambiguous; could be one of:---          -v      --verbose             verbosely list files---          -V, -?  --version, --release  show version info---        Usage: foobar [OPTION...] files...---          -v        --verbose             verbosely list files---          -V, -?    --version, --release  show version info---          -o[FILE]  --output[=FILE]       use FILE for dump---          -n USER   --name=USER           only dump USER's files--------------------------------------------------------------------------------------------}--{- $example--To hopefully illuminate the role of the different data-structures, here\'s the command-line options for a (very simple)-compiler:-->    module Opts where->->    import Distribution.GetOpt->    import Data.Maybe ( fromMaybe )->->    data Flag->     = Verbose  | Version->     | Input String | Output String | LibDir String->       deriving Show->->    options :: [OptDescr Flag]->    options =->     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"->     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"->     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"->     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"->     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"->     ]->->    inp,outp :: Maybe String -> Flag->    outp = Output . fromMaybe "stdout"->    inp  = Input  . fromMaybe "stdin"->->    compilerOpts :: [String] -> IO ([Flag], [String])->    compilerOpts argv =->       case getOpt Permute options argv of->          (o,n,[]  ) -> return (o,n)->          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))->      where header = "Usage: ic [OPTION...] files..."---}
cabal/Cabal/Distribution/InstalledPackageInfo.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- -- |@@ -28,8 +30,10 @@  module Distribution.InstalledPackageInfo (         InstalledPackageInfo(..),-        installedComponentId,         installedPackageId,+        installedComponentId,+        requiredSignatures,+        installedOpenUnitId,         ExposedModule(..),         ParseResult(..), PError(..), PWarning,         emptyInstalledPackageInfo,@@ -40,19 +44,25 @@         fieldsInstalledPackageInfo,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.ParseUtils import Distribution.License import Distribution.Package hiding (installedUnitId, installedPackageId)+import Distribution.Package.TextClass ()+import Distribution.Backpack import qualified Distribution.Package as Package import Distribution.ModuleName import Distribution.Version import Distribution.Text import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.Binary+import Distribution.Compat.Graph  import Text.PrettyPrint as Disp-import Data.Maybe   (fromMaybe)-import GHC.Generics (Generic)+import qualified Data.Char as Char+import qualified Data.Map as Map+import Data.Set (Set)  -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type@@ -64,6 +74,12 @@         -- these parts are exactly the same as PackageDescription         sourcePackageId   :: PackageId,         installedUnitId   :: UnitId,+        installedComponentId_ :: ComponentId,+        -- INVARIANT: if this package is definite, OpenModule's+        -- OpenUnitId directly records UnitId.  If it is+        -- indefinite, OpenModule is always an OpenModuleVar+        -- with the same ModuleName as the key.+        instantiatedWith  :: [(ModuleName, OpenModule)],         compatPackageKey  :: String,         license           :: License,         copyright         :: String,@@ -77,18 +93,24 @@         category          :: String,         -- these parts are required by an installed package only:         abiHash           :: AbiHash,+        indefinite        :: Bool,         exposed           :: Bool,+        -- INVARIANT: if the package is definite, OpenModule's+        -- OpenUnitId directly records UnitId.         exposedModules    :: [ExposedModule],         hiddenModules     :: [ModuleName],         trusted           :: Bool,         importDirs        :: [FilePath],         libraryDirs       :: [FilePath],+        libraryDynDirs    :: [FilePath],  -- ^ overrides 'libraryDirs'         dataDir           :: FilePath,         hsLibraries       :: [String],         extraLibraries    :: [String],         extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi         includeDirs       :: [FilePath],         includes          :: [String],+        -- INVARIANT: if the package is definite, UnitId is NOT+        -- a ComponentId of an indefinite package         depends           :: [UnitId],         ccOptions         :: [String],         ldOptions         :: [String],@@ -98,14 +120,33 @@         haddockHTMLs      :: [FilePath],         pkgRoot           :: Maybe FilePath     }-    deriving (Eq, Generic, Read, Show)+    deriving (Eq, Generic, Typeable, Read, Show)  installedComponentId :: InstalledPackageInfo -> ComponentId-installedComponentId ipi = case installedUnitId ipi of-                            SimpleUnitId cid -> cid+installedComponentId ipi =+    case unComponentId (installedComponentId_ ipi) of+        "" -> mkComponentId (unUnitId (installedUnitId ipi))+        _  -> installedComponentId_ ipi +-- | Get the indefinite unit identity representing this package.+-- This IS NOT guaranteed to give you a substitution; for+-- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@.+-- For indefinite libraries, however, you will correctly get+-- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'.+installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId+installedOpenUnitId ipi+    = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi))++-- | Returns the set of module names which need to be filled for+-- an indefinite package, or the empty set if the package is definite.+requiredSignatures :: InstalledPackageInfo -> Set ModuleName+requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi))+ {-# DEPRECATED installedPackageId "Use installedUnitId instead" #-} -- | Backwards compatibility with Cabal pre-1.24.+-- This type synonym is slightly awful because in cabal-install+-- we define an 'InstalledPackageId' but it's a ComponentId,+-- not a UnitId! installedPackageId :: InstalledPackageInfo -> UnitId installedPackageId = installedUnitId @@ -120,11 +161,18 @@ instance Package.PackageInstalled InstalledPackageInfo where    installedDepends = depends +instance IsNode InstalledPackageInfo where+    type Key InstalledPackageInfo = UnitId+    nodeKey       = installedUnitId+    nodeNeighbors = depends+ emptyInstalledPackageInfo :: InstalledPackageInfo emptyInstalledPackageInfo    = InstalledPackageInfo {-        sourcePackageId   = PackageIdentifier (PackageName "") (Version [] []),+        sourcePackageId   = PackageIdentifier (mkPackageName "") nullVersion,         installedUnitId   = mkUnitId "",+        installedComponentId_ = mkComponentId "",+        instantiatedWith  = [],         compatPackageKey  = "",         license           = UnspecifiedLicense,         copyright         = "",@@ -136,13 +184,15 @@         synopsis          = "",         description       = "",         category          = "",-        abiHash           = AbiHash "",+        abiHash           = mkAbiHash "",+        indefinite        = False,         exposed           = False,         exposedModules    = [],         hiddenModules     = [],         trusted           = False,         importDirs        = [],         libraryDirs       = [],+        libraryDynDirs    = [],         dataDir           = "",         hsLibraries       = [],         extraLibraries    = [],@@ -165,17 +215,17 @@ data ExposedModule    = ExposedModule {        exposedName      :: ModuleName,-       exposedReexport  :: Maybe Module+       exposedReexport  :: Maybe OpenModule      }   deriving (Eq, Generic, Read, Show)  instance Text ExposedModule where     disp (ExposedModule m reexport) =-        Disp.sep [ disp m-                 , case reexport of-                    Just m' -> Disp.sep [Disp.text "from", disp m']-                    Nothing -> Disp.empty-                 ]+        Disp.hsep [ disp m+                  , case reexport of+                     Just m' -> Disp.hsep [Disp.text "from", disp m']+                     Nothing -> Disp.empty+                  ]     parse = do         m <- parseModuleNameQ         Parse.skipSpaces@@ -185,7 +235,6 @@             fmap Just parse         return (ExposedModule m reexport) - instance Binary ExposedModule  -- To maintain backwards-compatibility, we accept both comma/non-comma@@ -223,6 +272,13 @@ showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo +dispCompatPackageKey :: String -> Doc+dispCompatPackageKey = text++parseCompatPackageKey :: Parse.ReadP r String+parseCompatPackageKey = Parse.munch1 uid_char+    where uid_char c = Char.isAlphaNum c || c `elem` "-_.=[],:<>+"+ -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing @@ -240,9 +296,11 @@  , simpleField "id"                            disp                   parse                            installedUnitId             (\pk pkg -> pkg{installedUnitId=pk})- -- NB: parse these as component IDs+ , simpleField "instantiated-with"+        (dispOpenModuleSubst . Map.fromList)    (fmap Map.toList parseOpenModuleSubst)+        instantiatedWith   (\iw    pkg -> pkg{instantiatedWith=iw})  , simpleField "key"-                           (disp . ComponentId)   (fmap (\(ComponentId s) -> s) parse)+                           dispCompatPackageKey   parseCompatPackageKey                            compatPackageKey       (\pk pkg -> pkg{compatPackageKey=pk})  , simpleField "license"                            disp                   parseLicenseQ@@ -280,6 +338,8 @@ installedFieldDescrs = [    boolField "exposed"         exposed            (\val pkg -> pkg{exposed=val})+ , boolField "indefinite"+        indefinite         (\val pkg -> pkg{indefinite=val})  , simpleField "exposed-modules"         showExposedModules parseExposedModules         exposedModules     (\xs    pkg -> pkg{exposedModules=xs})@@ -297,6 +357,9 @@  , listField   "library-dirs"         showFilePath       parseFilePathQ         libraryDirs        (\xs pkg -> pkg{libraryDirs=xs})+ , listField   "dynamic-library-dirs"+        showFilePath       parseFilePathQ+        libraryDynDirs     (\xs pkg -> pkg{libraryDynDirs=xs})  , simpleField "data-dir"         showFilePath       (parseFilePathQ Parse.<++ return "")         dataDir            (\val pkg -> pkg{dataDir=val})
cabal/Cabal/Distribution/Lex.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Lex@@ -13,23 +12,9 @@         tokenizeQuotedWords  ) where -import Data.Char (isSpace)-import Distribution.Compat.Semigroup as Semi--newtype DList a = DList ([a] -> [a])--runDList :: DList a -> [a]-runDList (DList run) = run []--singleton :: a -> DList a-singleton a = DList (a:)--instance Monoid (DList a) where-  mempty = DList id-  mappend = (Semi.<>)--instance Semigroup (DList a) where-  DList a <> DList b = DList (a . b)+import Prelude ()+import Distribution.Compat.Prelude+import Distribution.Compat.DList  tokenizeQuotedWords :: String -> [String] tokenizeQuotedWords = filter (not . null) . go False mempty
cabal/Cabal/Distribution/License.hs view
@@ -47,17 +47,13 @@     knownLicenses,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Version import Distribution.Text import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.Binary- import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>))-import qualified Data.Char as Char (isAlphaNum)-import Data.Data (Data)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)  -- | Indicates the license under which a package's source code is released. -- Versions of the licenses not listed here will be rejected by Hackage and@@ -133,24 +129,24 @@                 , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3])                 , AGPL unversioned,                        AGPL (version [3])                 , BSD2, BSD3, MIT, ISC-                , MPL (Version [2, 0] [])+                , MPL (mkVersion [2, 0])                 , Apache unversioned, Apache (version [2, 0])                 , PublicDomain, AllRightsReserved, OtherLicense]  where    unversioned = Nothing-   version   v = Just (Version v [])+   version     = Just . mkVersion  instance Text License where-  disp (GPL  version)         = Disp.text "GPL"    <> dispOptVersion version-  disp (LGPL version)         = Disp.text "LGPL"   <> dispOptVersion version-  disp (AGPL version)         = Disp.text "AGPL"   <> dispOptVersion version-  disp (MPL  version)         = Disp.text "MPL"    <> dispVersion    version-  disp (Apache version)       = Disp.text "Apache" <> dispOptVersion version+  disp (GPL  version)         = Disp.text "GPL"    <<>> dispOptVersion version+  disp (LGPL version)         = Disp.text "LGPL"   <<>> dispOptVersion version+  disp (AGPL version)         = Disp.text "AGPL"   <<>> dispOptVersion version+  disp (MPL  version)         = Disp.text "MPL"    <<>> dispVersion    version+  disp (Apache version)       = Disp.text "Apache" <<>> dispOptVersion version   disp (UnknownLicense other) = Disp.text other   disp other                  = Disp.text (show other)    parse = do-    name    <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-')+    name    <- Parse.munch1 (\c -> isAlphaNum c && c /= '-')     version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)     return $! case (name, version :: Maybe Version) of       ("GPL",               _      ) -> GPL  version@@ -174,4 +170,4 @@ dispOptVersion (Just v) = dispVersion v  dispVersion :: Version -> Disp.Doc-dispVersion v = Disp.char '-' <> disp v+dispVersion v = Disp.char '-' <<>> disp v
cabal/Cabal/Distribution/Make.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Make@@ -56,10 +59,13 @@  module Distribution.Make (         module Distribution.Package,-        License(..), Version(..),+        License(..), Version,         defaultMain, defaultMainArgs, defaultMainNoRead   ) where +import Prelude ()+import Distribution.Compat.Prelude+ -- local import Distribution.Compat.Exception import Distribution.Package@@ -112,7 +118,7 @@     printVersion        = putStrLn $ "Cabal library version "                                   ++ display cabalVersion -    progs = defaultProgramConfiguration+    progs = defaultProgramDb     commands =       [configureCommand progs `commandAddAction` configureAction       ,buildCommand     progs `commandAddAction` buildAction
cabal/Cabal/Distribution/ModuleName.hs view
@@ -13,33 +13,30 @@ -- Data type for Haskell module names.  module Distribution.ModuleName (-        ModuleName,+        ModuleName (..), -- TODO: move Parsec instance here, don't export constructor         fromString,+        fromComponents,         components,         toFilePath,         main,         simple,+        -- * Internal+        validModuleComponent,   ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Utils.ShortText import Distribution.Text-import Distribution.Compat.Binary import qualified Distribution.Compat.ReadP as Parse -import qualified Data.Char as Char-         ( isAlphaNum, isUpper )-import Control.DeepSeq-import Data.Data (Data)-import Data.Typeable (Typeable) import qualified Text.PrettyPrint as Disp-import Data.List-         ( intercalate, intersperse )-import GHC.Generics (Generic)-import System.FilePath-         ( pathSeparator )+import System.FilePath ( pathSeparator )  -- | A valid Haskell module name. ---newtype ModuleName = ModuleName [String]+newtype ModuleName = ModuleName ShortTextLst   deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)  instance Binary ModuleName@@ -49,29 +46,29 @@  instance Text ModuleName where   disp (ModuleName ms) =-    Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms))+    Disp.hcat (intersperse (Disp.char '.') (map Disp.text $ stlToStrings ms))    parse = do     ms <- Parse.sepBy1 component (Parse.char '.')-    return (ModuleName ms)+    return (ModuleName $ stlFromStrings ms)      where       component = do-        c  <- Parse.satisfy Char.isUpper+        c  <- Parse.satisfy isUpper         cs <- Parse.munch validModuleChar         return (c:cs)  validModuleChar :: Char -> Bool-validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''+validModuleChar c = isAlphaNum c || c == '_' || c == '\''  validModuleComponent :: String -> Bool validModuleComponent []     = False-validModuleComponent (c:cs) = Char.isUpper c+validModuleComponent (c:cs) = isUpper c                            && all validModuleChar cs  {-# DEPRECATED simple "use ModuleName.fromString instead" #-} simple :: String -> ModuleName-simple str = ModuleName [str]+simple str = ModuleName (stlFromStrings [str])  -- | Construct a 'ModuleName' from a valid module name 'String'. --@@ -80,29 +77,34 @@ -- are parsing user input then use 'Distribution.Text.simpleParse' instead. -- fromString :: String -> ModuleName-fromString string-  | all validModuleComponent components' = ModuleName components'-  | otherwise                            = error badName-+fromString string = fromComponents (split string)   where-    components' = split string-    badName     = "ModuleName.fromString: invalid module name " ++ show string-     split cs = case break (=='.') cs of       (chunk,[])     -> chunk : []       (chunk,_:rest) -> chunk : split rest +-- | Construct a 'ModuleName' from valid module components, i.e. parts+-- separated by dots.+fromComponents :: [String] -> ModuleName+fromComponents components'+    | null components'                     = error zeroComponents+    | all validModuleComponent components' = ModuleName (stlFromStrings components')+    | otherwise                            = error badName+  where+    zeroComponents = "ModuleName.fromComponents: zero components"+    badName        = "ModuleName.fromComponents: invalid components " ++ show components'+ -- | The module name @Main@. -- main :: ModuleName-main = ModuleName ["Main"]+main = ModuleName (stlFromStrings ["Main"])  -- | The individual components of a hierarchical module name. For example -- -- > components (fromString "A.B.C") = ["A", "B", "C"] -- components :: ModuleName -> [String]-components (ModuleName ms) = ms+components (ModuleName ms) = stlToStrings ms  -- | Convert a module name to a file path, but without any file extension. -- For example:@@ -111,3 +113,39 @@ -- toFilePath :: ModuleName -> FilePath toFilePath = intercalate [pathSeparator] . components++----------------------------------------------------------------------------+-- internal helper++-- | Strict/unpacked representation of @[ShortText]@+data ShortTextLst = STLNil+                  | STLCons !ShortText !ShortTextLst+                  deriving (Eq, Generic, Ord, Typeable, Data)++instance NFData ShortTextLst where+    rnf = flip seq ()++instance Show ShortTextLst where+    showsPrec p = showsPrec p . stlToList+++instance Read ShortTextLst where+    readsPrec p = map (first stlFromList) . readsPrec p++instance Binary ShortTextLst where+    put = put . stlToList+    get = stlFromList <$> get++stlToList :: ShortTextLst -> [ShortText]+stlToList STLNil = []+stlToList (STLCons st next) = st : stlToList next++stlToStrings :: ShortTextLst -> [String]+stlToStrings = map fromShortText . stlToList++stlFromList :: [ShortText] -> ShortTextLst+stlFromList [] = STLNil+stlFromList (x:xs) = STLCons x (stlFromList xs)++stlFromStrings :: [String] -> ShortTextLst+stlFromStrings = stlFromList . map toShortText
cabal/Cabal/Distribution/Package.hs view
@@ -18,14 +18,20 @@  module Distribution.Package (         -- * Package ids-        PackageName(..),+        UnqualComponentName, unUnqualComponentName, mkUnqualComponentName,+        PackageName, unPackageName, mkPackageName,+        packageNameToUnqualComponentName, unqualComponentNameToPackageName,         PackageIdentifier(..),         PackageId,+        PkgconfigName, unPkgconfigName, mkPkgconfigName,          -- * Package keys/installed package IDs (used for linker symbols)-        ComponentId(..),-        UnitId(..),-        mkUnitId,+        ComponentId, unComponentId, mkComponentId,+        UnitId, unUnitId, mkUnitId,+        DefUnitId,+        unsafeMkDefUnitId,+        unDefUnitId,+        newSimpleUnitId,         mkLegacyUnitId,         getHSLibraryName,         InstalledPackageId, -- backwards compat@@ -34,10 +40,12 @@         Module(..),          -- * ABI hash-        AbiHash(..),+        AbiHash, unAbiHash, mkAbiHash,          -- * Package source dependencies         Dependency(..),+        LegacyExeDependency(..),+        PkgconfigDependency(..),         thisPackageVersion,         notThisPackageVersion,         simplifyDependency,@@ -49,46 +57,165 @@         PackageInstalled(..),   ) where +import Prelude ()+import Distribution.Compat.Prelude+import Distribution.Utils.ShortText+ import Distribution.Version-         ( Version(..), VersionRange, anyVersion, thisVersion-         , notThisVersion, simplifyVersionRange )+         ( Version, VersionRange, thisVersion+         , notThisVersion, simplifyVersionRange+         , nullVersion )  import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Distribution.Compat.ReadP-import Distribution.Compat.Binary import Distribution.Text import Distribution.ModuleName -import Control.DeepSeq (NFData(..))-import qualified Data.Char as Char-    ( isDigit, isAlphaNum, )-import Data.Data ( Data )-import Data.List ( intercalate )-import Data.Typeable ( Typeable )-import GHC.Generics (Generic)-import Text.PrettyPrint ((<>), (<+>), text)+import Text.PrettyPrint (text) -newtype PackageName = PackageName { unPackageName :: String }+-- | An unqualified component name, for any kind of component.+--+-- This is distinguished from a 'ComponentName' and 'ComponentId'. The former+-- also states which of a library, executable, etc the name refers too. The+-- later uniquely identifiers a component and its closure.+--+-- @since 2.0+newtype UnqualComponentName = UnqualComponentName ShortText+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data,+              Semigroup, Monoid) -- TODO: bad enabler of bad monoids++-- | Convert 'UnqualComponentName' to 'String'+--+-- @since 2.0+unUnqualComponentName :: UnqualComponentName -> String+unUnqualComponentName (UnqualComponentName s) = fromShortText s++-- | Construct a 'UnqualComponentName' from a 'String'+--+-- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName'+--+-- Note: No validations are performed to ensure that the resulting+-- 'UnqualComponentName' is valid+--+-- @since 2.0+mkUnqualComponentName :: String -> UnqualComponentName+mkUnqualComponentName = UnqualComponentName . toShortText++instance Binary UnqualComponentName++parsePackageName :: Parse.ReadP r String+parsePackageName = do+  ns <- Parse.sepBy1 component (Parse.char '-')+  return $ intercalate "-" ns+  where+    component = do+      cs <- Parse.munch1 isAlphaNum+      if all isDigit cs then Parse.pfail else return cs+      -- each component must contain an alphabetic character, to avoid+      -- ambiguity in identifiers like foo-1 (the 1 is the version number).++instance Text UnqualComponentName where+  disp = Disp.text . unUnqualComponentName+  parse = mkUnqualComponentName <$> parsePackageName++instance NFData UnqualComponentName where+    rnf (UnqualComponentName pkg) = rnf pkg++-- | A package name.+--+-- Use 'mkPackageName' and 'unPackageName' to convert from/to a+-- 'String'.+--+-- This type is opaque since @Cabal-2.0@+--+-- @since 2.0+newtype PackageName = PackageName ShortText     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +-- | Convert 'PackageName' to 'String'+unPackageName :: PackageName -> String+unPackageName (PackageName s) = fromShortText s++-- | Construct a 'PackageName' from a 'String'+--+-- 'mkPackageName' is the inverse to 'unPackageName'+--+-- Note: No validations are performed to ensure that the resulting+-- 'PackageName' is valid+--+-- @since 2.0+mkPackageName :: String -> PackageName+mkPackageName = PackageName . toShortText++-- | Converts a package name to an unqualified component name+--+-- Useful in legacy situations where a package name may refer to an internal+-- component, if one is defined with that name.+--+-- @since 2.0+packageNameToUnqualComponentName :: PackageName -> UnqualComponentName+packageNameToUnqualComponentName (PackageName s) = UnqualComponentName s++-- | Converts an unqualified component name to a package name+--+-- `packageNameToUnqualComponentName` is the inverse of+-- `unqualComponentNameToPackageName`.+--+-- Useful in legacy situations where a package name may refer to an internal+-- component, if one is defined with that name.+--+-- @since 2.0+unqualComponentNameToPackageName :: UnqualComponentName -> PackageName+unqualComponentNameToPackageName (UnqualComponentName s) = PackageName s+ instance Binary PackageName  instance Text PackageName where-  disp (PackageName n) = Disp.text n-  parse = do-    ns <- Parse.sepBy1 component (Parse.char '-')-    return (PackageName (intercalate "-" ns))-    where-      component = do-        cs <- Parse.munch1 Char.isAlphaNum-        if all Char.isDigit cs then Parse.pfail else return cs-        -- each component must contain an alphabetic character, to avoid-        -- ambiguity in identifiers like foo-1 (the 1 is the version number).+  disp = Disp.text . unPackageName+  parse = mkPackageName <$> parsePackageName  instance NFData PackageName where     rnf (PackageName pkg) = rnf pkg +-- | A pkg-config library name+--+-- This is parsed as any valid argument to the pkg-config utility.+--+-- @since 2.0+newtype PkgconfigName = PkgconfigName ShortText+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)++-- | Convert 'PkgconfigName' to 'String'+--+-- @since 2.0+unPkgconfigName :: PkgconfigName -> String+unPkgconfigName (PkgconfigName s) = fromShortText s++-- | Construct a 'PkgconfigName' from a 'String'+--+-- 'mkPkgconfigName' is the inverse to 'unPkgconfigName'+--+-- Note: No validations are performed to ensure that the resulting+-- 'PkgconfigName' is valid+--+-- @since 2.0+mkPkgconfigName :: String -> PkgconfigName+mkPkgconfigName = PkgconfigName . toShortText++instance Binary PkgconfigName++-- pkg-config allows versions and other letters in package names, eg+-- "gtk+-2.0" is a valid pkg-config package _name_.  It then has a package+-- version number like 2.10.13+instance Text PkgconfigName where+  disp = Disp.text . unPkgconfigName+  parse = mkPkgconfigName+          <$> munch1 (\c -> isAlphaNum c || c `elem` "+-._")++instance NFData PkgconfigName where+    rnf (PkgconfigName pkg) = rnf pkg+ -- | Type alias so we can use the shorter name PackageId. type PackageId = PackageIdentifier @@ -103,13 +230,13 @@ instance Binary PackageIdentifier  instance Text PackageIdentifier where-  disp (PackageIdentifier n v) = case v of-    Version [] _ -> disp n -- if no version, don't show version.-    _            -> disp n <> Disp.char '-' <> disp v+  disp (PackageIdentifier n v)+    | v == nullVersion = disp n -- if no version, don't show version.+    | otherwise        = disp n <<>> Disp.char '-' <<>> disp v    parse = do     n <- parse-    v <- (Parse.char '-' >> parse) <++ return (Version [] [])+    v <- (Parse.char '-' >> parse) <++ return nullVersion     return (PackageIdentifier n v)  instance NFData PackageIdentifier where@@ -124,15 +251,14 @@ -- module identities, e.g., when writing out reexported modules in -- the 'InstalledPackageInfo'. data Module =-    Module { moduleUnitId :: UnitId,-             moduleName :: ModuleName }+      Module DefUnitId ModuleName     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)  instance Binary Module  instance Text Module where     disp (Module uid mod_name) =-        disp uid <> Disp.text ":" <> disp mod_name+        disp uid <<>> Disp.text ":" <<>> disp mod_name     parse = do         uid <- parse         _ <- Parse.char ':'@@ -143,43 +269,122 @@     rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name  -- | A 'ComponentId' uniquely identifies the transitive source--- code closure of a component.  For non-Backpack components, it also--- serves as the basis for install paths, symbols, etc.+-- code closure of a component (i.e. libraries, executables). ---data ComponentId-    = ComponentId String+-- For non-Backpack components, this corresponds one to one with+-- the 'UnitId', which serves as the basis for install paths,+-- linker symbols, etc.+--+-- Use 'mkComponentId' and 'unComponentId' to convert from/to a+-- 'String'.+--+-- This type is opaque since @Cabal-2.0@+--+-- @since 2.0+newtype ComponentId = ComponentId ShortText     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +-- | Construct a 'ComponentId' from a 'String'+--+-- 'mkComponentId' is the inverse to 'unComponentId'+--+-- Note: No validations are performed to ensure that the resulting+-- 'ComponentId' is valid+--+-- @since 2.0+mkComponentId :: String -> ComponentId+mkComponentId = ComponentId . toShortText++-- | Convert 'ComponentId' to 'String'+--+-- @since 2.0+unComponentId :: ComponentId -> String+unComponentId (ComponentId s) = fromShortText s+ {-# DEPRECATED InstalledPackageId "Use UnitId instead" #-} type InstalledPackageId = UnitId  instance Binary ComponentId  instance Text ComponentId where-  disp (ComponentId str) = text str+  disp = text . unComponentId -  parse = ComponentId `fmap` Parse.munch1 abi_char-   where abi_char c = Char.isAlphaNum c || c `elem` "-_."+  parse = mkComponentId `fmap` Parse.munch1 abi_char+   where abi_char c = isAlphaNum c || c `elem` "-_."  instance NFData ComponentId where-    rnf (ComponentId pk) = rnf pk+    rnf = rnf . unComponentId  -- | Returns library name prefixed with HS, suitable for filenames getHSLibraryName :: UnitId -> String-getHSLibraryName (SimpleUnitId (ComponentId s)) = "HS" ++ s+getHSLibraryName uid = "HS" ++ display uid --- | For now, there is no distinction between component IDs--- and unit IDs in Cabal.-newtype UnitId = SimpleUnitId ComponentId-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, Text, NFData)+-- | A unit identifier identifies a (possibly instantiated)+-- package/component that can be installed the installed package+-- database.  There are several types of components that can be+-- installed:+--+--  * A traditional library with no holes, so that 'unitIdHash'+--    is @Nothing@.  In the absence of Backpack, 'UnitId'+--    is the same as a 'ComponentId'.+--+--  * An indefinite, Backpack library with holes.  In this case,+--    'unitIdHash' is still @Nothing@, but in the install,+--    there are only interfaces, no compiled objects.+--+--  * An instantiated Backpack library with all the holes+--    filled in.  'unitIdHash' is a @Just@ a hash of the+--    instantiating mapping.+--+-- A unit is a component plus the additional information on how the+-- holes are filled in. Thus there is a one to many relationship: for a+-- particular component there are many different ways of filling in the+-- holes, and each different combination is a unit (and has a separate+-- 'UnitId').+--+-- 'UnitId' is distinct from 'OpenUnitId', in that it is always+-- installed, whereas 'OpenUnitId' are intermediate unit identities+-- that arise during mixin linking, and don't necessarily correspond+-- to any actually installed unit.  Since the mapping is not actually+-- recorded in a 'UnitId', you can't actually substitute over them+-- (but you can substitute over 'OpenUnitId').  See also+-- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an+-- instantiated 'UnitId' to retrieve its mapping.+--+newtype UnitId = UnitId ShortText+  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) --- | Makes a simple-style UnitId from a string.+instance Binary UnitId++instance Text UnitId where+    disp = text . unUnitId+    parse = mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")++unUnitId :: UnitId -> String+unUnitId (UnitId s) = fromShortText s+ mkUnitId :: String -> UnitId-mkUnitId = SimpleUnitId . ComponentId+mkUnitId = UnitId . toShortText +-- | A 'UnitId' for a definite package.  The 'DefUnitId' invariant says+-- that a 'UnitId' identified this way is definite; i.e., it has no+-- unfilled holes.+newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId }+  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Text)++-- | Unsafely create a 'DefUnitId' from a 'UnitId'.  Your responsibility+-- is to ensure that the 'DefUnitId' invariant holds.+unsafeMkDefUnitId :: UnitId -> DefUnitId+unsafeMkDefUnitId = DefUnitId++-- | Create a unit identity with no associated hash directly+-- from a 'ComponentId'.+newSimpleUnitId :: ComponentId -> UnitId+newSimpleUnitId (ComponentId s) = UnitId s+ -- | Make an old-style UnitId from a package identifier mkLegacyUnitId :: PackageId -> UnitId-mkLegacyUnitId = SimpleUnitId . ComponentId . display+mkLegacyUnitId = newSimpleUnitId . mkComponentId . display  -- ------------------------------------------------------------ -- * Package source dependencies@@ -190,18 +395,34 @@ data Dependency = Dependency PackageName VersionRange                   deriving (Generic, Read, Show, Eq, Typeable, Data) -instance Binary Dependency+-- | Describes a legacy `build-tools`-style dependency on an executable+--+-- It is "legacy" because we do not know what the build-tool referred to. It+-- could refer to a pkg-config executable (PkgconfigName), or an internal+-- executable (UnqualComponentName). Thus the name is stringly typed.+--+-- @since 2.0+data LegacyExeDependency = LegacyExeDependency+                           String+                           VersionRange+                         deriving (Generic, Read, Show, Eq, Typeable, Data) -instance Text Dependency where-  disp (Dependency name ver) =-    disp name <+> disp ver+-- | Describes a dependency on a pkg-config library+--+-- @since 2.0+data PkgconfigDependency = PkgconfigDependency+                           PkgconfigName+                           VersionRange+                         deriving (Generic, Read, Show, Eq, Typeable, Data) -  parse = do name <- parse-             Parse.skipSpaces-             ver <- parse <++ return anyVersion-             Parse.skipSpaces-             return (Dependency name ver)+instance Binary Dependency+instance Binary LegacyExeDependency+instance Binary PkgconfigDependency +instance NFData Dependency where rnf = genericRnf+instance NFData LegacyExeDependency where rnf = genericRnf+instance NFData PkgconfigDependency where rnf = genericRnf+ thisPackageVersion :: PackageIdentifier -> Dependency thisPackageVersion (PackageIdentifier n v) =   Dependency n (thisVersion v)@@ -239,7 +460,7 @@ instance Package PackageIdentifier where   packageId = id --- | Packages that have an installed package ID+-- | Packages that have an installed unit ID class Package pkg => HasUnitId pkg where   installedUnitId :: pkg -> UnitId @@ -260,10 +481,36 @@ -- ----------------------------------------------------------------------------- -- ABI hash -newtype AbiHash = AbiHash String+-- | ABI Hashes+--+-- Use 'mkAbiHash' and 'unAbiHash' to convert from/to a+-- 'String'.+--+-- This type is opaque since @Cabal-2.0@+--+-- @since 2.0+newtype AbiHash = AbiHash ShortText     deriving (Eq, Show, Read, Generic)++-- | Construct a 'AbiHash' from a 'String'+--+-- 'mkAbiHash' is the inverse to 'unAbiHash'+--+-- Note: No validations are performed to ensure that the resulting+-- 'AbiHash' is valid+--+-- @since 2.0+unAbiHash :: AbiHash -> String+unAbiHash (AbiHash h) = fromShortText h++-- | Convert 'AbiHash' to 'String'+--+-- @since 2.0+mkAbiHash :: String -> AbiHash+mkAbiHash = AbiHash . toShortText+ instance Binary AbiHash  instance Text AbiHash where-    disp (AbiHash abi) = Disp.text abi-    parse = fmap AbiHash (Parse.munch Char.isAlphaNum)+    disp = Disp.text . unAbiHash+    parse = fmap mkAbiHash (Parse.munch isAlphaNum)
+ cabal/Cabal/Distribution/Package/TextClass.hs view
@@ -0,0 +1,56 @@+-- | *Dependency Text instances moved from Distribution.Package+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Distribution.Package.TextClass () where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Package+import Distribution.ParseUtils+import Distribution.Version (anyVersion)++import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import Distribution.Compat.ReadP+import Distribution.Text++import Text.PrettyPrint ((<+>))+++instance Text Dependency where+  disp (Dependency name ver) =+    disp name <+> disp ver++  parse = do name <- parse+             Parse.skipSpaces+             ver <- parse <++ return anyVersion+             Parse.skipSpaces+             return (Dependency name ver)++instance Text LegacyExeDependency where+  disp (LegacyExeDependency name ver) =+    Disp.text name <+> disp ver++  parse = do name <- parseMaybeQuoted parseBuildToolName+             Parse.skipSpaces+             ver <- parse <++ return anyVersion+             Parse.skipSpaces+             return $ LegacyExeDependency name ver+    where+      -- like parsePackageName but accepts symbols in components+      parseBuildToolName :: Parse.ReadP r String+      parseBuildToolName = do ns <- sepBy1 component (Parse.char '-')+                              return (intercalate "-" ns)+        where component = do+                cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_')+                if all isDigit cs then pfail else return cs++instance Text PkgconfigDependency where+  disp (PkgconfigDependency name ver) =+    disp name <+> disp ver++  parse = do name <- parse+             Parse.skipSpaces+             ver <- parse <++ return anyVersion+             Parse.skipSpaces+             return $ PkgconfigDependency name ver
cabal/Cabal/Distribution/PackageDescription.hs view
@@ -11,1285 +11,121 @@ -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable ----- This defines the data structure for the @.cabal@ file format. There are--- several parts to this structure. It has top level info and then 'Library',--- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have--- associated 'BuildInfo' data that's used to build the library, exe, test, or--- benchmark.  To further complicate things there is both a 'PackageDescription'--- and a 'GenericPackageDescription'. This distinction relates to cabal--- configurations. When we initially read a @.cabal@ file we get a--- 'GenericPackageDescription' which has all the conditional sections.--- Before actually building a package we have to decide--- on each conditional. Once we've done that we get a 'PackageDescription'.--- It was done this way initially to avoid breaking too much stuff when the--- feature was introduced. It could probably do with being rationalised at some--- point to make it simpler.--module Distribution.PackageDescription (-        -- * Package descriptions-        PackageDescription(..),-        emptyPackageDescription,-        specVersion,-        descCabalVersion,-        BuildType(..),-        knownBuildTypes,--        -- ** Renaming-        ModuleRenaming(..),-        defaultRenaming,-        lookupRenaming,--        -- ** Libraries-        Library(..),-        ModuleReexport(..),-        emptyLibrary,-        withLib,-        hasPublicLib,-        hasLibs,-        libModules,--        -- ** Executables-        Executable(..),-        emptyExecutable,-        withExe,-        hasExes,-        exeModules,--        -- * Tests-        TestSuite(..),-        TestSuiteInterface(..),-        TestType(..),-        testType,-        knownTestTypes,-        emptyTestSuite,-        hasTests,-        withTest,-        testModules,-        enabledTests,--        -- * Benchmarks-        Benchmark(..),-        BenchmarkInterface(..),-        BenchmarkType(..),-        benchmarkType,-        knownBenchmarkTypes,-        emptyBenchmark,-        hasBenchmarks,-        withBenchmark,-        benchmarkModules,-        enabledBenchmarks,--        -- * Build information-        BuildInfo(..),-        emptyBuildInfo,-        allBuildInfo,-        allLanguages,-        allExtensions,-        usedExtensions,-        hcOptions,-        hcProfOptions,-        hcSharedOptions,--        -- ** Supplementary build information-        ComponentName(..),-        defaultLibName,-        HookedBuildInfo,-        emptyHookedBuildInfo,-        updatePackageDescription,--        -- * package configuration-        GenericPackageDescription(..),-        Flag(..), FlagName(..), FlagAssignment,-        CondTree(..), ConfVar(..), Condition(..),-        cNot,--        -- * Source repositories-        SourceRepo(..),-        RepoKind(..),-        RepoType(..),-        knownRepoTypes,--        -- * Custom setup build information-        SetupBuildInfo(..),-  ) where--import Distribution.Compat.Binary-import qualified Distribution.Compat.Semigroup as Semi ((<>))-import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup, gmempty, gmappend)-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP   ((<++))-import Distribution.Package-import Distribution.ModuleName-import Distribution.Version-import Distribution.License-import Distribution.Compiler-import Distribution.System-import Distribution.Text-import Language.Haskell.Extension--import Data.Data                  (Data)-import Data.List                  (nub, intercalate)-import Data.Maybe                 (fromMaybe, maybeToList)-import Data.Foldable as Fold      (Foldable(foldMap))-import Data.Traversable as Trav   (Traversable(traverse))-import Data.Typeable               ( Typeable )-import Control.Applicative as AP   (Alternative(..), Applicative(..))-import Control.Monad               (MonadPlus(mplus,mzero), ap)-import GHC.Generics                (Generic)-import Text.PrettyPrint as Disp-import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)-import qualified Data.Map as Map-import Data.Map                    (Map)---- -------------------------------------------------------------------------------- The PackageDescription type---- | This data type is the internal representation of the file @pkg.cabal@.--- It contains two kinds of information about the package: information--- which is needed for all packages, such as the package name and version, and--- information which is needed for the simple build system only, such as--- the compiler options and library name.----data PackageDescription-    =  PackageDescription {-        -- the following are required by all packages:-        package        :: PackageIdentifier,-        license        :: License,-        licenseFiles   :: [FilePath],-        copyright      :: String,-        maintainer     :: String,-        author         :: String,-        stability      :: String,-        testedWith     :: [(CompilerFlavor,VersionRange)],-        homepage       :: String,-        pkgUrl         :: String,-        bugReports     :: String,-        sourceRepos    :: [SourceRepo],-        synopsis       :: String, -- ^A one-line summary of this package-        description    :: String, -- ^A more verbose description of this package-        category       :: String,-        customFieldsPD :: [(String,String)], -- ^Custom fields starting-                                             -- with x-, stored in a-                                             -- simple assoc-list.--        -- | YOU PROBABLY DON'T WANT TO USE THIS FIELD. This field is-        -- special! Depending on how far along processing the-        -- PackageDescription we are, the contents of this field are-        -- either nonsense, or the collected dependencies of *all* the-        -- components in this package.  buildDepends is initialized by-        -- 'finalizePackageDescription' and 'flattenPackageDescription';-        -- prior to that, dependency info is stored in the 'CondTree'-        -- built around a 'GenericPackageDescription'.  When this-        -- resolution is done, dependency info is written to the inner-        -- 'BuildInfo' and this field.  This is all horrible, and #2066-        -- tracks progress to get rid of this field.-        buildDepends   :: [Dependency],-        -- | The version of the Cabal spec that this package description uses.-        -- For historical reasons this is specified with a version range but-        -- only ranges of the form @>= v@ make sense. We are in the process of-        -- transitioning to specifying just a single version, not a range.-        specVersionRaw :: Either Version VersionRange,-        buildType      :: Maybe BuildType,-        setupBuildInfo :: Maybe SetupBuildInfo,-        -- components-        libraries      :: [Library],-        executables    :: [Executable],-        testSuites     :: [TestSuite],-        benchmarks     :: [Benchmark],-        dataFiles      :: [FilePath],-        dataDir        :: FilePath,-        extraSrcFiles  :: [FilePath],-        extraTmpFiles  :: [FilePath],-        extraDocFiles  :: [FilePath]-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary PackageDescription--instance Package PackageDescription where-  packageId = package---- | The version of the Cabal spec that this package should be interpreted--- against.------ Historically we used a version range but we are switching to using a single--- version. Currently we accept either. This function converts into a single--- version by ignoring upper bounds in the version range.----specVersion :: PackageDescription -> Version-specVersion pkg = case specVersionRaw pkg of-  Left  version      -> version-  Right versionRange -> case asVersionIntervals versionRange of-                          []                            -> Version [0] []-                          ((LowerBound version _, _):_) -> version---- | The range of versions of the Cabal tools that this package is intended to--- work with.------ This function is deprecated and should not be used for new purposes, only to--- support old packages that rely on the old interpretation.----descCabalVersion :: PackageDescription -> VersionRange-descCabalVersion pkg = case specVersionRaw pkg of-  Left  version      -> orLaterVersion version-  Right versionRange -> versionRange-{-# DEPRECATED descCabalVersion "Use specVersion instead" #-}--emptyPackageDescription :: PackageDescription-emptyPackageDescription-    =  PackageDescription {-                      package      = PackageIdentifier (PackageName "")-                                                       (Version [] []),-                      license      = UnspecifiedLicense,-                      licenseFiles = [],-                      specVersionRaw = Right anyVersion,-                      buildType    = Nothing,-                      copyright    = "",-                      maintainer   = "",-                      author       = "",-                      stability    = "",-                      testedWith   = [],-                      buildDepends = [],-                      homepage     = "",-                      pkgUrl       = "",-                      bugReports   = "",-                      sourceRepos  = [],-                      synopsis     = "",-                      description  = "",-                      category     = "",-                      customFieldsPD = [],-                      setupBuildInfo = Nothing,-                      libraries    = [],-                      executables  = [],-                      testSuites   = [],-                      benchmarks   = [],-                      dataFiles    = [],-                      dataDir      = "",-                      extraSrcFiles = [],-                      extraTmpFiles = [],-                      extraDocFiles = []-                     }---- | The type of build system used by this package.-data BuildType-  = Simple      -- ^ calls @Distribution.Simple.defaultMain@-  | Configure   -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,-                -- which invokes @configure@ to generate additional build-                -- information used by later phases.-  | Make        -- ^ calls @Distribution.Make.defaultMain@-  | Custom      -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)-  | UnknownBuildType String-                -- ^ a package that uses an unknown build type cannot actually-                --   be built. Doing it this way rather than just giving a-                --   parse error means we get better error messages and allows-                --   you to inspect the rest of the package description.-                deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BuildType--knownBuildTypes :: [BuildType]-knownBuildTypes = [Simple, Configure, Make, Custom]--instance Text BuildType where-  disp (UnknownBuildType other) = Disp.text other-  disp other                    = Disp.text (show other)--  parse = do-    name <- Parse.munch1 Char.isAlphaNum-    return $ case name of-      "Simple"    -> Simple-      "Configure" -> Configure-      "Custom"    -> Custom-      "Make"      -> Make-      _           -> UnknownBuildType name---- ------------------------------------------------------------------------------ The SetupBuildInfo type---- One can see this as a very cut-down version of BuildInfo below.--- To keep things simple for tools that compile Setup.hs we limit the--- options authors can specify to just Haskell package dependencies.--data SetupBuildInfo = SetupBuildInfo {-        setupDepends :: [Dependency]-    }-    deriving (Generic, Show, Eq, Read, Typeable, Data)--instance Binary SetupBuildInfo--instance Semi.Monoid SetupBuildInfo where-  mempty = gmempty-  mappend = (Semi.<>)--instance Semigroup SetupBuildInfo where-  (<>) = gmappend---- ------------------------------------------------------------------------------ Module renaming---- | Renaming applied to the modules provided by a package.--- The boolean indicates whether or not to also include all of the--- original names of modules.  Thus, @ModuleRenaming False []@ is--- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@--- is, "expose all modules, but also expose @Data.Bool@ as @Bool@".----data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]-    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)--defaultRenaming :: ModuleRenaming-defaultRenaming = ModuleRenaming True []--lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming-lookupRenaming = Map.findWithDefault defaultRenaming . packageName--instance Binary ModuleRenaming where--instance Monoid ModuleRenaming where-    mempty = ModuleRenaming False []-    mappend = (Semi.<>)--instance Semigroup ModuleRenaming where-    ModuleRenaming b rns <> ModuleRenaming b' rns'-        = ModuleRenaming (b || b') (rns ++ rns') -- TODO: dedupe?---- NB: parentheses are mandatory, because later we may extend this syntax--- to allow "hiding (A, B)" or other modifier words.-instance Text ModuleRenaming where-  disp (ModuleRenaming True []) = Disp.empty-  disp (ModuleRenaming b vs) = (if b then text "with" else Disp.empty) <+> dispRns-    where dispRns = Disp.parens-                         (Disp.hsep-                            (Disp.punctuate Disp.comma (map dispEntry vs)))-          dispEntry (orig, new)-            | orig == new = disp orig-            | otherwise = disp orig <+> text "as" <+> disp new--  parse = do Parse.string "with" >> Parse.skipSpaces-             fmap (ModuleRenaming True) parseRns-         <++ fmap (ModuleRenaming False) parseRns-         <++ return (ModuleRenaming True [])-    where parseRns = do-             rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList-             Parse.skipSpaces-             return rns-          parseList =-            Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces)-          parseEntry :: Parse.ReadP r (ModuleName, ModuleName)-          parseEntry = do-            orig <- parse-            Parse.skipSpaces-            (do _ <- Parse.string "as"-                Parse.skipSpaces-                new <- parse-                Parse.skipSpaces-                return (orig, new)-             <++-                return (orig, orig))---- ------------------------------------------------------------------------------ The Library type--data Library = Library {-        libName :: String,-        exposedModules    :: [ModuleName],-        reexportedModules :: [ModuleReexport],-        requiredSignatures:: [ModuleName], -- ^ What sigs need implementations?-        exposedSignatures:: [ModuleName], -- ^ What sigs are visible to users?-        libExposed        :: Bool, -- ^ Is the lib to be exposed by default?-        libBuildInfo      :: BuildInfo-    }-    deriving (Generic, Show, Eq, Read, Typeable, Data)--instance Binary Library--instance Monoid Library where-  mempty = Library {-    libName = mempty,-    exposedModules = mempty,-    reexportedModules = mempty,-    requiredSignatures = mempty,-    exposedSignatures = mempty,-    libExposed     = True,-    libBuildInfo   = mempty-  }-  mappend = (Semi.<>)--instance Semigroup Library where-  a <> b = Library {-    libName = combine' libName,-    exposedModules = combine exposedModules,-    reexportedModules = combine reexportedModules,-    requiredSignatures = combine requiredSignatures,-    exposedSignatures = combine exposedSignatures,-    libExposed     = libExposed a && libExposed b, -- so False propagates-    libBuildInfo   = combine libBuildInfo-  }-    where combine field = field a `mappend` field b-          combine' field = case (field a, field b) of-                      ("","") -> ""-                      ("", x) -> x-                      (x, "") -> x-                      (x, y) -> error $ "Ambiguous values for library field: '"-                                  ++ x ++ "' and '" ++ y ++ "'"--emptyLibrary :: Library-emptyLibrary = mempty---- | Does this package have a PUBLIC library?-hasPublicLib :: PackageDescription -> Bool-hasPublicLib p = any f (libraries p)-    where f lib = buildable (libBuildInfo lib) &&-                  libName lib == display (packageName (package p))---- | Does this package have any libraries?-hasLibs :: PackageDescription -> Bool-hasLibs p = any (buildable . libBuildInfo) (libraries p)---- |If the package description has a library section, call the given---  function with the library build info as argument.-withLib :: PackageDescription -> (Library -> IO ()) -> IO ()-withLib pkg_descr f =-   sequence_ [f lib | lib <- libraries pkg_descr, buildable (libBuildInfo lib)]---- | Get all the module names from the library (exposed and internal modules)--- which need to be compiled.  (This does not include reexports, which--- do not need to be compiled.)-libModules :: Library -> [ModuleName]-libModules lib = exposedModules lib-              ++ otherModules (libBuildInfo lib)-              ++ exposedSignatures lib-              ++ requiredSignatures lib---- -------------------------------------------------------------------------------- Module re-exports--data ModuleReexport = ModuleReexport {-       moduleReexportOriginalPackage :: Maybe PackageName,-       moduleReexportOriginalName    :: ModuleName,-       moduleReexportName            :: ModuleName-    }-    deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary ModuleReexport--instance Text ModuleReexport where-    disp (ModuleReexport mpkgname origname newname) =-          maybe Disp.empty (\pkgname -> disp pkgname <> Disp.char ':') mpkgname-       <> disp origname-      <+> if newname == origname-            then Disp.empty-            else Disp.text "as" <+> disp newname--    parse = do-      mpkgname <- Parse.option Nothing $ do-                    pkgname <- parse-                    _       <- Parse.char ':'-                    return (Just pkgname)-      origname <- parse-      newname  <- Parse.option origname $ do-                    Parse.skipSpaces-                    _ <- Parse.string "as"-                    Parse.skipSpaces-                    parse-      return (ModuleReexport mpkgname origname newname)---- ------------------------------------------------------------------------------ The Executable type--data Executable = Executable {-        exeName    :: String,-        modulePath :: FilePath,-        buildInfo  :: BuildInfo-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary Executable--instance Monoid Executable where-  mempty = gmempty-  mappend = (Semi.<>)--instance Semigroup Executable where-  a <> b = Executable{-    exeName    = combine' exeName,-    modulePath = combine modulePath,-    buildInfo  = combine buildInfo-  }-    where combine field = field a `mappend` field b-          combine' field = case (field a, field b) of-                      ("","") -> ""-                      ("", x) -> x-                      (x, "") -> x-                      (x, y) -> error $ "Ambiguous values for executable field: '"-                                  ++ x ++ "' and '" ++ y ++ "'"--emptyExecutable :: Executable-emptyExecutable = mempty---- |does this package have any executables?-hasExes :: PackageDescription -> Bool-hasExes p = any (buildable . buildInfo) (executables p)---- | Perform the action on each buildable 'Executable' in the package--- description.-withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()-withExe pkg_descr f =-  sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]---- | Get all the module names from an exe-exeModules :: Executable -> [ModuleName]-exeModules exe = otherModules (buildInfo exe)---- ------------------------------------------------------------------------------ The TestSuite type---- | A \"test-suite\" stanza in a cabal file.----data TestSuite = TestSuite {-        testName      :: String,-        testInterface :: TestSuiteInterface,-        testBuildInfo :: BuildInfo,-        testEnabled   :: Bool-        -- TODO: By having a 'testEnabled' field in the PackageDescription, we-        -- are mixing build status information (i.e., arguments to 'configure')-        -- with static package description information. This is undesirable, but-        -- a better solution is waiting on the next overhaul to the-        -- GenericPackageDescription -> PackageDescription resolution process.-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary TestSuite---- | The test suite interfaces that are currently defined. Each test suite must--- specify which interface it supports.------ More interfaces may be defined in future, either new revisions or totally--- new interfaces.----data TestSuiteInterface =--     -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form-     -- of an executable. It returns a zero exit code for success, non-zero for-     -- failure. The stdout and stderr channels may be logged. It takes no-     -- command line parameters and nothing on stdin.-     ---     TestSuiteExeV10 Version FilePath--     -- | Test interface \"detailed-0.9\". The test-suite takes the form of a-     -- library containing a designated module that exports \"tests :: [Test]\".-     ---   | TestSuiteLibV09 Version ModuleName--     -- | A test suite that does not conform to one of the above interfaces for-     -- the given reason (e.g. unknown test type).-     ---   | TestSuiteUnsupported TestType-   deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary TestSuiteInterface--instance Monoid TestSuite where-    mempty = TestSuite {-        testName      = mempty,-        testInterface = mempty,-        testBuildInfo = mempty,-        testEnabled   = False-    }-    mappend = (Semi.<>)--instance Semigroup TestSuite where-    a <> b = TestSuite {-        testName      = combine' testName,-        testInterface = combine  testInterface,-        testBuildInfo = combine  testBuildInfo,-        testEnabled   = testEnabled a || testEnabled b-    }-        where combine   field = field a `mappend` field b-              combine' f = case (f a, f b) of-                        ("", x) -> x-                        (x, "") -> x-                        (x, y) -> error "Ambiguous values for test field: '"-                            ++ x ++ "' and '" ++ y ++ "'"--instance Monoid TestSuiteInterface where-    mempty  =  TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))-    mappend = (Semi.<>)--instance Semigroup TestSuiteInterface where-    a <> (TestSuiteUnsupported _) = a-    _ <> b                        = b--emptyTestSuite :: TestSuite-emptyTestSuite = mempty---- | Does this package have any test suites?-hasTests :: PackageDescription -> Bool-hasTests = any (buildable . testBuildInfo) . testSuites---- | Get all the enabled test suites from a package.-enabledTests :: PackageDescription -> [TestSuite]-enabledTests = filter testEnabled . testSuites---- | Perform an action on each buildable 'TestSuite' in a package.-withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()-withTest pkg_descr f =-    mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr---- | Get all the module names from a test suite.-testModules :: TestSuite -> [ModuleName]-testModules test = (case testInterface test of-                     TestSuiteLibV09 _ m -> [m]-                     _                   -> [])-                ++ otherModules (testBuildInfo test)---- | The \"test-type\" field in the test suite stanza.----data TestType = TestTypeExe Version     -- ^ \"type: exitcode-stdio-x.y\"-              | TestTypeLib Version     -- ^ \"type: detailed-x.y\"-              | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary TestType--knownTestTypes :: [TestType]-knownTestTypes = [ TestTypeExe (Version [1,0] [])-                 , TestTypeLib (Version [0,9] []) ]--stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res-stdParse f = do-  cs   <- Parse.sepBy1 component (Parse.char '-')-  _    <- Parse.char '-'-  ver  <- parse-  let name = intercalate "-" cs-  return $! f ver (lowercase name)-  where-    component = do-      cs <- Parse.munch1 Char.isAlphaNum-      if all Char.isDigit cs then Parse.pfail else return cs-      -- each component must contain an alphabetic character, to avoid-      -- ambiguity in identifiers like foo-1 (the 1 is the version number).--instance Text TestType where-  disp (TestTypeExe ver)          = text "exitcode-stdio-" <> disp ver-  disp (TestTypeLib ver)          = text "detailed-"       <> disp ver-  disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver--  parse = stdParse $ \ver name -> case name of-    "exitcode-stdio" -> TestTypeExe ver-    "detailed"       -> TestTypeLib ver-    _                -> TestTypeUnknown name ver---testType :: TestSuite -> TestType-testType test = case testInterface test of-  TestSuiteExeV10 ver _         -> TestTypeExe ver-  TestSuiteLibV09 ver _         -> TestTypeLib ver-  TestSuiteUnsupported testtype -> testtype---- ------------------------------------------------------------------------------ The Benchmark type---- | A \"benchmark\" stanza in a cabal file.----data Benchmark = Benchmark {-        benchmarkName      :: String,-        benchmarkInterface :: BenchmarkInterface,-        benchmarkBuildInfo :: BuildInfo,-        benchmarkEnabled   :: Bool-        -- TODO: See TODO for 'testEnabled'.-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary Benchmark---- | The benchmark interfaces that are currently defined. Each--- benchmark must specify which interface it supports.------ More interfaces may be defined in future, either new revisions or--- totally new interfaces.----data BenchmarkInterface =--     -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark-     -- takes the form of an executable. It returns a zero exit code-     -- for success, non-zero for failure. The stdout and stderr-     -- channels may be logged. It takes no command line parameters-     -- and nothing on stdin.-     ---     BenchmarkExeV10 Version FilePath--     -- | A benchmark that does not conform to one of the above-     -- interfaces for the given reason (e.g. unknown benchmark type).-     ---   | BenchmarkUnsupported BenchmarkType-   deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary BenchmarkInterface--instance Monoid Benchmark where-    mempty = Benchmark {-        benchmarkName      = mempty,-        benchmarkInterface = mempty,-        benchmarkBuildInfo = mempty,-        benchmarkEnabled   = False-    }-    mappend = (Semi.<>)--instance Semigroup Benchmark where-    a <> b = Benchmark {-        benchmarkName      = combine' benchmarkName,-        benchmarkInterface = combine  benchmarkInterface,-        benchmarkBuildInfo = combine  benchmarkBuildInfo,-        benchmarkEnabled   = benchmarkEnabled a || benchmarkEnabled b-    }-        where combine   field = field a `mappend` field b-              combine' f = case (f a, f b) of-                        ("", x) -> x-                        (x, "") -> x-                        (x, y) -> error "Ambiguous values for benchmark field: '"-                            ++ x ++ "' and '" ++ y ++ "'"--instance Monoid BenchmarkInterface where-    mempty  =  BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))-    mappend = (Semi.<>)--instance Semigroup BenchmarkInterface where-    a <> (BenchmarkUnsupported _) = a-    _ <> b                        = b--emptyBenchmark :: Benchmark-emptyBenchmark = mempty---- | Does this package have any benchmarks?-hasBenchmarks :: PackageDescription -> Bool-hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks---- | Get all the enabled benchmarks from a package.-enabledBenchmarks :: PackageDescription -> [Benchmark]-enabledBenchmarks = filter benchmarkEnabled . benchmarks---- | Perform an action on each buildable 'Benchmark' in a package.-withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()-withBenchmark pkg_descr f =-    mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr---- | Get all the module names from a benchmark.-benchmarkModules :: Benchmark -> [ModuleName]-benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)---- | The \"benchmark-type\" field in the benchmark stanza.----data BenchmarkType = BenchmarkTypeExe Version-                     -- ^ \"type: exitcode-stdio-x.y\"-                   | BenchmarkTypeUnknown String Version-                     -- ^ Some unknown benchmark type e.g. \"type: foo\"-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BenchmarkType--knownBenchmarkTypes :: [BenchmarkType]-knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]--instance Text BenchmarkType where-  disp (BenchmarkTypeExe ver)          = text "exitcode-stdio-" <> disp ver-  disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver--  parse = stdParse $ \ver name -> case name of-    "exitcode-stdio" -> BenchmarkTypeExe ver-    _                -> BenchmarkTypeUnknown name ver---benchmarkType :: Benchmark -> BenchmarkType-benchmarkType benchmark = case benchmarkInterface benchmark of-  BenchmarkExeV10 ver _              -> BenchmarkTypeExe ver-  BenchmarkUnsupported benchmarktype -> benchmarktype---- ------------------------------------------------------------------------------ The BuildInfo type---- Consider refactoring into executable and library versions.-data BuildInfo = BuildInfo {-        buildable         :: Bool,      -- ^ component is buildable here-        buildTools        :: [Dependency], -- ^ tools needed to build this bit-        cppOptions        :: [String],  -- ^ options for pre-processing Haskell code-        ccOptions         :: [String],  -- ^ options for C compiler-        ldOptions         :: [String],  -- ^ options for linker-        pkgconfigDepends  :: [Dependency], -- ^ pkg-config packages that are used-        frameworks        :: [String], -- ^support frameworks for Mac OS X-        extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks.-        cSources          :: [FilePath],-        jsSources         :: [FilePath],-        hsSourceDirs      :: [FilePath], -- ^ where to look for the Haskell module hierarchy-        otherModules      :: [ModuleName], -- ^ non-exposed or non-main modules--        defaultLanguage   :: Maybe Language,-- ^ language used when not explicitly specified-        otherLanguages    :: [Language],    -- ^ other languages used within the package-        defaultExtensions :: [Extension],   -- ^ language extensions used by all modules-        otherExtensions   :: [Extension],   -- ^ other language extensions used within the package-        oldExtensions     :: [Extension],   -- ^ the old extensions field, treated same as 'defaultExtensions'--        extraLibs         :: [String], -- ^ what libraries to link with when compiling a program that uses your package-        extraGHCiLibs     :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi.-        extraLibDirs      :: [String],-        includeDirs       :: [FilePath], -- ^directories to find .h files-        includes          :: [FilePath], -- ^ The .h files to be found in includeDirs-        installIncludes   :: [FilePath], -- ^ .h files to install with the package-        options           :: [(CompilerFlavor,[String])],-        profOptions       :: [(CompilerFlavor,[String])],-        sharedOptions     :: [(CompilerFlavor,[String])],-        customFieldsBI    :: [(String,String)], -- ^Custom fields starting-                                                -- with x-, stored in a-                                                -- simple assoc-list.-        targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target-        targetBuildRenaming :: Map PackageName ModuleRenaming-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BuildInfo--instance Monoid BuildInfo where-  mempty = BuildInfo {-    buildable           = True,-    buildTools          = [],-    cppOptions          = [],-    ccOptions           = [],-    ldOptions           = [],-    pkgconfigDepends    = [],-    frameworks          = [],-    extraFrameworkDirs  = [],-    cSources            = [],-    jsSources           = [],-    hsSourceDirs        = [],-    otherModules        = [],-    defaultLanguage     = Nothing,-    otherLanguages      = [],-    defaultExtensions   = [],-    otherExtensions     = [],-    oldExtensions       = [],-    extraLibs           = [],-    extraGHCiLibs       = [],-    extraLibDirs        = [],-    includeDirs         = [],-    includes            = [],-    installIncludes     = [],-    options             = [],-    profOptions         = [],-    sharedOptions       = [],-    customFieldsBI      = [],-    targetBuildDepends  = [],-    targetBuildRenaming = Map.empty-  }-  mappend = (Semi.<>)--instance Semigroup BuildInfo where-  a <> b = BuildInfo {-    buildable           = buildable a && buildable b,-    buildTools          = combine    buildTools,-    cppOptions          = combine    cppOptions,-    ccOptions           = combine    ccOptions,-    ldOptions           = combine    ldOptions,-    pkgconfigDepends    = combine    pkgconfigDepends,-    frameworks          = combineNub frameworks,-    extraFrameworkDirs  = combineNub extraFrameworkDirs,-    cSources            = combineNub cSources,-    jsSources           = combineNub jsSources,-    hsSourceDirs        = combineNub hsSourceDirs,-    otherModules        = combineNub otherModules,-    defaultLanguage     = combineMby defaultLanguage,-    otherLanguages      = combineNub otherLanguages,-    defaultExtensions   = combineNub defaultExtensions,-    otherExtensions     = combineNub otherExtensions,-    oldExtensions       = combineNub oldExtensions,-    extraLibs           = combine    extraLibs,-    extraGHCiLibs       = combine    extraGHCiLibs,-    extraLibDirs        = combineNub extraLibDirs,-    includeDirs         = combineNub includeDirs,-    includes            = combineNub includes,-    installIncludes     = combineNub installIncludes,-    options             = combine    options,-    profOptions         = combine    profOptions,-    sharedOptions       = combine    sharedOptions,-    customFieldsBI      = combine    customFieldsBI,-    targetBuildDepends  = combineNub targetBuildDepends,-    targetBuildRenaming = combineMap targetBuildRenaming-  }-    where-      combine    field = field a `mappend` field b-      combineNub field = nub (combine field)-      combineMby field = field b `mplus` field a-      combineMap field = Map.unionWith mappend (field a) (field b)--emptyBuildInfo :: BuildInfo-emptyBuildInfo = mempty---- | The 'BuildInfo' for the library (if there is one and it's buildable), and--- all buildable executables, test suites and benchmarks.  Useful for gathering--- dependencies.-allBuildInfo :: PackageDescription -> [BuildInfo]-allBuildInfo pkg_descr = [ bi | lib <- libraries pkg_descr-                              , let bi = libBuildInfo lib-                              , buildable bi ]-                      ++ [ bi | exe <- executables pkg_descr-                              , let bi = buildInfo exe-                              , buildable bi ]-                      ++ [ bi | tst <- testSuites pkg_descr-                              , let bi = testBuildInfo tst-                              , buildable bi-                              , testEnabled tst ]-                      ++ [ bi | tst <- benchmarks pkg_descr-                              , let bi = benchmarkBuildInfo tst-                              , buildable bi-                              , benchmarkEnabled tst ]-  --FIXME: many of the places where this is used, we actually want to look at-  --       unbuildable bits too, probably need separate functions---- | The 'Language's used by this component----allLanguages :: BuildInfo -> [Language]-allLanguages bi = maybeToList (defaultLanguage bi)-               ++ otherLanguages bi---- | The 'Extension's that are used somewhere by this component----allExtensions :: BuildInfo -> [Extension]-allExtensions bi = usedExtensions bi-                ++ otherExtensions bi---- | The 'Extensions' that are used by all modules in this component----usedExtensions :: BuildInfo -> [Extension]-usedExtensions bi = oldExtensions bi-                 ++ defaultExtensions bi---- Libraries live in a separate namespace, so must distinguish-data ComponentName = CLibName   String-                   | CExeName   String-                   | CTestName  String-                   | CBenchName String-                   deriving (Eq, Generic, Ord, Read, Show)--instance Binary ComponentName--defaultLibName :: PackageIdentifier -> ComponentName-defaultLibName pid = CLibName (display (pkgName pid))--type HookedBuildInfo = [(ComponentName, BuildInfo)]--emptyHookedBuildInfo :: HookedBuildInfo-emptyHookedBuildInfo = []---- |Select options for a particular Haskell compiler.-hcOptions :: CompilerFlavor -> BuildInfo -> [String]-hcOptions = lookupHcOptions options--hcProfOptions :: CompilerFlavor -> BuildInfo -> [String]-hcProfOptions = lookupHcOptions profOptions--hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String]-hcSharedOptions = lookupHcOptions sharedOptions--lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])])-                -> CompilerFlavor -> BuildInfo -> [String]-lookupHcOptions f hc bi = [ opt | (hc',opts) <- f bi-                          , hc' == hc-                          , opt <- opts ]---- --------------------------------------------------------------- * Source repos--- ---------------------------------------------------------------- | Information about the source revision control system for a package.------ When specifying a repo it is useful to know the meaning or intention of the--- information as doing so enables automation. There are two obvious common--- purposes: one is to find the repo for the latest development version, the--- other is to find the repo for this specific release. The 'ReopKind'--- specifies which one we mean (or another custom one).------ A package can specify one or the other kind or both. Most will specify just--- a head repo but some may want to specify a repo to reconstruct the sources--- for this package release.------ The required information is the 'RepoType' which tells us if it's using--- 'Darcs', 'Git' for example. The 'repoLocation' and other details are--- interpreted according to the repo type.----data SourceRepo = SourceRepo {-  -- | The kind of repo. This field is required.-  repoKind     :: RepoKind,--  -- | The type of the source repository system for this repo, eg 'Darcs' or-  -- 'Git'. This field is required.-  repoType     :: Maybe RepoType,--  -- | The location of the repository. For most 'RepoType's this is a URL.-  -- This field is required.-  repoLocation :: Maybe String,--  -- | 'CVS' can put multiple \"modules\" on one server and requires a-  -- module name in addition to the location to identify a particular repo.-  -- Logically this is part of the location but unfortunately has to be-  -- specified separately. This field is required for the 'CVS' 'RepoType' and-  -- should not be given otherwise.-  repoModule   :: Maybe String,--  -- | The name or identifier of the branch, if any. Many source control-  -- systems have the notion of multiple branches in a repo that exist in the-  -- same location. For example 'Git' and 'CVS' use this while systems like-  -- 'Darcs' use different locations for different branches. This field is-  -- optional but should be used if necessary to identify the sources,-  -- especially for the 'RepoThis' repo kind.-  repoBranch   :: Maybe String,--  -- | The tag identify a particular state of the repository. This should be-  -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.-  ---  repoTag      :: Maybe String,--  -- | Some repositories contain multiple projects in different subdirectories-  -- This field specifies the subdirectory where this packages sources can be-  -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted-  -- relative to the root of the repository. This field is optional. If not-  -- given the default is \".\" ie no subdirectory.-  repoSubdir   :: Maybe FilePath-}-  deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary SourceRepo---- | What this repo info is for, what it represents.----data RepoKind =-    -- | The repository for the \"head\" or development version of the project.-    -- This repo is where we should track the latest development activity or-    -- the usual repo people should get to contribute patches.-    RepoHead--    -- | The repository containing the sources for this exact package version-    -- or release. For this kind of repo a tag should be given to give enough-    -- information to re-create the exact sources.-  | RepoThis--  | RepoKindUnknown String-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--instance Binary RepoKind---- | An enumeration of common source control systems. The fields used in the--- 'SourceRepo' depend on the type of repo. The tools and methods used to--- obtain and track the repo depend on the repo type.----data RepoType = Darcs | Git | SVN | CVS-              | Mercurial | GnuArch | Bazaar | Monotone-              | OtherRepoType String-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--instance Binary RepoType--knownRepoTypes :: [RepoType]-knownRepoTypes = [Darcs, Git, SVN, CVS-                 ,Mercurial, GnuArch, Bazaar, Monotone]--repoTypeAliases :: RepoType -> [String]-repoTypeAliases Bazaar    = ["bzr"]-repoTypeAliases Mercurial = ["hg"]-repoTypeAliases GnuArch   = ["arch"]-repoTypeAliases _         = []--instance Text RepoKind where-  disp RepoHead                = Disp.text "head"-  disp RepoThis                = Disp.text "this"-  disp (RepoKindUnknown other) = Disp.text other--  parse = do-    name <- ident-    return $ case lowercase name of-      "head" -> RepoHead-      "this" -> RepoThis-      _      -> RepoKindUnknown name--instance Text RepoType where-  disp (OtherRepoType other) = Disp.text other-  disp other                 = Disp.text (lowercase (show other))-  parse = fmap classifyRepoType ident--classifyRepoType :: String -> RepoType-classifyRepoType s =-  fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap-  where-    repoTypeMap = [ (name, repoType')-                  | repoType' <- knownRepoTypes-                  , name <- display repoType' : repoTypeAliases repoType' ]--ident :: Parse.ReadP r String-ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')--lowercase :: String -> String-lowercase = map Char.toLower---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription-updatePackageDescription hooked_bis p-  = p{ executables = updateMany (CExeName . exeName)         updateExecutable (executables p)-     , libraries   = updateMany (CLibName . libName)         updateLibrary    (libraries   p)-     , benchmarks  = updateMany (CBenchName . benchmarkName) updateBenchmark  (benchmarks p)-     , testSuites  = updateMany (CTestName . testName)       updateTestSuite  (testSuites p)-     }-    where-      updateMany :: (a -> ComponentName) -- ^ get 'ComponentName' from @a@-                 -> (BuildInfo -> a -> a) -- ^ @updateExecutable@, @updateLibrary@, etc-                 -> [a]          -- ^list of components to update-                 -> [a]          -- ^list with updated components-      updateMany name update cs' = foldr (updateOne name update) cs' hooked_bis--      updateOne :: (a -> ComponentName) -- ^ get 'ComponentName' from @a@-                -> (BuildInfo -> a -> a) -- ^ @updateExecutable@, @updateLibrary@, etc-                -> (ComponentName, BuildInfo) -- ^(name, new buildinfo)-                -> [a]        -- ^list of components to update-                -> [a]        -- ^list with name component updated-      updateOne _ _ _                 []         = []-      updateOne name_sel update hooked_bi'@(name,bi) (c:cs)-        | name_sel c == name ||-          -- Special case: an empty name means "please update the BuildInfo for-          -- the public library, i.e. the one with the same name as the-          -- package."  See 'parseHookedBuildInfo'.-          name == CLibName "" && name_sel c == defaultLibName (package p)-          = update bi c : cs-        | otherwise          = c : updateOne name_sel update hooked_bi' cs--      updateExecutable bi exe = exe{buildInfo    = bi `mappend` buildInfo exe}-      updateLibrary    bi lib = lib{libBuildInfo = bi `mappend` libBuildInfo lib}-      updateBenchmark  bi ben = ben{benchmarkBuildInfo = bi `mappend` benchmarkBuildInfo ben}-      updateTestSuite  bi test = test{testBuildInfo = bi `mappend` testBuildInfo test}---- ------------------------------------------------------------------------------ The GenericPackageDescription type--data GenericPackageDescription =-    GenericPackageDescription {-        packageDescription :: PackageDescription,-        genPackageFlags       :: [Flag],-        condLibraries      :: [(String, CondTree ConfVar [Dependency] Library)],-        condExecutables    :: [(String, CondTree ConfVar [Dependency] Executable)],-        condTestSuites     :: [(String, CondTree ConfVar [Dependency] TestSuite)],-        condBenchmarks     :: [(String, CondTree ConfVar [Dependency] Benchmark)]-      }-    deriving (Show, Eq, Typeable, Data, Generic)--instance Package GenericPackageDescription where-  packageId = packageId . packageDescription--instance Binary GenericPackageDescription---- | A flag can represent a feature to be included, or a way of linking---   a target against its dependencies, or in fact whatever you can think of.-data Flag = MkFlag-    { flagName        :: FlagName-    , flagDescription :: String-    , flagDefault     :: Bool-    , flagManual      :: Bool-    }-    deriving (Show, Eq, Typeable, Data, Generic)--instance Binary Flag---- | A 'FlagName' is the name of a user-defined configuration flag-newtype FlagName = FlagName String-    deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)--instance Binary FlagName---- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to--- 'Bool' flag values. It represents the flags chosen by the user or--- discovered during configuration. For example @--flags=foo --flags=-bar@--- becomes @[("foo", True), ("bar", False)]@----type FlagAssignment = [(FlagName, Bool)]---- | A @ConfVar@ represents the variable type used.-data ConfVar = OS OS-             | Arch Arch-             | Flag FlagName-             | Impl CompilerFlavor VersionRange-    deriving (Eq, Show, Typeable, Data, Generic)--instance Binary ConfVar---- | A boolean expression parameterized over the variable type used.-data Condition c = Var c-                 | Lit Bool-                 | CNot (Condition c)-                 | COr (Condition c) (Condition c)-                 | CAnd (Condition c) (Condition c)-    deriving (Show, Eq, Typeable, Data, Generic)--cNot :: Condition a -> Condition a-cNot (Lit b)  = Lit (not b)-cNot (CNot c) = c-cNot c        = CNot c--instance Functor Condition where-  f `fmap` Var c    = Var (f c)-  _ `fmap` Lit c    = Lit c-  f `fmap` CNot c   = CNot (fmap f c)-  f `fmap` COr c d  = COr  (fmap f c) (fmap f d)-  f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d)--instance Foldable Condition where-  f `foldMap` Var c    = f c-  _ `foldMap` Lit _    = mempty-  f `foldMap` CNot c   = Fold.foldMap f c-  f `foldMap` COr c d  = foldMap f c `mappend` foldMap f d-  f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d--instance Traversable Condition where-  f `traverse` Var c    = Var `fmap` f c-  _ `traverse` Lit c    = pure $ Lit c-  f `traverse` CNot c   = CNot `fmap` Trav.traverse f c-  f `traverse` COr c d  = COr  `fmap` traverse f c <*> traverse f d-  f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d--instance Applicative Condition where-  pure  = Var-  (<*>) = ap--instance Monad Condition where-  return = AP.pure-  -- Terminating cases-  (>>=) (Lit x) _ = Lit x-  (>>=) (Var x) f = f x-  -- Recursing cases-  (>>=) (CNot  x  ) f = CNot (x >>= f)-  (>>=) (COr   x y) f = COr  (x >>= f) (y >>= f)-  (>>=) (CAnd  x y) f = CAnd (x >>= f) (y >>= f)--instance Monoid (Condition a) where-  mempty = Lit False-  mappend = (Semi.<>)--instance Semigroup (Condition a) where-  (<>) = COr--instance Alternative Condition where-  empty = mempty-  (<|>) = mappend--instance MonadPlus Condition where-  mzero = mempty-  mplus = mappend--instance Binary c => Binary (Condition c)--data CondTree v c a = CondNode-    { condTreeData        :: a-    , condTreeConstraints :: c-    , condTreeComponents  :: [( Condition v-                              , CondTree v c a-                              , Maybe (CondTree v c a))]-    }-    deriving (Show, Eq, Typeable, Data, Generic)--instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)+-- Backwards compatibility reexport of everything you need to know+-- about @.cabal@ files.++module Distribution.PackageDescription (+        -- * Package descriptions+        PackageDescription(..),+        emptyPackageDescription,+        specVersion,+        descCabalVersion,+        BuildType(..),+        knownBuildTypes,+        allLibraries,++        -- ** Renaming (syntactic)+        ModuleRenaming(..),+        defaultRenaming,++        -- ** Libraries+        Library(..),+        ModuleReexport(..),+        emptyLibrary,+        withLib,+        hasPublicLib,+        hasLibs,+        explicitLibModules,+        libModulesAutogen,+        libModules,++        -- ** Executables+        Executable(..),+        emptyExecutable,+        withExe,+        hasExes,+        exeModules,+        exeModulesAutogen,++        -- * Tests+        TestSuite(..),+        TestSuiteInterface(..),+        TestType(..),+        testType,+        knownTestTypes,+        emptyTestSuite,+        hasTests,+        withTest,+        testModules,+        testModulesAutogen,++        -- * Benchmarks+        Benchmark(..),+        BenchmarkInterface(..),+        BenchmarkType(..),+        benchmarkType,+        knownBenchmarkTypes,+        emptyBenchmark,+        hasBenchmarks,+        withBenchmark,+        benchmarkModules,+        benchmarkModulesAutogen,++        -- * Build information+        BuildInfo(..),+        emptyBuildInfo,+        allBuildInfo,+        allLanguages,+        allExtensions,+        usedExtensions,+        hcOptions,+        hcProfOptions,+        hcSharedOptions,++        -- ** Supplementary build information+        ComponentName(..),+        defaultLibName,+        HookedBuildInfo,+        emptyHookedBuildInfo,+        updatePackageDescription,++        -- * package configuration+        GenericPackageDescription(..),+        Flag(..), emptyFlag,+        FlagName, mkFlagName, unFlagName,+        FlagAssignment,+        CondTree(..), ConfVar(..), Condition(..),+        cNot, cAnd, cOr,++        -- * Source repositories+        SourceRepo(..),+        RepoKind(..),+        RepoType(..),+        knownRepoTypes,+        emptySourceRepo,++        -- * Custom setup build information+        SetupBuildInfo(..),+  ) where++import Prelude ()+--import Distribution.Compat.Prelude++import Distribution.Types.Library+import Distribution.Types.TestSuite+import Distribution.Types.Executable+import Distribution.Types.Benchmark+import Distribution.Types.TestType+import Distribution.Types.TestSuiteInterface+import Distribution.Types.BenchmarkType+import Distribution.Types.BenchmarkInterface+import Distribution.Types.ModuleRenaming+import Distribution.Types.ModuleReexport+import Distribution.Types.BuildInfo+import Distribution.Types.SetupBuildInfo+import Distribution.Types.BuildType+import Distribution.Types.GenericPackageDescription+import Distribution.Types.PackageDescription+import Distribution.Types.ComponentName+import Distribution.Types.HookedBuildInfo+import Distribution.Types.SourceRepo
cabal/Cabal/Distribution/PackageDescription/Check.hs view
@@ -34,38 +34,40 @@         checkPackageFileNames,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.PackageDescription import Distribution.PackageDescription.Configuration import Distribution.Compiler import Distribution.System import Distribution.License+import Distribution.Simple.BuildPaths (autogenPathsModuleName) import Distribution.Simple.CCompiler+import Distribution.Types.ComponentRequestedSpec import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.Version import Distribution.Package import Distribution.Text import Language.Haskell.Extension -import Data.Maybe-         ( isNothing, isJust, catMaybes, mapMaybe, fromMaybe )-import Data.List  (sort, group, isPrefixOf, nub, find)-import Control.Monad-         ( filterM, liftM )+import Control.Monad (mapM)+import Data.List  (group) import qualified System.Directory as System          ( doesFileExist, doesDirectoryExist ) import qualified Data.Map as Map  import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>), (<+>))+import Text.PrettyPrint ((<+>))  import qualified System.Directory (getDirectoryContents) import System.IO (openBinaryFile, IOMode(ReadMode), hGetContents) import System.FilePath-         ( (</>), takeExtension, isRelative, isAbsolute-         , splitDirectories,  splitPath, splitExtension )+         ( (</>), takeExtension, splitDirectories, splitPath, splitExtension ) import System.FilePath.Windows as FilePath.Windows          ( isValid ) + -- | Results of some kind of failed package check. -- -- There are a range of severities, from merely dubious to totally insane.@@ -112,7 +114,7 @@ checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck                  -> Maybe PackageCheck checkSpecVersion pkg specver cond pc-  | specVersion pkg >= Version specver [] = Nothing+  | specVersion pkg >= mkVersion specver  = Nothing   | otherwise                             = check cond pc  -- ------------------------------------------------------------@@ -165,28 +167,45 @@ checkSanity pkg =   catMaybes [ -    check (null . (\(PackageName n) -> n) . packageName $ pkg) $+    check (null . unPackageName . packageName $ pkg) $       PackageBuildImpossible "No 'name' field." -  , check (null . versionBranch . packageVersion $ pkg) $+  , check (nullVersion == packageVersion pkg) $       PackageBuildImpossible "No 'version' field."    , check (all ($ pkg) [ null . executables                        , null . testSuites                        , null . benchmarks-                       , null . libraries ]) $+                       , null . allLibraries+                       , null . foreignLibs ]) $       PackageBuildImpossible         "No executables, libraries, tests, or benchmarks found. Nothing to do." +  , check (any isNothing (map libName $ subLibraries pkg)) $+      PackageBuildImpossible $ "Found one or more unnamed internal libraries. "+        ++ "Only the non-internal library can have the same name as the package."+   , check (not (null duplicateNames)) $-      PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames-        ++ ". The name of every library, executable, test suite, and benchmark section in"+      PackageBuildImpossible $ "Duplicate sections: "+        ++ commaSep (map unUnqualComponentName duplicateNames)+        ++ ". The name of every library, executable, test suite,"+        ++ " and benchmark section in"         ++ " the package must be unique."++  -- NB: but it's OK for executables to have the same name!+  -- TODO shouldn't need to compare on the string level+  , check (any (== display (packageName pkg)) (display <$> subLibNames)) $+      PackageBuildImpossible $ "Illegal internal library name "+        ++ display (packageName pkg)+        ++ ". Internal libraries cannot have the same name as the package."+        ++ " Maybe you wanted a non-internal library?"+        ++ " If so, rewrite the section stanza"+        ++ " from 'library: '" ++ display (packageName pkg) ++ "' to 'library'."   ]   --TODO: check for name clashes case insensitively: windows file systems cannot   --cope. -  ++ concatMap (checkLibrary    pkg) (libraries pkg)+  ++ concatMap (checkLibrary    pkg) (allLibraries pkg)   ++ concatMap (checkExecutable pkg) (executables pkg)   ++ concatMap (checkTestSuite  pkg) (testSuites pkg)   ++ concatMap (checkBenchmark  pkg) (benchmarks pkg)@@ -200,15 +219,14 @@         ++ "tool only supports up to version " ++ display cabalVersion ++ "."   ]   where-    -- The public library gets special dispensation, because it+    -- The public 'library' gets special dispensation, because it     -- is common practice to export a library and name the executable-    -- the same as the package.  We always put the public library-    -- in the top-level directory in dist, so no conflicts either.-    libNames = filter (/= unPackageName (packageName pkg)) . map libName $ libraries pkg+    -- the same as the package.+    subLibNames = catMaybes . map libName $ subLibraries pkg     exeNames = map exeName $ executables pkg     testNames = map testName $ testSuites pkg     bmNames = map benchmarkName $ benchmarks pkg-    duplicateNames = dups $ libNames ++ exeNames ++ testNames ++ bmNames+    duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames  checkLibrary :: PackageDescription -> Library -> [PackageCheck] checkLibrary pkg lib =@@ -219,25 +237,37 @@             "Duplicate modules in library: "          ++ commaSep (map display moduleDuplicates) -    -- check use of required-signatures/exposed-signatures sections-  , checkVersion [1,21] (not (null (requiredSignatures lib))) $-      PackageDistInexcusable $-           "To use the 'required-signatures' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.21'."+  -- TODO: This check is bogus if a required-signature was passed through+  , check (null (explicitLibModules lib) && null (reexportedModules lib)) $+      PackageDistSuspiciousWarn $+           "Library " ++ (case libName lib of+                            Nothing -> ""+                            Just n -> display n+                            ) ++ "does not expose any modules" -  , checkVersion [1,21] (not (null (exposedSignatures lib))) $+    -- check use of signatures sections+  , checkVersion [1,25] (not (null (signatures lib))) $       PackageDistInexcusable $-           "To use the 'exposed-signatures' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.21'."+           "To use the 'signatures' field the package needs to specify "+        ++ "at least 'cabal-version: >= 1.25'."++    -- check that all autogen-modules appear on other-modules or exposed-modules+  , check+      (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $+      PackageBuildImpossible $+           "An 'autogen-module' is neither on 'exposed-modules' or "+        ++ "'other-modules'."+   ]    where     checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck     checkVersion ver cond pc-      | specVersion pkg >= Version ver []      = Nothing+      | specVersion pkg >= mkVersion ver       = Nothing       | otherwise                              = check cond pc -    moduleDuplicates = dups (libModules lib +++    -- TODO: not sure if this check is always right in Backpack+    moduleDuplicates = dups (explicitLibModules lib ++                              map moduleReexportName (reexportedModules lib))  checkExecutable :: PackageDescription -> Executable -> [PackageCheck]@@ -246,7 +276,7 @@      check (null (modulePath exe)) $       PackageBuildImpossible $-        "No 'main-is' field found for executable " ++ exeName exe+        "No 'main-is' field found for executable " ++ display (exeName exe)    , check (not (null (modulePath exe))        && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $@@ -264,8 +294,16 @@    , check (not (null moduleDuplicates)) $        PackageBuildImpossible $-            "Duplicate modules in executable '" ++ exeName exe ++ "': "+            "Duplicate modules in executable '" ++ display (exeName exe) ++ "': "          ++ commaSep (map display moduleDuplicates)++    -- check that all autogen-modules appear on other-modules+  , check+      (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $+      PackageBuildImpossible $+           "On executable '" ++ display (exeName exe) ++ "' an 'autogen-module' is not "+        ++ "on 'other-modules'"+   ]   where     moduleDuplicates = dups (exeModules exe)@@ -290,7 +328,7 @@    , check (not $ null moduleDuplicates) $       PackageBuildImpossible $-           "Duplicate modules in test suite '" ++ testName test ++ "': "+           "Duplicate modules in test suite '" ++ display (testName test) ++ "': "         ++ commaSep (map display moduleDuplicates)    , check mainIsWrongExt $@@ -303,6 +341,16 @@       PackageDistInexcusable $            "The package uses a C/C++/obj-C source file for the 'main-is' field. "         ++ "To use this feature you must specify 'cabal-version: >= 1.18'."++    -- check that all autogen-modules appear on other-modules+  , check+      (not $ and $ map+        (flip elem (testModules test))+        (testModulesAutogen test)+      ) $+      PackageBuildImpossible $+           "On test suite '" ++ display (testName test) ++ "' an 'autogen-module' is not "+        ++ "on 'other-modules'"   ]   where     moduleDuplicates = dups $ testModules test@@ -335,13 +383,23 @@    , check (not $ null moduleDuplicates) $       PackageBuildImpossible $-           "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "+           "Duplicate modules in benchmark '" ++ display (benchmarkName bm) ++ "': "         ++ commaSep (map display moduleDuplicates)    , check mainIsWrongExt $       PackageBuildImpossible $            "The 'main-is' field must specify a '.hs' or '.lhs' file "         ++ "(even if it is generated by a preprocessor)."++    -- check that all autogen-modules appear on other-modules+  , check+      (not $ and $ map+        (flip elem (benchmarkModules bm))+        (benchmarkModulesAutogen bm)+      ) $+      PackageBuildImpossible $+             "On benchmark '" ++ display (benchmarkName bm) ++ "' an 'autogen-module' is "+          ++ "not on 'other-modules'"   ]   where     moduleDuplicates = dups $ benchmarkModules bm@@ -441,6 +499,22 @@       PackageDistSuspicious         "The 'synopsis' field is rather long (max 80 chars is recommended)." +    -- See also https://github.com/haskell/cabal/pull/3479+  , check (not (null (description pkg))+           && length (description pkg) <= length (synopsis pkg)) $+      PackageDistSuspicious $+           "The 'description' field should be longer than the 'synopsis' "+        ++ "field. "+        ++ "It's useful to provide an informative 'description' to allow "+        ++ "Haskell programmers who have never heard about your package to "+        ++ "understand the purpose of your package. "+        ++ "The 'description' field content is typically shown by tooling "+        ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which "+        ++ "serves as a headline. "+        ++ "Please refer to <https://www.haskell.org/"+        ++ "cabal/users-guide/developing-packages.html#package-properties>"+        ++ " for more details."+     -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"   , check (not (null testedWithImpossibleRanges)) $       PackageDistInexcusable $@@ -450,6 +524,14 @@         ++ "different versions of the same compiler use multiple entries, "         ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "         ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."++  , check (not (null buildDependsRangeOnInternalLibrary)) $+      PackageBuildWarning $+           "The package has a version range for a dependency on an "+        ++ "internal library: "+        ++ commaSep (map display buildDependsRangeOnInternalLibrary)+        ++ ". This version range has no semantic meaning and can be "+        ++ "removed."   ]   where     unknownCompilers  = [ name | (OtherCompiler name, _) <- testedWith pkg ]@@ -468,11 +550,22 @@              , name `elem` map display knownLanguages ]      testedWithImpossibleRanges =-      [ Dependency (PackageName (display compiler)) vr+      [ Dependency (mkPackageName (display compiler)) vr       | (compiler, vr) <- testedWith pkg       , isNoVersion vr ] +    internalLibraries =+        map (maybe (packageName pkg) (unqualComponentNameToPackageName) . libName)+            (allLibraries pkg)+    buildDependsRangeOnInternalLibrary =+      [ dep+      | bi <- allBuildInfo pkg+      , dep@(Dependency name versionRange) <- targetBuildDepends bi+      , not (isAnyVersion versionRange)+      , name `elem` internalLibraries+      ] + checkLicense :: PackageDescription -> [PackageCheck] checkLicense pkg =   catMaybes [@@ -558,7 +651,7 @@         ++ "field. It should specify the tag corresponding to this version "         ++ "or release of the package." -  , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $+  , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $       PackageDistInexcusable         "The 'subdir' field of a source-repository must be a relative path."   ]@@ -692,7 +785,8 @@    where     all_ghc_options    = concatMap get_ghc_options (allBuildInfo pkg)-    lib_ghc_options    = concatMap (get_ghc_options . libBuildInfo) (libraries pkg)+    lib_ghc_options    = concatMap (get_ghc_options . libBuildInfo)+                         (allLibraries pkg)     get_ghc_options bi = hcOptions GHC bi ++ hcProfOptions GHC bi                          ++ hcSharedOptions GHC bi @@ -781,7 +875,8 @@   where all_cppOptions = [ opts | bi <- allBuildInfo pkg                                 , opts <- cppOptions bi ] -checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck+checkAlternatives :: String -> String -> [(String, String)]+                  -> Maybe PackageCheck checkAlternatives badField goodField flags =   check (not (null badFlags)) $     PackageBuildWarning $@@ -802,7 +897,7 @@   [ PackageDistInexcusable $       quote (kind ++ ": " ++ path) ++ " is an absolute path."   | (path, kind) <- relPaths-  , isAbsolute path ]+  , isAbsoluteOnAnyPlatform path ]   ++   [ PackageDistInexcusable $          quote (kind ++ ": " ++ path) ++ " points inside the 'dist' "@@ -867,7 +962,7 @@   catMaybes [      -- check syntax of cabal-version field-    check (specVersion pkg >= Version [1,10] []+    check (specVersion pkg >= mkVersion [1,10]            && not simpleSpecVersionRangeSyntax) $       PackageBuildWarning $            "Packages relying on Cabal 1.10 or later must only specify a "@@ -875,7 +970,7 @@         ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."      -- check syntax of cabal-version field-  , check (specVersion pkg < Version [1,9] []+  , check (specVersion pkg < mkVersion [1,9]            && not simpleSpecVersionRangeSyntax) $       PackageDistSuspicious $            "It is recommended that the 'cabal-version' field only specify a "@@ -906,7 +1001,7 @@            "To use the 'default-language' field the package needs to specify "         ++ "at least 'cabal-version: >= 1.10'." -  , check (specVersion pkg >= Version [1,10] []+  , check (specVersion pkg >= mkVersion [1,10]            && (any isNothing (buildInfoField defaultLanguage))) $       PackageBuildWarning $            "Packages using 'cabal-version: >= 1.10' must specify the "@@ -915,30 +1010,30 @@         ++ "different modules then list the other ones in the "         ++ "'other-languages' field." +  , checkVersion [1,18]+    (not . null $ extraDocFiles pkg) $+      PackageDistInexcusable $+           "To use the 'extra-doc-files' field the package needs to specify "+        ++ "at least 'cabal-version: >= 1.18'."+   , checkVersion [1,23]-    (case libraries pkg of-        [lib] -> libName lib /= unPackageName (packageName pkg)-        [] -> False-        _ -> True) $+    (not (null (subLibraries pkg))) $       PackageDistInexcusable $            "To use multiple 'library' sections or a named library section "         ++ "the package needs to specify at least 'cabal-version >= 1.23'."      -- check use of reexported-modules sections   , checkVersion [1,21]-    (any (not.null.reexportedModules) (libraries pkg)) $+    (any (not.null.reexportedModules) (allLibraries pkg)) $       PackageDistInexcusable $            "To use the 'reexported-module' field the package needs to specify "         ++ "at least 'cabal-version: >= 1.21'."      -- check use of thinning and renaming-  , checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $+  , checkVersion [1,25] usesBackpackIncludes $       PackageDistInexcusable $-           "The package uses "-        ++ "thinning and renaming in the 'build-depends' field: "-        ++ commaSep (map display depsUsingThinningRenamingSyntax)-        ++ ". To use this new syntax, the package needs to specify at least"-        ++ "'cabal-version: >= 1.21'."+           "To use the 'mixins' field the package needs to specify "+        ++ "at least 'cabal-version: >= 1.25'."      -- check use of 'extra-framework-dirs' field   , checkVersion [1,23] (any (not . null) (buildInfoField extraFrameworkDirs)) $@@ -955,7 +1050,7 @@         ++ "at least 'cabal-version: >= 1.10'."      -- check use of extensions field-  , check (specVersion pkg >= Version [1,10] []+  , check (specVersion pkg >= mkVersion [1,10]            && (any (not . null) (buildInfoField oldExtensions))) $       PackageBuildWarning $            "For packages using 'cabal-version: >= 1.10' the 'extensions' "@@ -986,6 +1081,18 @@            [ display (Dependency name (eliminateWildcardSyntax versionRange))            | Dependency name versionRange <- depsUsingWildcardSyntax ] +    -- check use of "build-depends: foo ^>= 1.2.3" syntax+  , checkVersion [2,0] (not (null depsUsingMajorBoundSyntax)) $+      PackageDistInexcusable $+           "The package uses major bounded version syntax in the "+        ++ "'build-depends' field: "+        ++ commaSep (map display depsUsingMajorBoundSyntax)+        ++ ". To use this new syntax the package need to specify at least "+        ++ "'cabal-version: >= 2.0'. Alternatively, if broader compatibility "+        ++ "is important then use: " ++ commaSep+           [ display (Dependency name (eliminateMajorBoundSyntax versionRange))+           | Dependency name versionRange <- depsUsingMajorBoundSyntax ]+     -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax   , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $       PackageDistInexcusable $@@ -1059,7 +1166,7 @@         ++ "compatibility with earlier Cabal versions then you may be able to "         ++ "use an equivalent compiler-specific flag." -  , check (specVersion pkg >= Version [1,23] []+  , check (specVersion pkg >= mkVersion [1,23]            && isNothing (setupBuildInfo pkg)            && buildType pkg == Just Custom) $       PackageBuildWarning $@@ -1069,7 +1176,7 @@         ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "         ++ "so a simple example would be 'setup-depends: base, Cabal'." -  , check (specVersion pkg < Version [1,23] []+  , check (specVersion pkg < mkVersion [1,23]            && isNothing (setupBuildInfo pkg)            && buildType pkg == Just Custom) $       PackageDistSuspiciousWarn $@@ -1079,6 +1186,18 @@         ++ "that specifies the dependencies of the Setup.hs script itself. "         ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "         ++ "so a simple example would be 'setup-depends: base, Cabal'."++  , check (specVersion pkg >= mkVersion [1,25]+           && elem (autogenPathsModuleName pkg) allModuleNames+           && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $+      PackageDistInexcusable $+           "Packages using 'cabal-version: >= 1.25' and the autogenerated "+        ++ "module Paths_* must include it also on the 'autogen-modules' field "+        ++ "besides 'exposed-modules' and 'other-modules'. This specifies that "+        ++ "the module does not come with the package and is generated on "+        ++ "setup. Modules built with a custom Setup.hs script also go here "+        ++ "to ensure that commands like sdist don't fail."+   ]   where     -- Perform a check on packages that use a version of the spec less than@@ -1087,7 +1206,7 @@     -- version.     checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck     checkVersion ver cond pc-      | specVersion pkg >= Version ver []      = Nothing+      | specVersion pkg >= mkVersion ver       = Nothing       | otherwise                              = check cond pc      buildInfoField field         = map field (allBuildInfo pkg)@@ -1102,7 +1221,7 @@               , usesNewVersionRangeSyntax vr ]      testedWithVersionRangeExpressions =-        [ Dependency (PackageName (display compiler)) vr+        [ Dependency (mkPackageName (display compiler)) vr         | (compiler, vr) <- testedWith pkg         , usesNewVersionRangeSyntax vr ] @@ -1115,6 +1234,7 @@                       (\_ -> True)  -- >=                       (\_ -> False)                       (\_ _ -> False)+                      (\_ _ -> False)                       (\_ _ -> False) (\_ _ -> False)                       id)                (specVersionRaw pkg)@@ -1132,22 +1252,20 @@           (const 1) (const 1)           (const 1) (const 1)           (const (const 1))+          (const (const 1))           (+) (+)           (const 3) -- uses new ()'s syntax      depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg                                     , usesWildcardSyntax vr ] -    -- TODO: If the user writes build-depends: foo with (), this is-    -- indistinguishable from build-depends: foo, so there won't be an-    -- error even though there should be-    depsUsingThinningRenamingSyntax =-      [ name-      | bi <- allBuildInfo pkg-      , (name, _) <- Map.toList (targetBuildRenaming bi) ]+    depsUsingMajorBoundSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg+                                  , usesMajorBoundSyntax vr ] +    usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg)+     testedWithUsingWildcardSyntax =-      [ Dependency (PackageName (display compiler)) vr+      [ Dependency (mkPackageName (display compiler)) vr       | (compiler, vr) <- testedWith pkg       , usesWildcardSyntax vr ] @@ -1158,16 +1276,40 @@         (const False) (const False)         (const False) (const False)         (\_ _ -> True) -- the wildcard case+        (\_ _ -> False)         (||) (||) id +    -- NB: this eliminates both, WildcardVersion and MajorBoundVersion+    -- because when WildcardVersion is not support, neither is MajorBoundVersion     eliminateWildcardSyntax =       foldVersionRange'         anyVersion thisVersion         laterVersion earlierVersion         orLaterVersion orEarlierVersion         (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))+        (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))         intersectVersionRanges unionVersionRanges id +    usesMajorBoundSyntax :: VersionRange -> Bool+    usesMajorBoundSyntax =+      foldVersionRange'+        False (const False)+        (const False) (const False)+        (const False) (const False)+        (\_ _ -> False)+        (\_ _ -> True) -- MajorBoundVersion+        (||) (||) id++    eliminateMajorBoundSyntax =+      foldVersionRange'+        anyVersion thisVersion+        laterVersion earlierVersion+        orLaterVersion orEarlierVersion+        (\v _ -> withinVersion v)+        (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))+        intersectVersionRanges unionVersionRanges id++     compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4                      , PublicDomain, AllRightsReserved                      , UnspecifiedLicense, OtherLicense ]@@ -1213,6 +1355,15 @@       map DisableExtension       [MonoPatBinds] +    allModuleNames =+         (case library pkg of+           Nothing -> []+           (Just lib) -> explicitLibModules lib+         )+      ++ concatMap otherModules (allBuildInfo pkg)++    allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg)+ -- | A variation on the normal 'Text' instance, shows any ()'s in the original -- textual syntax. We need to show these otherwise it's confusing to users when -- we complain of their presence but do not pretty print them!@@ -1224,12 +1375,13 @@  . foldVersionRange'                         -- precedence:      -- All the same as the usual pretty printer, except for the parens      (         Disp.text "-any"                           , 0 :: Int)-     (\v   -> (Disp.text "==" <> disp v                   , 0))-     (\v   -> (Disp.char '>'  <> disp v                   , 0))-     (\v   -> (Disp.char '<'  <> disp v                   , 0))-     (\v   -> (Disp.text ">=" <> disp v                   , 0))-     (\v   -> (Disp.text "<=" <> disp v                   , 0))-     (\v _ -> (Disp.text "==" <> dispWild v               , 0))+     (\v   -> (Disp.text "==" <<>> disp v                   , 0))+     (\v   -> (Disp.char '>'  <<>> disp v                   , 0))+     (\v   -> (Disp.char '<'  <<>> disp v                   , 0))+     (\v   -> (Disp.text ">=" <<>> disp v                   , 0))+     (\v   -> (Disp.text "<=" <<>> disp v                   , 0))+     (\v _ -> (Disp.text "==" <<>> dispWild v               , 0))+     (\v _ -> (Disp.text "^>=" <<>> disp v                   , 0))      (\(r1, p1) (r2, p2) ->        (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))      (\(r1, p1) (r2, p2) ->@@ -1237,9 +1389,10 @@      (\(r,  _ )          -> (Disp.parens r, 0)) -- parens    where-    dispWild (Version b _) =-           Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))-        <> Disp.text ".*"+    dispWild v =+           Disp.hcat (Disp.punctuate (Disp.char '.')+                                     (map Disp.int $ versionNumbers v))+        <<>> Disp.text ".*"     punct p p' | p < p'    = Disp.parens                | otherwise = id @@ -1284,19 +1437,22 @@     -- pick a single "typical" configuration and check if that has an     -- open upper bound. To get a typical configuration we finalise     -- using no package index and the current platform.-    finalised = finalizePackageDescription-                              [] (const True) buildPlatform+    finalised = finalizePD+                              [] defaultComponentRequestedSpec (const True)+                              buildPlatform                               (unknownCompilerInfo-                                (CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag)+                                (CompilerId buildCompilerFlavor nullVersion)+                                NoAbiTag)                               [] pkg     baseDependency = case finalised of       Right (pkg', _) | not (null baseDeps) ->           foldr intersectVersionRanges anyVersion baseDeps         where           baseDeps =-            [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ]+            [ vr | Dependency pname vr <- buildDepends pkg'+                 , pname == mkPackageName "base" ] -      -- Just in case finalizePackageDescription fails for any reason,+      -- Just in case finalizePD fails for any reason,       -- or if the package doesn't depend on the base package at all,       -- then we will just skip the check, since boundedAbove noVersion = True       _          -> noVersion@@ -1332,8 +1488,11 @@     unknownOSs    = [ os   | OS   (OtherOS os)           <- conditions ]     unknownArches = [ arch | Arch (OtherArch arch)       <- conditions ]     unknownImpls  = [ impl | Impl (OtherCompiler impl) _ <- conditions ]-    conditions = concatMap (fvs . snd) (condLibraries pkg)+    conditions = concatMap fvs (maybeToList (condLibrary pkg))+              ++ concatMap (fvs . snd) (condSubLibraries pkg)               ++ concatMap (fvs . snd) (condExecutables pkg)+              ++ concatMap (fvs . snd) (condTestSuites pkg)+              ++ concatMap (fvs . snd) (condBenchmarks pkg)     fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables     compfv (c, ct, mct) = condfv c ++ fvs ct ++ maybe [] fvs mct     condfv c = case c of@@ -1436,9 +1595,12 @@      allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)]     allConditionalBuildInfo =-        concatMap (collectCondTreePaths libBuildInfo . snd)-                  (condLibraries pkg)+        concatMap (collectCondTreePaths libBuildInfo)+                  (maybeToList (condLibrary pkg)) +     ++ concatMap (collectCondTreePaths libBuildInfo . snd)+                  (condSubLibraries pkg)+      ++ concatMap (collectCondTreePaths buildInfo . snd)                   (condExecutables pkg) @@ -1475,14 +1637,15 @@ -- | Sanity check things that requires IO. It looks at the files in the -- package and expects to find the package unpacked in at the given file path. ---checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]+checkPackageFiles :: PackageDescription -> FilePath -> NoCallStackIO [PackageCheck] checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg   where     checkFilesIO = CheckPackageContentOps {       doesFileExist        = System.doesFileExist                  . relative,       doesDirectoryExist   = System.doesDirectoryExist             . relative,       getDirectoryContents = System.Directory.getDirectoryContents . relative,-      getFileContents      = \f -> openBinaryFile (relative f) ReadMode >>= hGetContents+      getFileContents      = \f -> openBinaryFile (relative f) ReadMode+                                   >>= hGetContents     }     relative path = root </> path @@ -1524,10 +1687,18 @@ checkCabalFileBOM ops = do   epdfile <- findPackageDesc ops   case epdfile of-    Left pc      -> return $ Just pc-    Right pdfile -> (flip check pc . startsWithBOM . fromUTF8) `liftM` (getFileContents ops pdfile)-                       where pc = PackageDistInexcusable $-                                    pdfile ++ " starts with an Unicode byte order mark (BOM). This may cause problems with older cabal versions."+    -- MASSIVE HACK.  If the Cabal file doesn't exist, that is+    -- a very strange situation to be in, because the driver code+    -- in 'Distribution.Setup' ought to have noticed already!+    -- But this can be an issue, see #3552 and also when+    -- --cabal-file is specified.  So if you can't find the file,+    -- just don't bother with this check.+    Left _       -> return $ Nothing+    Right pdfile -> (flip check pc . startsWithBOM . fromUTF8)+                    `liftM` (getFileContents ops pdfile)+      where pc = PackageDistInexcusable $+                 pdfile ++ " starts with an Unicode byte order mark (BOM)."+                 ++ " This may cause problems with older cabal versions."  -- |Find a package description file in the given directory.  Looks for -- @.cabal@ files.  Like 'Distribution.Simple.Utils.findPackageDesc',@@ -1547,7 +1718,8 @@       case cabalFiles of         []          -> return (Left $ PackageBuildImpossible noDesc)         [cabalFile] -> return (Right cabalFile)-        multiple    -> return (Left $ PackageBuildImpossible $ multiDesc multiple)+        multiple    -> return (Left $ PackageBuildImpossible+                               $ multiDesc multiple)    where     noDesc :: String@@ -1555,7 +1727,7 @@              ++ "Please create a package description file <pkgname>.cabal"      multiDesc :: [String] -> String-    multiDesc l = "Multiple cabal files found.\n"+    multiDesc l = "Multiple cabal files found while checking.\n"                   ++ "Please use only one of: "                   ++ intercalate ", " l @@ -1607,7 +1779,7 @@                   | dir <- extraFrameworkDirs  bi ]                ++ [ (dir, "include-dirs")   | dir <- includeDirs  bi ]                ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]-             , isRelative dir ]+             , isRelativeOnAnyPlatform dir ]   missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs   return [ PackageBuildWarning {              explanation = quote (kind ++ ": " ++ dir)@@ -1686,13 +1858,13 @@   | otherwise = case pack nameMax (reverse (splitPath path)) of     Left err           -> Just err     Right []           -> Nothing-    Right (first:rest) -> case pack prefixMax remainder of+    Right (h:rest) -> case pack prefixMax remainder of       Left err         -> Just err       Right []         -> Nothing       Right (_:_)      -> Just noSplit      where         -- drop the '/' between the name and prefix:-        remainder = init first : rest+        remainder = init h : rest    where     nameMax, prefixMax :: Int
cabal/Cabal/Distribution/PackageDescription/Configuration.hs view
@@ -10,12 +10,13 @@ -- Portability :  portable -- -- This is about the cabal configurations feature. It exports--- 'finalizePackageDescription' and 'flattenPackageDescription' which are+-- 'finalizePD' and 'flattenPackageDescription' which are -- functions for converting 'GenericPackageDescription's down to -- 'PackageDescription's. It has code for working with the tree of conditions -- and resolving or flattening conditions.  module Distribution.PackageDescription.Configuration (+    finalizePD,     finalizePackageDescription,     flattenPackageDescription, @@ -23,6 +24,7 @@     parseCondition,     freeVars,     extractCondition,+    extractConditions,     addBuildableCondition,     mapCondTree,     mapTreeData,@@ -32,6 +34,9 @@     transformAllBuildDepends,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Utils@@ -42,12 +47,10 @@ import Distribution.Text import Distribution.Compat.ReadP as ReadP hiding ( char ) import qualified Distribution.Compat.ReadP as ReadP ( char )-import Distribution.Compat.Semigroup as Semi+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.ForeignLib+import Distribution.Types.Component -import Control.Arrow (first)-import Data.Char ( isAlphaNum )-import Data.Maybe ( mapMaybe, maybeToList )-import Data.Map ( Map, fromListWith, toList ) import qualified Data.Map as Map import Data.Tree ( Tree(Node) ) @@ -141,7 +144,7 @@     boolLiteral   = fmap Lit  parse     archIdent     = fmap Arch parse     osIdent       = fmap OS   parse-    flagIdent     = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar)+    flagIdent     = fmap (Flag . mkFlagName . lowercase) (munch1 isIdentChar)     isIdentChar c = isAlphaNum c || c == '_' || c == '-'     oper s        = sp >> string s >> sp     sp            = skipSpaces@@ -174,7 +177,7 @@  instance Semigroup d => Monoid (DepTestRslt d) where     mempty = DepOk-    mappend = (Semi.<>)+    mappend = (<>)  instance Semigroup d => Semigroup (DepTestRslt d) where     DepOk <> x     = x@@ -206,6 +209,7 @@ resolveWithFlags ::      [(FlagName,[Bool])]         -- ^ Domain for each flag name, will be tested in order.+  -> ComponentRequestedSpec   -> OS      -- ^ OS as returned by Distribution.System.buildOS   -> Arch    -- ^ Arch as returned by Distribution.System.buildArch   -> CompilerInfo  -- ^ Compiler information@@ -215,7 +219,7 @@   -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)        -- ^ Either the missing dependencies (error case), or a pair of        -- (set of build targets with dependencies, chosen flag assignments)-resolveWithFlags dom os arch impl constrs trees checkDeps =+resolveWithFlags dom enabled os arch impl constrs trees checkDeps =     either (Left . fromDepMapUnion) Right $ explore (build [] dom)   where     extraConstrs = toDepMap constrs@@ -240,7 +244,7 @@                 -- apply additional constraints to all dependencies                 first (`constrainBy` extraConstrs) .                 simplifyCondTree (env flags)-            deps = overallDependencies targetSet+            deps = overallDependencies enabled targetSet         in case checkDeps (fromDepMap deps) of              DepOk | null ts   -> Right (targetSet, flags)                    | otherwise -> tryAll $ map explore ts@@ -274,10 +278,8 @@     env flags flag = (maybe (Left flag) Right . lookup flag) flags      pdTaggedBuildInfo :: PDTagged -> BuildInfo-    pdTaggedBuildInfo (Lib _ l) = libBuildInfo l-    pdTaggedBuildInfo (Exe _ e) = buildInfo e-    pdTaggedBuildInfo (Test _ t) = testBuildInfo t-    pdTaggedBuildInfo (Bench _ b) = benchmarkBuildInfo b+    pdTaggedBuildInfo (Lib l) = libBuildInfo l+    pdTaggedBuildInfo (SubComp _ c) = componentBuildInfo c     pdTaggedBuildInfo PDNull = mempty  -- | Transforms a 'CondTree' by putting the input under the "then" branch of a@@ -293,17 +295,24 @@     Lit False -> CondNode mempty mempty []     c         -> CondNode mempty mempty [(c, t, Nothing)] --- | Extract buildable condition from a cond tree.+-- Note: extracting buildable conditions.+-- -------------------------------------- ----- Background: If the conditions in a cond tree lead to Buildable being set to False,--- then none of the dependencies for this cond tree should actually be taken into--- account. On the other hand, some of the flags may only be decided in the solver,--- so we cannot necessarily make the decision whether a component is Buildable or not--- prior to solving.+-- If the conditions in a cond tree lead to Buildable being set to False, then+-- none of the dependencies for this cond tree should actually be taken into+-- account. On the other hand, some of the flags may only be decided in the+-- solver, so we cannot necessarily make the decision whether a component is+-- Buildable or not prior to solving. ----- What we are doing here is to partially evaluate a condition tree in order to extract--- the condition under which Buildable is True. The predicate determines whether data--- under a 'CondTree' is buildable.+-- What we are doing here is to partially evaluate a condition tree in order to+-- extract the condition under which Buildable is True. The predicate determines+-- whether data under a 'CondTree' is buildable.+++-- | Extract the condition matched by the given predicate from a cond tree.+--+-- We use this mainly for extracting buildable conditions (see the Note above),+-- but the function is in fact more general. extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v extractCondition p = go   where@@ -316,31 +325,31 @@         ct = go t         ce = maybe (Lit True) go e       in-        ((c `cand` ct) `cor` (CNot c `cand` ce)) `cand` goList cs+        ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs -    cand (Lit False) _           = Lit False-    cand _           (Lit False) = Lit False-    cand (Lit True)  x           = x-    cand x           (Lit True)  = x-    cand x           y           = CAnd x y+-- | Extract conditions matched by the given predicate from all cond trees in a+-- 'GenericPackageDescription'.+extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription+                     -> [Condition ConfVar]+extractConditions f gpkg =+  concat [+      extractCondition (f . libBuildInfo)             <$> maybeToList (condLibrary gpkg)+    , extractCondition (f . libBuildInfo)       . snd <$> condSubLibraries   gpkg+    , extractCondition (f . buildInfo)          . snd <$> condExecutables gpkg+    , extractCondition (f . testBuildInfo)      . snd <$> condTestSuites  gpkg+    , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks  gpkg+    ] -    cor  (Lit True)  _           = Lit True-    cor  _           (Lit True)  = Lit True-    cor  (Lit False) x           = x-    cor  x           (Lit False) = x-    cor  c           (CNot d)-      | c == d                   = Lit True-    cor  x           y           = COr x y  -- | A map of dependencies that combines version ranges using 'unionVersionRanges'. newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName VersionRange }  toDepMapUnion :: [Dependency] -> DepMapUnion toDepMapUnion ds =-  DepMapUnion $ fromListWith unionVersionRanges [ (p,vr) | Dependency p vr <- ds ]+  DepMapUnion $ Map.fromListWith unionVersionRanges [ (p,vr) | Dependency p vr <- ds ]  fromDepMapUnion :: DepMapUnion -> [Dependency]-fromDepMapUnion m = [ Dependency p vr | (p,vr) <- toList (unDepMapUnion m) ]+fromDepMapUnion m = [ Dependency p vr | (p,vr) <- Map.toList (unDepMapUnion m) ]  -- | A map of dependencies.  Newtyped since the default monoid instance is not --   appropriate.  The monoid instance uses 'intersectVersionRanges'.@@ -349,7 +358,7 @@  instance Monoid DependencyMap where     mempty = DependencyMap Map.empty-    mappend = (Semi.<>)+    mappend = (<>)  instance Semigroup DependencyMap where     (DependencyMap a) <> (DependencyMap b) =@@ -357,10 +366,10 @@  toDepMap :: [Dependency] -> DependencyMap toDepMap ds =-  DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ]+  DependencyMap $ Map.fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ]  fromDepMap :: DependencyMap -> [Dependency]-fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ]+fromDepMap m = [ Dependency p vr | (p,vr) <- Map.toList (unDependencyMap m) ]  -- | Flattens a CondTree using a partial flag assignment.  When a condition -- cannot be evaluated, both branches are ignored.@@ -405,15 +414,24 @@  -- | Combine the target-specific dependencies in a TargetSet to give the -- dependencies for the package as a whole.-overallDependencies :: TargetSet PDTagged -> DependencyMap-overallDependencies (TargetSet targets) = mconcat depss+overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap+overallDependencies enabled (TargetSet targets) = mconcat depss   where     (depss, _) = unzip $ filter (removeDisabledSections . snd) targets     removeDisabledSections :: PDTagged -> Bool-    removeDisabledSections (Lib _ l)     = buildable (libBuildInfo l)-    removeDisabledSections (Exe _ e)   = buildable (buildInfo e)-    removeDisabledSections (Test _ t)  = testEnabled t && buildable (testBuildInfo t)-    removeDisabledSections (Bench _ b) = benchmarkEnabled b && buildable (benchmarkBuildInfo b)+    -- UGH. The embedded componentName in the 'Component's here is+    -- BLANK.  I don't know whose fault this is but I'll use the tag+    -- instead. -- ezyang+    removeDisabledSections (Lib _)     = componentNameRequested enabled CLibName+    removeDisabledSections (SubComp t c)+        -- Do NOT use componentName+        = componentNameRequested enabled+        $ case c of+            CLib  _ -> CSubLibName t+            CFLib _ -> CFLibName   t+            CExe  _ -> CExeName    t+            CTest _ -> CTestName   t+            CBench _ -> CBenchName t     removeDisabledSections PDNull      = True  -- Apply extra constraints to a dependency map.@@ -434,59 +452,30 @@  -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go.-flattenTaggedTargets :: TargetSet PDTagged ->-        ([(String, Library)], [(String, Executable)], [(String, TestSuite)]-        , [(String, Benchmark)])-flattenTaggedTargets (TargetSet targets) = foldr untag ([], [], [], []) targets+flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)])+flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets   where-    untag (deps, Lib n l) (libs, exes, tests, bms)-        | any ((== n) . fst) libs =-          userBug $ "There exist several libs with the same name: '" ++ n ++ "'"-        -- NB: libraries live in a different namespace than everything else-        -- TODO: no, (new-style) TESTS live in same namespace!!-        | otherwise = ((n, l'):libs, exes, tests, bms)+    untag (_, Lib _) (Just _, _) = userBug "Only one library expected"+    untag (deps, Lib l) (Nothing, comps) =+        (Just l', comps)       where         l' = l {                 libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }             }-    untag (deps, Exe n e) (libs, exes, tests, bms)-        | any ((== n) . fst) exes =-          userBug $ "There exist several exes with the same name: '" ++ n ++ "'"-        | any ((== n) . fst) tests =-          userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"-        | any ((== n) . fst) bms =-          userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"-        | otherwise = (libs, (n, e'):exes, tests, bms)-      where-        e' = e {-                buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }-            }-    untag (deps, Test n t) (libs, exes, tests, bms)-        | any ((== n) . fst) tests =-          userBug $ "There exist several tests with the same name: '" ++ n ++ "'"-        | any ((== n) . fst) exes =-          userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"-        | any ((== n) . fst) bms =-          userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"-        | otherwise = (libs, exes, (n, t'):tests, bms)-      where-        t' = t {-            testBuildInfo = (testBuildInfo t)-                { targetBuildDepends = fromDepMap deps }-            }-    untag (deps, Bench n b) (libs, exes, tests, bms)-        | any ((== n) . fst) bms =-          userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"-        | any ((== n) . fst) exes =-          userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"-        | any ((== n) . fst) tests =-          userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"-        | otherwise = (libs, exes, tests, (n, b'):bms)+    untag (deps, SubComp n c) (mb_lib, comps)+        | any ((== n) . fst) comps =+          userBug $ "There exist several components with the same name: '" ++ unUnqualComponentName n ++ "'"++        | otherwise = (mb_lib, (n, c') : comps)       where-        b' = b {-            benchmarkBuildInfo = (benchmarkBuildInfo b)-                { targetBuildDepends = fromDepMap deps }-            }+        updBI bi = bi { targetBuildDepends = fromDepMap deps }+        c' = case c of+              CLib   x -> CLib   x { libBuildInfo        = updBI (libBuildInfo        x) }+              CFLib  x -> CFLib  x { foreignLibBuildInfo = updBI (foreignLibBuildInfo x) }+              CExe   x -> CExe   x { buildInfo           = updBI (buildInfo           x) }+              CTest  x -> CTest  x { testBuildInfo       = updBI (testBuildInfo       x) }+              CBench x -> CBench x { benchmarkBuildInfo  = updBI (benchmarkBuildInfo  x) }+     untag (_, PDNull) x = x  -- actually this should not happen, but let's be liberal  @@ -494,24 +483,20 @@ -- Convert GenericPackageDescription to PackageDescription -- -data PDTagged = Lib String Library-              | Exe String Executable-              | Test String TestSuite-              | Bench String Benchmark+data PDTagged = Lib Library+              | SubComp UnqualComponentName Component               | PDNull               deriving Show  instance Monoid PDTagged where     mempty = PDNull-    mappend = (Semi.<>)+    mappend = (<>)  instance Semigroup PDTagged where     PDNull    <> x      = x     x         <> PDNull = x-    Lib n l   <> Lib   n' l' | n == n' = Lib n (l <> l')-    Exe n e   <> Exe   n' e' | n == n' = Exe n (e <> e')-    Test n t  <> Test  n' t' | n == n' = Test n (t <> t')-    Bench n b <> Bench n' b' | n == n' = Bench n (b <> b')+    Lib l     <> Lib l' = Lib (l <> l')+    SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')     _         <> _  = cabalBug "Cannot combine incompatible tags"  -- | Create a package description with all configurations resolved.@@ -536,8 +521,13 @@ -- On success, it will return the package description and the full flag -- assignment chosen. ---finalizePackageDescription ::+-- Note that this drops any stanzas which have @buildable: False@.  While+-- this is arguably the right thing to do, it means we give bad error+-- messages in some situations, see #3858.+--+finalizePD ::      FlagAssignment  -- ^ Explicitly specified flag assignments+  -> ComponentRequestedSpec   -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of                           -- available packages?  If this is unknown then use                           -- True.@@ -549,35 +539,46 @@             (PackageDescription, FlagAssignment)              -- ^ Either missing dependencies or the resolved package              -- description along with the flag assignments chosen.-finalizePackageDescription userflags satisfyDep+finalizePD userflags enabled satisfyDep         (Platform arch os) impl constraints-        (GenericPackageDescription pkg flags libs0 exes0 tests0 bms0) =+        (GenericPackageDescription pkg flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) =     case resolveFlags of-      Right ((libs', exes', tests', bms'), targetSet, flagVals) ->-        Right ( pkg { libraries = libs'+      Right ((mb_lib', comps'), targetSet, flagVals) ->+        let (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' in+        Right ( pkg { library = mb_lib'+                    , subLibraries = sub_libs'+                    , foreignLibs = flibs'                     , executables = exes'                     , testSuites = tests'                     , benchmarks = bms'-                    , buildDepends = fromDepMap (overallDependencies targetSet)+                    , buildDepends = fromDepMap (overallDependencies enabled targetSet)                     }               , flagVals )        Left missing -> Left missing   where     -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data-    condTrees =    map (\(name,tree) -> mapTreeData (Lib name) tree) libs0-                ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0-                ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0-                ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0+    condTrees =    maybeToList (fmap (mapTreeData Lib) mb_lib0)+                ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0+                ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0+                ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0+                ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0+                ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0      resolveFlags =-        case resolveWithFlags flagChoices os arch impl constraints condTrees check of+        case resolveWithFlags flagChoices enabled os arch impl constraints condTrees check of           Right (targetSet, fs) ->-              let (libs, exes, tests, bms) = flattenTaggedTargets targetSet in-              Right ( (map (\(n,l) -> (libFillInDefaults l) { libName = n }) libs,-                       map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,-                       map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,-                       map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),+              let (mb_lib, comps) = flattenTaggedTargets targetSet in+              Right ( (fmap libFillInDefaults mb_lib,+                       map (\(n,c) ->+                            foldComponent+                               (\l -> CLib   (libFillInDefaults l)   { libName = Just n+                                                                     , libExposed = False })+                               (\l -> CFLib  (flibFillInDefaults l)  { foreignLibName = n })+                               (\e -> CExe   (exeFillInDefaults e)   { exeName = n })+                               (\t -> CTest  (testFillInDefaults t)  { testName = n })+                               (\b -> CBench (benchFillInDefaults b) { benchmarkName = n })+                               c) comps),                      targetSet, fs)           Left missing      -> Left missing @@ -593,6 +594,20 @@                       then DepOk                       else MissingDeps missingDeps +{-# DEPRECATED finalizePackageDescription "This function now always assumes tests and benchmarks are disabled; use finalizePD with ComponentRequestedSpec to specify something more specific." #-}+finalizePackageDescription ::+     FlagAssignment  -- ^ Explicitly specified flag assignments+  -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of+                          -- available packages?  If this is unknown then use+                          -- True.+  -> Platform      -- ^ The 'Arch' and 'OS'+  -> CompilerInfo  -- ^ Compiler information+  -> [Dependency]  -- ^ Additional constraints+  -> GenericPackageDescription+  -> Either [Dependency]+            (PackageDescription, FlagAssignment)+finalizePackageDescription flags = finalizePD flags defaultComponentRequestedSpec+ {- let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])@@ -617,21 +632,37 @@ -- default path will be missing from the package description returned by this -- function. flattenPackageDescription :: GenericPackageDescription -> PackageDescription-flattenPackageDescription (GenericPackageDescription pkg _ libs0 exes0 tests0 bms0) =-    pkg { libraries = reverse libs-        , executables = reverse exes-        , testSuites = reverse tests-        , benchmarks = reverse bms-        , buildDepends = reverse ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps+flattenPackageDescription+  (GenericPackageDescription pkg _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) =+    pkg { library      = mlib+        , subLibraries = reverse sub_libs+        , foreignLibs  = reverse flibs+        , executables  = reverse exes+        , testSuites   = reverse tests+        , benchmarks   = reverse bms+        , buildDepends = ldeps+                      ++ reverse sub_ldeps+                      ++ reverse pldeps+                      ++ reverse edeps+                      ++ reverse tdeps+                      ++ reverse bdeps         }   where-    (libs, ldeps) = foldr flattenLib ([],[]) libs0-    (exes, edeps) = foldr flattenExe ([],[]) exes0-    (tests, tdeps) = foldr flattenTst ([],[]) tests0-    (bms, bdeps) = foldr flattenBm ([],[]) bms0+    (mlib, ldeps) = case mlib0 of+        Just lib -> let (l,ds) = ignoreConditions lib in+                    (Just ((libFillInDefaults l) { libName = Nothing }), ds)+        Nothing -> (Nothing, [])+    (sub_libs, sub_ldeps) = foldr flattenLib  ([],[]) sub_libs0+    (flibs,    pldeps)    = foldr flattenFLib ([],[]) flibs0+    (exes,     edeps)     = foldr flattenExe  ([],[]) exes0+    (tests,    tdeps)     = foldr flattenTst  ([],[]) tests0+    (bms,      bdeps)     = foldr flattenBm   ([],[]) bms0     flattenLib (n, t) (es, ds) =         let (e, ds') = ignoreConditions t in-        ( (libFillInDefaults $ e { libName = n }) : es, ds' ++ ds )+        ( (libFillInDefaults $ e { libName = Just n, libExposed = False }) : es, ds' ++ ds )+    flattenFLib (n, t) (es, ds) =+        let (e, ds') = ignoreConditions t in+        ( (flibFillInDefaults $ e { foreignLibName = n }) : es, ds' ++ ds )     flattenExe (n, t) (es, ds) =         let (e, ds') = ignoreConditions t in         ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )@@ -653,6 +684,10 @@ libFillInDefaults lib@(Library { libBuildInfo = bi }) =     lib { libBuildInfo = biFillInDefaults bi } +flibFillInDefaults :: ForeignLib -> ForeignLib+flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) =+    flib { foreignLibBuildInfo = biFillInDefaults bi }+ exeFillInDefaults :: Executable -> Executable exeFillInDefaults exe@(Executable { buildInfo = bi }) =     exe { buildInfo = biFillInDefaults bi }@@ -687,7 +722,8 @@      pd = packageDescription gpd     pd'  = pd {-      libraries      = map  onLibrary        (libraries pd),+      library        = fmap onLibrary        (library pd),+      subLibraries   = map  onLibrary        (subLibraries pd),       executables    = map  onExecutable     (executables pd),       testSuites     = map  onTestSuite      (testSuites pd),       benchmarks     = map  onBenchmark      (benchmarks pd),@@ -727,18 +763,21 @@   onTestSuite onBenchmark onDepends gpd = gpd'   where     gpd'    = gpd {-      condLibraries      = condLibs',+      condLibrary        = condLib',+      condSubLibraries   = condSubLibs',       condExecutables    = condExes',       condTestSuites     = condTests',       condBenchmarks     = condBenchs'       } -    condLibs   = condLibraries      gpd+    condLib    = condLibrary        gpd+    condSubLibs = condSubLibraries  gpd     condExes   = condExecutables    gpd     condTests  = condTestSuites     gpd     condBenchs = condBenchmarks     gpd -    condLibs'   = map  (mapSnd $ onCondTree onLibrary)    condLibs+    condLib'    = fmap (onCondTree onLibrary) condLib+    condSubLibs' = map (mapSnd $ onCondTree onLibrary)    condSubLibs     condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes     condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests     condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs
cabal/Cabal/Distribution/PackageDescription/Parse.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.PackageDescription.Parse@@ -18,34 +20,42 @@ module Distribution.PackageDescription.Parse (         -- * Package descriptions         readPackageDescription,-        writePackageDescription,         parsePackageDescription,-        showPackageDescription,          -- ** Parsing         ParseResult(..),         FieldDescr(..),         LineNo, +        -- ** Private, but needed for pretty-printer+        TestSuiteStanza(..),+        BenchmarkStanza(..),+         -- ** Supplementary build information         readHookedBuildInfo,         parseHookedBuildInfo,-        writeHookedBuildInfo,-        showHookedBuildInfo,          pkgDescrFieldDescrs,         libFieldDescrs,+        foreignLibFieldDescrs,         executableFieldDescrs,         binfoFieldDescrs,         sourceRepoFieldDescrs,         testSuiteFieldDescrs,+        benchmarkFieldDescrs,         flagFieldDescrs   ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.ForeignLib+import Distribution.Types.ForeignLibType import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription import Distribution.PackageDescription.Utils import Distribution.Package+import Distribution.Package.TextClass () import Distribution.ModuleName import Distribution.Version import Distribution.Verbosity@@ -55,19 +65,13 @@ import Distribution.Text import Distribution.Compat.ReadP hiding (get) -import Data.Char     (isSpace)-import Data.Maybe    (listToMaybe, isJust)-import Data.List     (nub, unfoldr, partition, (\\))-import Control.Monad (liftM, foldM, when, unless, ap)-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid         (Monoid(..))-import Control.Applicative (Applicative(..))-#endif-import Control.Arrow    (first)+import Data.List        (partition, (\\)) import System.Directory (doesFileExist)-import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Control.Monad    (mapM)  import Text.PrettyPrint+       (vcat, ($$), (<+>), text, render,+        comma, fsep, nest, ($+$), punctuate)   -- -----------------------------------------------------------------------------@@ -85,7 +89,7 @@            (either disp disp)     (liftM Left parse +++ liftM Right parse)            specVersionRaw         (\v pkg -> pkg{specVersionRaw=v})  , simpleField "build-type"-           (maybe empty disp)     (fmap Just parse)+           (maybe mempty disp)  (fmap Just parse)            buildType              (\t pkg -> pkg{buildType=t})  , simpleField "license"            disp                   parseLicenseQ@@ -177,11 +181,8 @@   , commaListFieldWithSep vcat "reexported-modules" disp parse       reexportedModules (\mods lib -> lib{reexportedModules=mods}) -  , listFieldWithSep vcat "required-signatures" disp parseModuleNameQ-      requiredSignatures (\mods lib -> lib{requiredSignatures=mods})--  , listFieldWithSep vcat "exposed-signatures" disp parseModuleNameQ-      exposedSignatures (\mods lib -> lib{exposedSignatures=mods})+  , listFieldWithSep vcat "signatures" disp parseModuleNameQ+      signatures (\mods lib -> lib{signatures=mods})    , boolField "exposed"       libExposed     (\val lib -> lib{libExposed=val})@@ -195,17 +196,40 @@ storeXFieldsLib _ _ = Nothing  -- ---------------------------------------------------------------------------+-- Foreign libraries++foreignLibFieldDescrs :: [FieldDescr ForeignLib]+foreignLibFieldDescrs =+  [ simpleField "type"+      disp                   parse+      foreignLibType         (\x flib -> flib { foreignLibType = x })+  , listField "options"+      disp                   parse+      foreignLibOptions      (\x flib -> flib { foreignLibOptions = x })+  , listField "mod-def-file"+      showFilePath           parseFilePathQ+      foreignLibModDefFile   (\x flib -> flib { foreignLibModDefFile = x })+  ]+  ++ map biToFLib binfoFieldDescrs+  where biToFLib = liftField foreignLibBuildInfo $ \bi flib ->+          flib { foreignLibBuildInfo = bi }++storeXFieldsForeignLib :: UnrecFieldParser ForeignLib+storeXFieldsForeignLib (f@('x':'-':_), val)+                        l@(ForeignLib { foreignLibBuildInfo = bi }) =+    Just $ l { foreignLibBuildInfo = bi {+                   customFieldsBI = (f,val):customFieldsBI bi+                 }+             }+storeXFieldsForeignLib _ _ = Nothing++-- --------------------------------------------------------------------------- -- The Executable type   executableFieldDescrs :: [FieldDescr Executable] executableFieldDescrs =-  [ -- note ordering: configuration must come first, for-    -- showPackageDescription.-    simpleField "executable"-                           showToken          parseTokenQ-                           exeName            (\xs    exe -> exe{exeName=xs})-  , simpleField "main-is"+  [ simpleField "main-is"                            showFilePath       parseFilePathQ                            modulePath         (\xs    exe -> exe{modulePath=xs})   ]@@ -235,13 +259,13 @@ testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] testSuiteFieldDescrs =     [ simpleField "type"-        (maybe empty disp)    (fmap Just parse)+        (maybe mempty disp) (fmap Just parse)         testStanzaTestType    (\x suite -> suite { testStanzaTestType = x })     , simpleField "main-is"-        (maybe empty showFilePath)  (fmap Just parseFilePathQ)+        (maybe mempty showFilePath)  (fmap Just parseFilePathQ)         testStanzaMainIs      (\x suite -> suite { testStanzaMainIs = x })     , simpleField "test-module"-        (maybe empty disp)    (fmap Just parseModuleNameQ)+        (maybe mempty disp) (fmap Just parseModuleNameQ)         testStanzaTestModule  (\x suite -> suite { testStanzaTestModule = x })     ]     ++ map biToTest binfoFieldDescrs@@ -320,11 +344,11 @@ benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza] benchmarkFieldDescrs =     [ simpleField "type"-        (maybe empty disp)    (fmap Just parse)+        (maybe mempty disp)    (fmap Just parse)         benchmarkStanzaBenchmarkType         (\x suite -> suite { benchmarkStanzaBenchmarkType = x })     , simpleField "main-is"-        (maybe empty showFilePath)  (fmap Just parseFilePathQ)+        (maybe mempty showFilePath)  (fmap Just parseFilePathQ)         benchmarkStanzaMainIs         (\x suite -> suite { benchmarkStanzaMainIs = x })     ]@@ -379,17 +403,19 @@ -- --------------------------------------------------------------------------- -- The BuildInfo type - binfoFieldDescrs :: [FieldDescr BuildInfo] binfoFieldDescrs =  [ boolField "buildable"            buildable          (\val binfo -> binfo{buildable=val})  , commaListField  "build-tools"-           disp               parseBuildTool+           disp               parse            buildTools         (\xs  binfo -> binfo{buildTools=xs})  , commaListFieldWithSep vcat "build-depends"            disp                   parse            targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs})+ , commaListFieldWithSep vcat "mixins"+           disp                   parse+           mixins   (\xs binfo -> binfo{mixins=xs})  , spaceListField "cpp-options"            showToken          parseTokenQ'            cppOptions          (\val binfo -> binfo{cppOptions=val})@@ -400,7 +426,7 @@            showToken          parseTokenQ'            ldOptions          (\val binfo -> binfo{ldOptions=val})  , commaListField  "pkgconfig-depends"-           disp               parsePkgconfigDependency+           disp               parse            pkgconfigDepends   (\xs  binfo -> binfo{pkgconfigDepends=xs})  , listField "frameworks"            showToken          parseTokenQ@@ -415,7 +441,7 @@            showFilePath       parseFilePathQ            jsSources          (\paths binfo -> binfo{jsSources=paths})  , simpleField "default-language"-           (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))+           (maybe mempty disp) (option Nothing (fmap Just parseLanguageQ))            defaultLanguage    (\lang  binfo -> binfo{defaultLanguage=lang})  , listField   "other-languages"            disp               parseLanguageQ@@ -454,6 +480,9 @@  , listFieldWithSep vcat "other-modules"            disp               parseModuleNameQ            otherModules       (\val binfo -> binfo{otherModules=val})+ , listFieldWithSep vcat "autogen-modules"+           disp               parseModuleNameQ+           autogenModules       (\val binfo -> binfo{autogenModules=val})  , optsField   "ghc-prof-options" GHC            profOptions        (\val binfo -> binfo{profOptions=val})  , optsField   "ghcjs-prof-options" GHCJS@@ -499,22 +528,22 @@ sourceRepoFieldDescrs :: [FieldDescr SourceRepo] sourceRepoFieldDescrs =     [ simpleField "type"-        (maybe empty disp)         (fmap Just parse)+        (maybe mempty disp)         (fmap Just parse)         repoType                   (\val repo -> repo { repoType = val })     , simpleField "location"-        (maybe empty showFreeText) (fmap Just parseFreeText)+        (maybe mempty showFreeText) (fmap Just parseFreeText)         repoLocation               (\val repo -> repo { repoLocation = val })     , simpleField "module"-        (maybe empty showToken)    (fmap Just parseTokenQ)+        (maybe mempty showToken)    (fmap Just parseTokenQ)         repoModule                 (\val repo -> repo { repoModule = val })     , simpleField "branch"-        (maybe empty showToken)    (fmap Just parseTokenQ)+        (maybe mempty showToken)    (fmap Just parseTokenQ)         repoBranch                 (\val repo -> repo { repoBranch = val })     , simpleField "tag"-        (maybe empty showToken)    (fmap Just parseTokenQ)+        (maybe mempty showToken)    (fmap Just parseTokenQ)         repoTag                    (\val repo -> repo { repoTag = val })     , simpleField "subdir"-        (maybe empty showFilePath) (fmap Just parseFilePathQ)+        (maybe mempty showFilePath) (fmap Just parseFilePathQ)         repoSubdir                 (\val repo -> repo { repoSubdir = val })     ] @@ -545,7 +574,7 @@         let (line, message) = locatedErrorMsg e         dieWithLocation fpath line message     ParseOk warnings x -> do-        mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings+        traverse_ (warn verbosity . showPWarning fpath) $ reverse warnings         return x  readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo@@ -572,15 +601,15 @@  mapSimpleFields :: (Field -> ParseResult Field) -> [Field]                 -> ParseResult [Field]-mapSimpleFields f = mapM walk+mapSimpleFields f = traverse walk   where     walk fld@F{} = f fld     walk (IfBlock l c fs1 fs2) = do-      fs1' <- mapM walk fs1-      fs2' <- mapM walk fs2+      fs1' <- traverse walk fs1+      fs2' <- traverse walk fs2       return (IfBlock l c fs1' fs2')     walk (Section ln n l fs1) = do-      fs1' <-  mapM walk fs1+      fs1' <-  traverse walk fs1       return (Section ln n l fs1')  -- prop_isMapM fs = mapSimpleFields return fs == return fs@@ -642,8 +671,8 @@                         (a,s') <- f s                         runStT (g a) s' -get :: Monad m => StT s m s-get = StT $ \s -> return (s, s)+getSt :: Monad m => StT s m s+getSt = StT $ \s -> return (s, s)  modify :: Monad m => (s -> s) -> StT s m () modify f = StT $ \s -> return ((),f s)@@ -663,7 +692,7 @@  -- return look-ahead field or nothing if we're at the end of the file peekField :: PM (Maybe Field)-peekField = liftM listToMaybe get+peekField = liftM listToMaybe getSt  -- Unconditionally discard the first field in our state.  Will error when it -- reaches end of file.  (Yes, that's evil.)@@ -702,10 +731,10 @@           head $ [ minVersionBound versionRange                  | Just versionRange <- [ simpleParse v                                         | F _ "cabal-version" v <- fields0 ] ]-              ++ [Version [0] []]+              ++ [mkVersion [0]]         minVersionBound versionRange =           case asVersionIntervals versionRange of-            []                            -> Version [0] []+            []                            -> mkVersion [0]             ((LowerBound version _, _):_) -> version      handleFutureVersionParseFailure cabalVersionNeeded $ do@@ -741,14 +770,14 @@            -- 'getBody' assumes that the remaining fields only consist of           -- flags, lib and exe sections.-        (repos, flags, mcsetup, libs, exes, tests, bms) <- getBody pkg+        (repos, flags, mcsetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg         warnIfRest  -- warn if getBody did not parse up to the last field.           -- warn about using old/new syntax with wrong cabal-version:         maybeWarnCabalVersion (not $ oldSyntax fields0) pkg-        checkForUndefinedFlags flags libs exes tests+        checkForUndefinedFlags flags mlib sub_libs exes tests         return $ GenericPackageDescription                    pkg { sourceRepos = repos, setupBuildInfo = mcsetup }-                   flags libs exes tests bms+                   flags mlib sub_libs flibs exes tests bms    where     oldSyntax = all isSimpleField@@ -758,13 +787,13 @@           ++ "  Tabs were used at (line,column): " ++ show tabs      maybeWarnCabalVersion newsyntax pkg-      | newsyntax && specVersion pkg < Version [1,2] []+      | newsyntax && specVersion pkg < mkVersion [1,2]       = lift $ warning $              "A package using section syntax must specify at least\n"           ++ "'cabal-version: >= 1.2'."      maybeWarnCabalVersion newsyntax pkg-      | not newsyntax && specVersion pkg >= Version [1,2] []+      | not newsyntax && specVersion pkg >= mkVersion [1,2]       = lift $ warning $              "A package using 'cabal-version: "           ++ displaySpecVersion (specVersionRaw pkg)@@ -835,7 +864,7 @@     -- warn if there's something at the end of the file     warnIfRest :: PM ()     warnIfRest = do-      s <- get+      s <- getSt       case s of         [] -> return ()         _ -> lift $ warning "Ignoring trailing declarations."  -- add line no.@@ -848,17 +877,24 @@         _ -> return (reverse acc)      ---    -- body ::= { repo | flag | library | executable | test }++    -- body ::= { repo | flag | library | sub library | foreign library+    --          | executable | test | bench }+     --     -- The body consists of an optional sequence of declarations of flags and-    -- an arbitrary number of libraries/executables/tests.+    -- an arbitrary number of components+    --+    -- TODO: This method is long due for a rewrite to use a accumulator+    -- data type, or perhaps some more general way of balling the+    -- components up.     getBody :: PackageDescription             -> PM ([SourceRepo], [Flag]                   ,Maybe SetupBuildInfo-                  ,[(String, CondTree ConfVar [Dependency] Library)]-                  ,[(String, CondTree ConfVar [Dependency] Executable)]-                  ,[(String, CondTree ConfVar [Dependency] TestSuite)]-                  ,[(String, CondTree ConfVar [Dependency] Benchmark)])+                  ,(Maybe (CondTree ConfVar [Dependency] Library))+                  ,[(UnqualComponentName, CondTree ConfVar [Dependency] Library)]+                  ,[(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]+                  ,[(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]+                  ,[(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]+                  ,[(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)])     getBody pkg = peekField >>= \mf -> case mf of       Just (Section line_no sec_type sec_label sec_fields)         | sec_type == "executable" -> do@@ -867,50 +903,53 @@             exename <- lift $ runP line_no "executable" parseTokenQ sec_label             flds <- collectFields parseExeFields sec_fields             skipField-            (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg-            return (repos, flags, csetup, lib, (exename, flds): exes, tests, bms)+            (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg+            return (repos, flags, csetup, mlib, sub_libs, flibs, (mkUnqualComponentName exename, flds): exes, tests, bms) +        | sec_type == "foreign-library" -> do+            when (null sec_label) $ lift $ syntaxError line_no+              "'foreign-library' needs one argument (the library's name)"+            libname <- lift $ runP line_no "foreign-library" parseTokenQ sec_label+            flds <- collectFields parseForeignLibFields sec_fields++            -- Check that a valid foreign library type has been chosen. A type+            -- field may be given inside a conditional block, so we must check+            -- for that before complaining that a type field has not been given.+            -- The foreign library must always have a valid type, so we need to+            -- check both the 'then' and 'else' blocks, though the blocks need+            -- not have the same type.+            let hasType ts = foreignLibType ts /= foreignLibType mempty+            if onAllBranches hasType flds+                then do+                    skipField+                    (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg+                    return (repos, flags, csetup, mlib, sub_libs, (mkUnqualComponentName libname, flds):flibs, exes, tests, bms)+                else lift $ syntaxError line_no $+                         "Foreign library \"" ++ libname+                      ++ "\" is missing required field \"type\" or the field "+                      ++ "is not present in all conditional branches. The "+                      ++ "available test types are: "+                      ++ intercalate ", " (map display knownForeignLibTypes)+         | sec_type == "test-suite" -> do             when (null sec_label) $ lift $ syntaxError line_no                 "'test-suite' needs one argument (the test suite's name)"             testname <- lift $ runP line_no "test" parseTokenQ sec_label             flds <- collectFields (parseTestFields line_no) sec_fields -            -- Check that a valid test suite type has been chosen. A type-            -- field may be given inside a conditional block, so we must-            -- check for that before complaining that a type field has not-            -- been given. The test suite must always have a valid type, so-            -- we need to check both the 'then' and 'else' blocks, though-            -- the blocks need not have the same type.-            let checkTestType ts ct =-                    let ts' = mappend ts $ condTreeData ct-                        -- If a conditional has only a 'then' block and no-                        -- 'else' block, then it cannot have a valid type-                        -- in every branch, unless the type is specified at-                        -- a higher level in the tree.-                        checkComponent (_, _, Nothing) = False-                        -- If a conditional has a 'then' block and an 'else'-                        -- block, both must specify a test type, unless the-                        -- type is specified higher in the tree.-                        checkComponent (_, t, Just e) =-                            checkTestType ts' t && checkTestType ts' e-                        -- Does the current node specify a test type?-                        hasTestType = testInterface ts'-                            /= testInterface emptyTestSuite-                    -- If the current level of the tree specifies a type,-                    -- then we are done. If not, then one of the conditional-                    -- branches below the current node must specify a type.-                    -- Each node may have multiple immediate children; we-                    -- only one need one to specify a type because the-                    -- configure step uses 'mappend' to join together the-                    -- results of flag resolution.-                    in hasTestType || any checkComponent (condTreeComponents ct)-            if checkTestType emptyTestSuite flds+            -- Check that a valid test suite type has been chosen. A type field+            -- may be given inside a conditional block, so we must check for+            -- that before complaining that a type field has not been given. The+            -- test suite must always have a valid type, so we need to check+            -- both the 'then' and 'else' blocks, though the blocks need not+            -- have the same type.+            let hasType ts = testInterface ts /= testInterface mempty+            if onAllBranches hasType flds                 then do                     skipField-                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg-                    return (repos, flags, csetup, lib, exes,-                            (testname, flds) : tests, bms)+                    (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg+                    return (repos, flags, csetup, mlib, sub_libs, flibs, exes,+                            (mkUnqualComponentName testname, flds) : tests, bms)                 else lift $ syntaxError line_no $                          "Test suite \"" ++ testname                       ++ "\" is missing required field \"type\" or the field "@@ -924,41 +963,19 @@             benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label             flds <- collectFields (parseBenchmarkFields line_no) sec_fields -            -- Check that a valid benchmark type has been chosen. A type-            -- field may be given inside a conditional block, so we must-            -- check for that before complaining that a type field has not-            -- been given. The benchmark must always have a valid type, so-            -- we need to check both the 'then' and 'else' blocks, though-            -- the blocks need not have the same type.-            let checkBenchmarkType ts ct =-                    let ts' = mappend ts $ condTreeData ct-                        -- If a conditional has only a 'then' block and no-                        -- 'else' block, then it cannot have a valid type-                        -- in every branch, unless the type is specified at-                        -- a higher level in the tree.-                        checkComponent (_, _, Nothing) = False-                        -- If a conditional has a 'then' block and an 'else'-                        -- block, both must specify a benchmark type, unless the-                        -- type is specified higher in the tree.-                        checkComponent (_, t, Just e) =-                            checkBenchmarkType ts' t && checkBenchmarkType ts' e-                        -- Does the current node specify a benchmark type?-                        hasBenchmarkType = benchmarkInterface ts'-                            /= benchmarkInterface emptyBenchmark-                    -- If the current level of the tree specifies a type,-                    -- then we are done. If not, then one of the conditional-                    -- branches below the current node must specify a type.-                    -- Each node may have multiple immediate children; we-                    -- only one need one to specify a type because the-                    -- configure step uses 'mappend' to join together the-                    -- results of flag resolution.-                    in hasBenchmarkType || any checkComponent (condTreeComponents ct)-            if checkBenchmarkType emptyBenchmark flds+            -- Check that a valid benchmark type has been chosen. A type field+            -- may be given inside a conditional block, so we must check for+            -- that before complaining that a type field has not been given. The+            -- benchmark must always have a valid type, so we need to check both+            -- the 'then' and 'else' blocks, though the blocks need not have the+            -- same type.+            let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty+            if onAllBranches hasType flds                 then do                     skipField-                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg-                    return (repos, flags, csetup, lib, exes,-                            tests, (benchname, flds) : bms)+                    (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg+                    return (repos, flags, csetup, mlib, sub_libs, flibs, exes,+                            tests, (mkUnqualComponentName benchname, flds) : bms)                 else lift $ syntaxError line_no $                          "Benchmark \"" ++ benchname                       ++ "\" is missing required field \"type\" or the field "@@ -967,15 +984,22 @@                       ++ intercalate ", " (map display knownBenchmarkTypes)          | sec_type == "library" -> do-            libname <- if null sec_label-                        then return (unPackageName (packageName pkg))-                        -- TODO: relax this parsing so that scoping is handled-                        -- correctly-                        else lift $ runP line_no "library" parseTokenQ sec_label+            mb_libname <- if null sec_label+                            then return Nothing+                            -- TODO: relax this parsing so that scoping is handled+                            -- correctly+                            else fmap Just . lift+                                  $ runP line_no "library" parseTokenQ sec_label             flds <- collectFields parseLibFields sec_fields             skipField-            (repos, flags, csetup, libs, exes, tests, bms) <- getBody pkg-            return (repos, flags, csetup, (libname, flds) : libs, exes, tests, bms)+            (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg+            case mb_libname of+                Just libname ->+                    return (repos, flags, csetup, mlib, (mkUnqualComponentName libname, flds) : sub_libs, flibs, exes, tests, bms)+                Nothing -> do+                    when (isJust mlib) $ lift $ syntaxError line_no+                      "There can only be one (public) library section in a package description."+                    return (repos, flags, csetup, Just flds, sub_libs, flibs, exes, tests, bms)          | sec_type == "flag" -> do             when (null sec_label) $ lift $@@ -983,11 +1007,11 @@             flag <- lift $ parseFields                     flagFieldDescrs                     warnUnrec-                    (MkFlag (FlagName (lowercase sec_label)) "" True False)+                    (emptyFlag (mkFlagName (lowercase sec_label)))                     sec_fields             skipField-            (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg-            return (repos, flag:flags, csetup, lib, exes, tests, bms)+            (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg+            return (repos, flag:flags, csetup, mlib, sub_libs, flibs, exes, tests, bms)          | sec_type == "source-repository" -> do             when (null sec_label) $ lift $ syntaxError line_no $@@ -1000,19 +1024,11 @@             repo <- lift $ parseFields                     sourceRepoFieldDescrs                     warnUnrec-                    SourceRepo {-                      repoKind     = kind,-                      repoType     = Nothing,-                      repoLocation = Nothing,-                      repoModule   = Nothing,-                      repoBranch   = Nothing,-                      repoTag      = Nothing,-                      repoSubdir   = Nothing-                    }+                    (emptySourceRepo kind)                     sec_fields             skipField-            (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg-            return (repo:repos, flags, csetup, lib, exes, tests, bms)+            (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg+            return (repo:repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms)          | sec_type == "custom-setup" -> do             unless (null sec_label) $ lift $@@ -1023,10 +1039,10 @@                              mempty                              sec_fields             skipField-            (repos, flags, csetup0, lib, exes, tests, bms) <- getBody pkg+            (repos, flags, csetup0, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg             when (isJust csetup0) $ lift $ syntaxError line_no               "There can only be one 'custom-setup' section in a package description."-            return (repos, flags, Just flds, lib, exes, tests, bms)+            return (repos, flags, Just flds, mlib, sub_libs, flibs, exes, tests, bms)          | otherwise -> do             lift $ warning $ "Ignoring unknown section type: " ++ sec_type@@ -1042,7 +1058,7 @@               "If-blocks are not allowed in between stanzas: " ++ show f             skipField             getBody pkg-      Nothing -> return ([], [], Nothing, [], [], [], [])+      Nothing -> return ([], [], Nothing, Nothing, [], [], [], [], [])      -- Extracts all fields in a block and returns a 'CondTree'.     --@@ -1056,7 +1072,7 @@             condFlds = [ f | f@IfBlock{} <- allflds ]             sections = [ s | s@Section{} <- allflds ] -        mapM_+        traverse_             (\(Section l n _ _) -> lift . warning $                 "Unexpected section '" ++ n ++ "' on line " ++ show l)             sections@@ -1076,11 +1092,11 @@         -- to check the CondTree, rather than grovel everywhere         -- inside the conditional bits).         deps <- liftM concat-              . mapM (lift . parseConstraint)+              . traverse (lift . parseConstraint)               . filter isConstraint               $ simplFlds -        ifs <- mapM processIfs condFlds+        ifs <- traverse processIfs condFlds          return (CondNode a deps ifs)       where@@ -1102,9 +1118,15 @@      -- Note: we don't parse the "executable" field here, hence the tail hack.     parseExeFields :: [Field] -> PM Executable-    parseExeFields = lift . parseFields (tail executableFieldDescrs)+    parseExeFields = lift . parseFields executableFieldDescrs                                         storeXFieldsExe emptyExecutable +    parseForeignLibFields :: [Field] -> PM ForeignLib+    parseForeignLibFields =+        lift . parseFields foreignLibFieldDescrs+                           storeXFieldsForeignLib+                           emptyForeignLib+     parseTestFields :: LineNo -> [Field] -> PM TestSuite     parseTestFields line fields = do         x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest@@ -1119,24 +1141,43 @@      checkForUndefinedFlags ::         [Flag] ->-        [(String, CondTree ConfVar [Dependency] Library)] ->-        [(String, CondTree ConfVar [Dependency] Executable)] ->-        [(String, CondTree ConfVar [Dependency] TestSuite)] ->+        Maybe (CondTree ConfVar [Dependency] Library) ->+        [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] ->+        [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] ->+        [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] ->         PM ()-    checkForUndefinedFlags flags libs exes tests = do+    checkForUndefinedFlags flags mlib sub_libs exes tests = do         let definedFlags = map flagName flags-        mapM_ (checkCondTreeFlags definedFlags . snd) libs-        mapM_ (checkCondTreeFlags definedFlags . snd) exes-        mapM_ (checkCondTreeFlags definedFlags . snd) tests+        traverse_ (checkCondTreeFlags definedFlags) (maybeToList mlib)+        traverse_ (checkCondTreeFlags definedFlags . snd) sub_libs+        traverse_ (checkCondTreeFlags definedFlags . snd) exes+        traverse_ (checkCondTreeFlags definedFlags . snd) tests      checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()     checkCondTreeFlags definedFlags ct = do         let fv = nub $ freeVars ct         unless (all (`elem` definedFlags) fv) $             fail $ "These flags are used without having been defined: "-                ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]+                ++ intercalate ", " [ unFlagName fn | fn <- fv \\ definedFlags ] +-- Check that a property holds on all branches of a condition tree+onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool+onAllBranches p = go mempty+  where+    -- If the current level of the tree satisfies the property, then we are+    -- done. If not, then one of the conditional branches below the current node+    -- must satisfy it. Each node may have multiple immediate children; we only+    -- one need one to satisfy the property because the configure step uses+    -- 'mappend' to join together the results of flag resolution.+    go :: a -> CondTree v c a -> Bool+    go acc ct = let acc' = acc `mappend` condTreeData ct+                in p acc' || any (goBranch acc') (condTreeComponents ct) +    -- Both the 'true' and the 'false' block must satisfy the property.+    goBranch :: a -> (cond, CondTree v c a, Maybe (CondTree v c a)) -> Bool+    goBranch _   (_, _, Nothing) = False+    goBranch acc (_, t, Just e)  = go acc t && go acc e+ -- | Parse a list of fields, given a list of field descriptions, --   a structure to accumulate the parsed fields, and a function --   that can decide what to do with fields which don't match any@@ -1202,84 +1243,26 @@ parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo parseHookedBuildInfo inp = do   fields <- readFields inp-  let (mLibFields:rest) = stanzas fields+  let ss@(mLibFields:exes) = stanzas fields   mLib <- parseLib mLibFields-  foldM parseStanza mLib rest+  biExes <- mapM parseExe (maybe ss (const exes) mLib)+  return (mLib, biExes)   where-    -- For backwards compatibility, if you have a bare stanza,-    -- we assume it's part of the public library.  We don't-    -- know what the name is, so the people using the HookedBuildInfo-    -- have to handle this carefully.-    parseLib :: [Field] -> ParseResult [(ComponentName, BuildInfo)]+    parseLib :: [Field] -> ParseResult (Maybe BuildInfo)     parseLib (bi@(F _ inFieldName _:_))-        | lowercase inFieldName /= "executable" &&-          lowercase inFieldName /= "library" &&-          lowercase inFieldName /= "benchmark" &&-          lowercase inFieldName /= "test-suite"-            = liftM (\bis -> [(CLibName "", bis)]) (parseBI bi)-    parseLib _ = return []+        | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)+    parseLib _ = return Nothing -    parseStanza :: HookedBuildInfo -> [Field] -> ParseResult HookedBuildInfo-    parseStanza bis (F line inFieldName mName:bi)-        | Just k <- case lowercase inFieldName of-                        "executable" -> Just CExeName-                        "library"    -> Just CLibName-                        "benchmark"  -> Just CBenchName-                        "test-suite" -> Just CTestName-                        _ -> Nothing-            = do bi' <- parseBI bi-                 return ((k mName, bi'):bis)-        | otherwise-            = syntaxError line $-                "expecting 'executable', 'library', 'benchmark' or 'test-suite' " ++-                "at top of stanza, but got '" ++ inFieldName ++ "'"-    parseStanza _ (_:_) = cabalBug "`parseStanza' called on a non-field"-    parseStanza _ [] = syntaxError 0 "error in parsing buildinfo file. Expected stanza"+    parseExe :: [Field] -> ParseResult (UnqualComponentName, BuildInfo)+    parseExe (F line inFieldName mName:bi)+        | lowercase inFieldName == "executable"+            = do bis <- parseBI bi+                 return (mkUnqualComponentName mName, bis)+        | otherwise = syntaxError line "expecting 'executable' at top of stanza"+    parseExe (_:_) = cabalBug "`parseExe' called on a non-field"+    parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"      parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st---- ------------------------------------------------------------------------------ Pretty printing--writePackageDescription :: FilePath -> PackageDescription -> IO ()-writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)----TODO: make this use section syntax--- add equivalent for GenericPackageDescription-showPackageDescription :: PackageDescription -> String-showPackageDescription pkg = render $-     ppPackage pkg-  $$ ppCustomFields (customFieldsPD pkg)-  $$ vcat [ space $$ ppLibrary lib | lib <- libraries pkg ]-  $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]-  where-    ppPackage    = ppFields pkgDescrFieldDescrs-    ppLibrary    = ppFields libFieldDescrs-    ppExecutable = ppFields executableFieldDescrs--ppCustomFields :: [(String,String)] -> Doc-ppCustomFields flds = vcat (map ppCustomField flds)--ppCustomField :: (String,String) -> Doc-ppCustomField (name,val) = text name <> colon <+> showFreeText val--writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()-writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack-                             . showHookedBuildInfo--showHookedBuildInfo :: HookedBuildInfo -> String-showHookedBuildInfo bis = render $-     vcat [    space-            $$ ppName name-            $$ ppBuildInfo bi-          | (name, bi) <- bis ]-  where-    ppName (CLibName name) = text "library:" <+> text name-    ppName (CExeName name) = text "executable:" <+> text name-    ppName (CTestName name) = text "test-suite:" <+> text name-    ppName (CBenchName name) = text "benchmark:" <+> text name-    ppBuildInfo bi = ppFields binfoFieldDescrs bi-                  $$ ppCustomFields (customFieldsBI bi)  -- replace all tabs used as indentation with whitespace, also return where -- tabs were found
+ cabal/Cabal/Distribution/PackageDescription/Parsec.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE FlexibleContexts    #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PackageDescription.Parsec+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This defined parsers and partial pretty printers for the @.cabal@ format.++module Distribution.PackageDescription.Parsec (+    -- * Package descriptions+    readGenericPackageDescription,+    parseGenericPackageDescription,++    -- ** Parsing+    ParseResult,++    -- ** Supplementary build information+    -- readHookedBuildInfo,+    -- parseHookedBuildInfo,+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import qualified Data.ByteString                                   as BS+import           Data.List                                         (partition)+import qualified Data.Map                                          as Map+import qualified Distribution.Compat.SnocList                      as SnocList+import           Distribution.Package+import           Distribution.PackageDescription+import           Distribution.PackageDescription.Parsec.FieldDescr+import           Distribution.Parsec.Class                         (parsec)+import           Distribution.Parsec.ConfVar+                 (parseConditionConfVar)+import           Distribution.Parsec.LexerMonad+                 (LexWarning, toPWarning)+import           Distribution.Parsec.Parser+import           Distribution.Parsec.Types.Common+import           Distribution.Parsec.Types.Field                   (getName)+import           Distribution.Parsec.Types.FieldDescr+import           Distribution.Parsec.Types.ParseResult+import           Distribution.Simple.Utils+                 (die, fromUTF8BS, warn)+import           Distribution.Text                                 (display)+import           Distribution.Types.ForeignLib+import           Distribution.Verbosity                            (Verbosity)+import           Distribution.Version+                 (LowerBound (..), Version, asVersionIntervals, mkVersion,+                 orLaterVersion)+import           System.Directory+                 (doesFileExist)+import qualified Text.Parsec                                       as P+import qualified Text.Parsec.Error                                 as P++-- ---------------------------------------------------------------+-- Parsing++-- | Helper combinator to do parsing plumbing for files.+--+-- Given a parser and a filename, return the parse of the file,+-- after checking if the file exists.+--+-- Argument order is chosen to encourage partial application.+readAndParseFile+    :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser+    -> Verbosity                         -- ^ Verbosity level+    -> FilePath                          -- ^ File to read+    -> IO a+readAndParseFile parser verbosity fpath = do+    exists <- doesFileExist fpath+    unless exists+        (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")+    bs <- BS.readFile fpath+    let (warnings, errors, result) = runParseResult (parser bs)+    traverse_ (warn verbosity . showPWarning fpath) warnings+    traverse_ (warn verbosity . showPError fpath) errors+    case result of+        Nothing -> die $ "Failing parsing \"" ++ fpath ++ "\"."+        Just x  -> return x++-- | Parse the given package file.+readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription+readGenericPackageDescription = readAndParseFile parseGenericPackageDescription++------------------------------------------------------------------------------+-- | Parses the given file into a 'GenericPackageDescription'.+--+-- In Cabal 1.2 the syntax for package descriptions was changed to a format+-- with sections and possibly indented property descriptions.+--+-- TODO: add lex warnings+parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription+parseGenericPackageDescription bs = case readFields' bs of+    Right (fs, lexWarnings) -> parseGenericPackageDescription' lexWarnings fs+    -- TODO: better marshalling of errors+    Left perr -> parseFatalFailure (Position 0 0) (show perr)++runFieldParser :: FieldParser a -> [FieldLine Position] -> ParseResult a+runFieldParser p ls = runFieldParser' pos p =<< fieldlinesToString pos ls+  where+    -- TODO: make per line lookup+    pos = case ls of+        []                     -> Position 0 0+        (FieldLine pos' _ : _) -> pos'++fieldlinesToBS :: [FieldLine ann] -> BS.ByteString+fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)++-- TODO: Take position  from FieldLine+-- TODO: Take field name+fieldlinesToString :: Position -> [FieldLine ann] -> ParseResult String+fieldlinesToString pos fls =+    let str = intercalate "\n" . map (\(FieldLine _ bs') -> fromUTF8BS bs') $ fls+    in if '\xfffd' `elem` str+        then str <$ parseWarning pos PWTUTF "Invalid UTF8 encoding"+        else pure str++runFieldParser' :: Position -> FieldParser a -> String -> ParseResult a+runFieldParser' (Position row col) p str = case P.runParser p' [] "<field>" str of+    Right (pok, ws) -> do+        -- TODO: map pos+        traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws+        pure pok+    Left err        -> do+        let ppos = P.errorPos err+        -- Positions start from 1:1, not 0:0+        let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos)+        let msg = P.showErrorMessages+                "or" "unknown parse error" "expecting" "unexpected" "end of input"+                (P.errorMessages err)++        parseFatalFailure epos $ msg ++ ": " ++ show str+  where+    p' = (,) <$ P.spaces <*> p <* P.spaces <* P.eof <*> P.getState++-- Note [Accumulating parser]+--+-- This parser has two "states":+-- * first we parse fields of PackageDescription+-- * then we parse sections (libraries, executables, etc)+parseGenericPackageDescription'+    :: [LexWarning]+    -> [Field Position]+    -> ParseResult GenericPackageDescription+parseGenericPackageDescription' lexWarnings fs = do+    parseWarnings' (fmap toPWarning lexWarnings)+    let (syntax, fs') = sectionizeFields fs+    gpd <-  goFields emptyGpd fs'+    -- Various post checks+    maybeWarnCabalVersion syntax (packageDescription gpd)+    checkForUndefinedFlags gpd+    -- TODO: do other validations+    return gpd+  where+    -- First fields+    goFields+        :: GenericPackageDescription+        -> [Field Position]+        -> ParseResult GenericPackageDescription+    goFields gpd [] = pure gpd+    goFields gpd (Field (Name pos name) fieldLines : fields) =+        case Map.lookup name pdFieldParsers of+            -- TODO: can be more elegant+            Nothing -> fieldlinesToString pos fieldLines >>= \value -> case storeXFieldsPD name value (packageDescription gpd) of+                Nothing -> do+                    parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name+                    goFields gpd fields+                Just pd ->+                    goFields (gpd { packageDescription = pd }) fields+            Just parser -> do+                pd <- runFieldParser (parser $ packageDescription gpd) fieldLines+                let gpd' = gpd { packageDescription = pd }+                goFields gpd' fields+    goFields gpd fields@(Section _ _ _ : _) = goSections gpd fields++    -- Sections+    goSections+        :: GenericPackageDescription+        -> [Field Position]+        -> ParseResult GenericPackageDescription+    goSections gpd [] = pure gpd+    goSections gpd (Field (Name pos name) _ : fields) = do+        parseWarning pos PWTTrailingFields $ "Ignoring trailing fields after sections: " ++ show name+        goSections gpd fields+    goSections gpd (Section name args secFields : fields) = do+        gpd' <- parseSection gpd name args secFields+        goSections gpd' fields++    emptyGpd :: GenericPackageDescription+    emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []++    pdFieldParsers :: Map FieldName (PackageDescription -> FieldParser PackageDescription)+    pdFieldParsers = Map.fromList $+        map (\x -> (fieldName x, fieldParser x)) pkgDescrFieldDescrs++    parseSection+        :: GenericPackageDescription+        -> Name Position+        -> [SectionArg Position]+        -> [Field Position]+        -> ParseResult GenericPackageDescription+    parseSection gpd (Name pos name) args fields+        | name == "library" && null args = do+            -- TODO: check that library is defined once+            l <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields+            let gpd' = gpd { condLibrary = Just l }+            pure gpd'++        -- Sublibraries+        | name == "library" = do+            name' <- parseUnqualComponentName pos args+            lib <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields+            -- TODO check duplicate name here?+            let gpd' = gpd { condSubLibraries = condSubLibraries gpd ++ [(name', lib)] }+            pure gpd'++        | name == "foreign-library" = do+            name' <- parseUnqualComponentName pos args+            flib <- parseCondTree foreignLibFieldDescrs storeXFieldsForeignLib (targetBuildDepends . foreignLibBuildInfo) emptyForeignLib fields+            -- TODO check duplicate name here?+            let gpd' = gpd { condForeignLibs = condForeignLibs gpd ++ [(name', flib)] }+            pure gpd'++        | name == "executable" = do+            name' <- parseUnqualComponentName pos args+            -- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010+            exe <- parseCondTree (tail executableFieldDescrs) storeXFieldsExe (targetBuildDepends . buildInfo) emptyExecutable fields+            -- TODO check duplicate name here?+            let gpd' = gpd { condExecutables = condExecutables gpd ++ [(name', exe)] }+            pure gpd'++        | name == "test-suite" = do+            name' <- parseUnqualComponentName pos args+            testStanza <- parseCondTree testSuiteFieldDescrs storeXFieldsTest (targetBuildDepends . testStanzaBuildInfo) emptyTestStanza fields+            testSuite <- traverse (validateTestSuite pos) testStanza+            -- TODO check duplicate name here?+            let gpd' = gpd { condTestSuites = condTestSuites gpd ++ [(name', testSuite)] }+            pure gpd'++        | name == "benchmark" = do+            name' <- parseUnqualComponentName pos args+            benchStanza <- parseCondTree benchmarkFieldDescrs storeXFieldsBenchmark (targetBuildDepends . benchmarkStanzaBuildInfo) emptyBenchmarkStanza fields+            bench <- traverse (validateBenchmark pos) benchStanza+            -- TODO check duplicate name here?+            let gpd' = gpd { condBenchmarks = condBenchmarks gpd ++ [(name', bench)] }+            pure gpd'++        | name == "flag" = do+            name' <- parseName pos args+            name'' <- runFieldParser' pos parsec name' `recoverWith` mkFlagName ""+            flag <- parseFields flagFieldDescrs warnUnrec (emptyFlag name'') fields+            -- Check default flag+            let gpd' = gpd { genPackageFlags = genPackageFlags gpd ++ [flag] }+            pure gpd'++        | name == "custom-setup" && null args = do+            sbi <- parseFields setupBInfoFieldDescrs warnUnrec mempty fields+            let pd = packageDescription gpd+            -- TODO: what if already defined?+            let gpd' = gpd { packageDescription = pd { setupBuildInfo = Just sbi } }+            pure gpd'++        | name == "source-repository" = do+            kind <- case args of+                [SecArgName spos secName] ->+                    runFieldParser' spos parsec (fromUTF8BS secName) `recoverWith` RepoHead+                [] -> do+                    parseFailure pos $ "'source-repository' needs one argument"+                    pure RepoHead+                _ -> do+                    parseFailure pos $ "Invalid source-repository kind " ++ show args+                    pure RepoHead+            sr <- parseFields sourceRepoFieldDescrs warnUnrec (emptySourceRepo kind) fields+            -- I want lens+            let pd =  packageDescription gpd+            let srs = sourceRepos pd+            let gpd' = gpd { packageDescription = pd { sourceRepos = srs ++ [sr] } }+            pure gpd'++        | otherwise = do+            parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name+            pure gpd++    newSyntaxVersion :: Version+    newSyntaxVersion = mkVersion [1, 2]++    maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()+    maybeWarnCabalVersion syntax pkg+      | syntax == NewSyntax && specVersion pkg < newSyntaxVersion+      = parseWarning (Position 0 0) PWTNewSyntax $+             "A package using section syntax must specify at least\n"+          ++ "'cabal-version: >= 1.2'."++    maybeWarnCabalVersion syntax pkg+      | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion+      = parseWarning (Position 0 0) PWTOldSyntax $+             "A package using 'cabal-version: "+          ++ displaySpecVersion (specVersionRaw pkg)+          ++ "' must use section syntax. See the Cabal user guide for details."+      where+        displaySpecVersion (Left version)       = display version+        displaySpecVersion (Right versionRange) =+          case asVersionIntervals versionRange of+            [] {- impossible -}           -> display versionRange+            ((LowerBound version _, _):_) -> display (orLaterVersion version)++    maybeWarnCabalVersion _ _ = return ()++{-+    handleFutureVersionParseFailure :: Version -> ParseResult a -> ParseResult GenericPackageDescription+    handleFutureVersionParseFailure _cabalVersionNeeded _parseBody =+        error "handleFutureVersionParseFailure"+-}++ {-+      undefined (unless versionOk (warning message) >> parseBody)+        `catchParseError` \parseError -> case parseError of+        TabsError _   -> parseFail parseError+        _ | versionOk -> parseFail parseError+          | otherwise -> fail message+      where versionOk = cabalVersionNeeded <= cabalVersion+            message   = "This package requires at least Cabal version "+                     ++ display cabalVersionNeeded+    -}++    checkForUndefinedFlags+        :: GenericPackageDescription+        -> ParseResult ()+    checkForUndefinedFlags _gpd = pure ()+{-+        let definedFlags = map flagName flags+        mapM_ (checkCondTreeFlags definedFlags) (maybeToList mlib)+        mapM_ (checkCondTreeFlags definedFlags . snd) sub_libs+        mapM_ (checkCondTreeFlags definedFlags . snd) exes+        mapM_ (checkCondTreeFlags definedFlags . snd) tests++    checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()+    checkCondTreeFlags definedFlags ct = do+        let fv = nub $ freeVars ct+        unless (all (`elem` definedFlags) fv) $+            fail $ "These flags are used without having been defined: "+                ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]+-}++parseName :: Position -> [SectionArg Position] -> ParseResult String+parseName pos args = case args of+    [SecArgName _pos secName] ->+         pure $ fromUTF8BS secName+    [SecArgStr _pos secName] ->+         pure secName+    [] -> do+         parseFailure pos $ "name required"+         pure ""+    _ -> do+         -- TODO: pretty print args+         parseFailure pos $ "Invalid name " ++ show args+         pure ""++parseUnqualComponentName :: Position -> [SectionArg Position] -> ParseResult UnqualComponentName+parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args+++-- | Parse a non-recursive list of fields, given a list of field descriptions,+--   a structure to accumulate the parsed fields, and a function+--   that can decide what to do with fields which don't match any+--   of the field descriptions.+parseFields+    :: forall a.+       [FieldDescr a]        -- ^ descriptions of fields we know how to parse+    -> UnknownFieldParser a  -- ^ possibly do something with unrecognized fields+    -> a                     -- ^ accumulator+    -> [Field Position]      -- ^ fields to be parsed+    -> ParseResult a+parseFields descrs _unknown = foldM go+  where+    go :: a -> Field Position -> ParseResult a+    go x (Section (Name pos name) _ _) = do+        -- Even we occur a subsection, we can continue parsing+        parseFailure pos $ "invalid subsection " ++ show name+        return x+    go x (Field (Name pos name) fieldLines) =+        case Map.lookup name fieldParsers of+            Nothing -> do+                -- TODO: use 'unknown'+                parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name+                return x+            Just parser ->+                runFieldParser (parser x) fieldLines++    fieldParsers :: Map FieldName (a -> FieldParser a)+    fieldParsers = Map.fromList $+        map (\x -> (fieldName x, fieldParser x)) descrs++type C c a = (Condition ConfVar, CondTree ConfVar c a, Maybe (CondTree ConfVar c a))++parseCondTree+    :: forall a c.+       [FieldDescr a]        -- ^ Field descriptions+    -> UnknownFieldParser a  -- ^ How to parse unknown fields+    -> (a -> c)              -- ^ Condition extractor+    -> a                     -- ^ Initial value+    -> [Field Position]      -- ^ Fields to parse+    -> ParseResult (CondTree ConfVar c a)+parseCondTree descs unknown cond ini = impl+  where+    impl :: [Field Position] -> ParseResult (CondTree ConfVar c a)+    impl fields = do+        (x, xs) <- goFields (ini, mempty) fields+        return $ CondNode x (cond x) (SnocList.runSnocList xs)++    goFields+        :: (a, SnocList.SnocList (C c a))+        -> [Field Position]+        -> ParseResult (a, SnocList.SnocList (C c a))+    goFields xss [] = return xss++    goFields xxs (Section (Name _pos name) tes con : fields) | name == "if" = do+        tes'  <- parseConditionConfVar tes+        con' <- impl con+        -- Jump to 'else' state+        goElse tes' con' xxs fields++    goFields xxs (Section (Name pos name) _ _ : fields) = do+        -- Even we occur a subsection, we can continue parsing+        -- http://hackage.haskell.org/package/constraints-0.1/constraints.cabal+        parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name+        goFields xxs fields++    goFields (x, xs) (Field (Name pos name) fieldLines : fields) =+        case Map.lookup name fieldParsers of+            Nothing -> fieldlinesToString pos fieldLines >>= \value -> case unknown name value x of+                Nothing -> do+                    parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name+                    goFields (x, xs) fields+                Just x' -> do+                    goFields (x', xs) fields+            Just parser -> do+                x' <- runFieldParser (parser x) fieldLines+                goFields (x', xs) fields++    -- Try to parse else branch+    goElse+        :: Condition ConfVar+        -> CondTree ConfVar c a+        -> (a, SnocList.SnocList (C c a))+        -> [Field Position]+        -> ParseResult (a, SnocList.SnocList (C c a))+    goElse tes con (x, xs) (Section (Name pos name) secArgs alt : fields) | name == "else" = do+        when (not . null $ secArgs) $ do+            parseFailure pos $ "`else` section has section arguments " ++ show secArgs+        alt' <- case alt of+            [] -> pure Nothing+            _  -> Just <$> impl alt+        let ieb = (tes, con, alt')+        goFields (x, SnocList.snoc xs ieb) fields+    goElse tes con (x, xs) fields = do+        let ieb = (tes, con, Nothing)+        goFields (x, SnocList.snoc xs ieb) fields++    fieldParsers :: Map FieldName (a -> FieldParser a)+    fieldParsers = Map.fromList $+        map (\x -> (fieldName x, fieldParser x)) descs++{- Note [Accumulating parser]++In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a ->+FieldParser a)@.  The weird value is used because we accumulate structure of+@a@ by folding over the fields.  There are various reasons for that:++* Almost all fields are optional++* This is simple approach so declarative bi-directional format (parsing and+printing) of structure could be specified (list of @'FieldDescr' a@)++* There are surface syntax fields corresponding to single field in the file:+  @license-file@ and @license-files@++* This is quite safe approach.++When/if we re-implement the parser to support formatting preservging roundtrip+with new AST, this all need to be rewritten.+-}++-------------------------------------------------------------------------------+-- Old syntax+-------------------------------------------------------------------------------++-- | "Sectionize" an old-style Cabal file.  A sectionized file has:+--+--  * all global fields at the beginning, followed by+--+--  * all flag declarations, followed by+--+--  * an optional library section, and an arbitrary number of executable+--    sections (in any order).+--+-- The current implementation just gathers all library-specific fields+-- in a library section and wraps all executable stanzas in an executable+-- section.+sectionizeFields :: [Field ann] -> (Syntax, [Field ann])+sectionizeFields fs = case classifyFields fs of+    Just fields -> (OldSyntax, convert fields)+    Nothing     -> (NewSyntax, fs)+  where+    -- return 'Just' if all fields are simple fields+    classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])]+    classifyFields = traverse f+      where+        f (Field name fieldlines) = Just (name, fieldlines)+        f _                      = Nothing++    trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse+    isSpace' = (== 32)++    convert :: [(Name ann, [FieldLine ann])] -> [Field ann]+    convert fields =+      let+        toField (name, ls) = Field name ls+        -- "build-depends" is a local field now.  To be backwards+        -- compatible, we still allow it as a global field in old-style+        -- package description files and translate it to a local field by+        -- adding it to every non-empty section+        (hdr0, exes0) = break ((=="executable") . getName . fst) fields+        (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0++        (deps, libfs) = partition ((== "build-depends") . getName . fst)+                                   libfs0++        exes = unfoldr toExe exes0+        toExe [] = Nothing+        toExe ((Name pos n, ls) : r)+          | n == "executable" =+              let (efs, r') = break ((== "executable") . getName . fst) r+              in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')+        toExe _ = error "unexpected input to 'toExe'"++        lib = case libfs of+            []                         -> []+            ((Name pos _,  _) : _) ->+                [Section (Name pos "library") [] (map toField $ deps ++ libfs)]++      in map toField hdr ++ lib ++ exes++-- | See 'sectionizeFields'.+data Syntax = OldSyntax | NewSyntax+    deriving (Eq, Show)++libFieldNames :: [FieldName]+libFieldNames = map fieldName libFieldDescrs
+ cabal/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs view
@@ -0,0 +1,607 @@+{-# LANGUAGE OverloadedStrings #-}+-- | 'GenericPackageDescription' Field descriptions+module Distribution.PackageDescription.Parsec.FieldDescr (+    -- * Package description+    pkgDescrFieldDescrs,+    storeXFieldsPD,+    -- * Library+    libFieldDescrs,+    storeXFieldsLib,+    -- * Foreign library+    foreignLibFieldDescrs,+    storeXFieldsForeignLib,+    -- * Executable+    executableFieldDescrs,+    storeXFieldsExe,+    -- * Test suite+    TestSuiteStanza (..),+    emptyTestStanza,+    testSuiteFieldDescrs,+    storeXFieldsTest,+    validateTestSuite,+    -- * Benchmark+    BenchmarkStanza (..),+    emptyBenchmarkStanza,+    benchmarkFieldDescrs,+    storeXFieldsBenchmark,+    validateBenchmark,+    -- * Flag+    flagFieldDescrs,+    -- * Source repository+    sourceRepoFieldDescrs,+    -- * Setup build info+    setupBInfoFieldDescrs,+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import qualified Data.ByteString                       as BS+import           Data.List                             (dropWhileEnd)+import qualified Distribution.Compat.Parsec            as Parsec+import           Distribution.Compiler                 (CompilerFlavor (..))+import           Distribution.ModuleName               (ModuleName)+import           Distribution.Package+import           Distribution.Package.TextClass        ()+import           Distribution.PackageDescription+import           Distribution.Types.ForeignLib+import           Distribution.Parsec.Class+import           Distribution.Parsec.Types.Common+import           Distribution.Parsec.Types.FieldDescr+import           Distribution.Parsec.Types.ParseResult+import           Distribution.PrettyUtils+import           Distribution.Simple.Utils             (fromUTF8BS)+import           Distribution.Text                     (disp, display)+import           Text.PrettyPrint                      (vcat)++-------------------------------------------------------------------------------+-- common FieldParsers+-------------------------------------------------------------------------------++-- | This is /almost/ @'many' 'Distribution.Compat.Parsec.anyChar'@, but it+--+-- * trims whitespace from ends of the lines,+--+-- * converts lines with only single dot into empty line.+--+freeTextFieldParser :: FieldParser String+freeTextFieldParser = dropDotLines <$ Parsec.spaces <*> many Parsec.anyChar+  where+    -- Example package with dot lines+    -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal+    dropDotLines "." = "."+    dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x+    dotToEmpty x | trim' x == "." = ""+    dotToEmpty x                  = trim x++    trim' = dropWhileEnd (`elem` (" \t" :: String))++-------------------------------------------------------------------------------+-- PackageDescription+-------------------------------------------------------------------------------++-- TODO: other-files isn't used in any cabal file on Hackage.+pkgDescrFieldDescrs :: [FieldDescr PackageDescription]+pkgDescrFieldDescrs =+    [ simpleField "name"+        disp                   parsec+        packageName            (\name pkg -> pkg{package=(package pkg){pkgName=name}})+    , simpleField "version"+        disp                   parsec+        packageVersion         (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})+    , simpleField "cabal-version"+             (either disp disp)     (Left <$> parsec <|> Right <$> parsec)+             specVersionRaw         (\v pkg -> pkg{specVersionRaw=v})+    , simpleField "build-type"+             (maybe mempty disp)    (Just <$> parsec)+             buildType              (\t pkg -> pkg{buildType=t})+    , simpleField "license"+             disp                   (parsecMaybeQuoted parsec)+             license                (\l pkg -> pkg{license=l})+    , simpleField "license-file"+             showFilePath           parsecFilePath+             (\pkg -> case licenseFiles pkg of+                        [x] -> x+                        _   -> "")+             (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})+     -- We have both 'license-file' and 'license-files' fields.+     -- Rather than declaring license-file to be deprecated, we will continue+     -- to allow both. The 'license-file' will continue to only allow single+     -- tokens, while 'license-files' allows multiple. On pretty-printing, we+     -- will use 'license-file' if there's just one, and use 'license-files'+     -- otherwise.+   , listField "license-files"+             showFilePath          parsecFilePath+             (\pkg -> case licenseFiles pkg of+                        [_] -> []+                        xs  -> xs)+             (\ls pkg -> pkg{licenseFiles=ls})+   , simpleField "copyright"+             showFreeText           freeTextFieldParser+             copyright              (\val pkg -> pkg{copyright=val})+   , simpleField "maintainer"+             showFreeText           freeTextFieldParser+             maintainer             (\val pkg -> pkg{maintainer=val})+   , simpleField "stability"+             showFreeText           freeTextFieldParser+             stability              (\val pkg -> pkg{stability=val})+   , simpleField "homepage"+             showFreeText           freeTextFieldParser+             homepage               (\val pkg -> pkg{homepage=val})+   , simpleField "package-url"+             showFreeText           freeTextFieldParser+             pkgUrl                 (\val pkg -> pkg{pkgUrl=val})+   , simpleField "bug-reports"+             showFreeText           freeTextFieldParser+             bugReports             (\val pkg -> pkg{bugReports=val})+   , simpleField "synopsis"+             showFreeText           freeTextFieldParser+             synopsis               (\val pkg -> pkg{synopsis=val})+   , simpleField "description"+             showFreeText           freeTextFieldParser+             description            (\val pkg -> pkg{description=val})+   , simpleField "category"+             showFreeText           freeTextFieldParser+             category               (\val pkg -> pkg{category=val})+   , simpleField "author"+             showFreeText           freeTextFieldParser+             author                 (\val pkg -> pkg{author=val})+   , listField "tested-with"+             showTestedWith         parsecTestedWith+             testedWith             (\val pkg -> pkg{testedWith=val})+   , listFieldWithSep vcat "data-files"+             showFilePath           parsecFilePath+             dataFiles              (\val pkg -> pkg{dataFiles=val})+   , simpleField "data-dir"+             showFilePath           parsecFilePath+             dataDir                (\val pkg -> pkg{dataDir=val})+   , listFieldWithSep vcat "extra-source-files"+             showFilePath           parsecFilePath+             extraSrcFiles          (\val pkg -> pkg{extraSrcFiles=val})+   , listFieldWithSep vcat "extra-tmp-files"+             showFilePath           parsecFilePath+             extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})+   , listFieldWithSep vcat "extra-doc-files"+             showFilePath           parsecFilePath+             extraDocFiles          (\val pkg -> pkg{extraDocFiles=val})+   ]++-- | Store any fields beginning with "x-" in the customFields field of+--   a PackageDescription.  All other fields will generate a warning.+storeXFieldsPD :: UnknownFieldParser PackageDescription+storeXFieldsPD f val pkg | beginsWithX f =+    Just pkg { customFieldsPD = customFieldsPD pkg ++ [(fromUTF8BS f, trim val)] }+storeXFieldsPD _ _ _ = Nothing++-------------------------------------------------------------------------------+-- Library+-------------------------------------------------------------------------------++libFieldDescrs :: [FieldDescr Library]+libFieldDescrs =+    [ listFieldWithSep vcat "exposed-modules" disp (parsecMaybeQuoted parsec)+        exposedModules (\mods lib -> lib{exposedModules=mods})+    , commaListFieldWithSep vcat "reexported-modules" disp parsec+        reexportedModules (\mods lib -> lib{reexportedModules=mods})++  , listFieldWithSep vcat "signatures" disp (parsecMaybeQuoted parsec)+      signatures (\mods lib -> lib{signatures=mods})++    , boolField "exposed"+        libExposed     (\val lib -> lib{libExposed=val})+    ] ++ map biToLib binfoFieldDescrs+  where+    biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})++storeXFieldsLib :: UnknownFieldParser Library+storeXFieldsLib f val l@Library { libBuildInfo = bi } | beginsWithX f =+    Just $ l {libBuildInfo =+                 bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}}+storeXFieldsLib _ _ _ = Nothing++-------------------------------------------------------------------------------+-- Foreign library+-------------------------------------------------------------------------------++foreignLibFieldDescrs :: [FieldDescr ForeignLib]+foreignLibFieldDescrs =+    [ simpleField "type"+      disp                   parsec+      foreignLibType         (\x flib -> flib { foreignLibType = x })+    , listField "options"+      disp                   parsec+      foreignLibOptions      (\x flib -> flib { foreignLibOptions = x })+    , listField "mod-def-file"+      showFilePath           parsecFilePath+      foreignLibModDefFile   (\x flib -> flib { foreignLibModDefFile = x })+    ] ++ map biToFLib binfoFieldDescrs+  where+    biToFLib = liftField foreignLibBuildInfo (\bi flib -> flib{foreignLibBuildInfo=bi})++storeXFieldsForeignLib :: UnknownFieldParser ForeignLib+storeXFieldsForeignLib f val l@ForeignLib { foreignLibBuildInfo = bi } | beginsWithX f =+    Just $ l {foreignLibBuildInfo =+                 bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}}+storeXFieldsForeignLib _ _ _ = Nothing++-------------------------------------------------------------------------------+-- Executable+-------------------------------------------------------------------------------++executableFieldDescrs :: [FieldDescr Executable]+executableFieldDescrs =+    [ -- note ordering: configuration must come first, for+      -- showPackageDescription.+      simpleField "executable"+        disp               parsec+        exeName            (\xs    exe -> exe{exeName=xs})+    , simpleField "main-is"+        showFilePath       parsecFilePath+        modulePath         (\xs    exe -> exe{modulePath=xs})+    ]+    ++ map biToExe binfoFieldDescrs+  where+    biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})++storeXFieldsExe :: UnknownFieldParser Executable+storeXFieldsExe f val e@Executable { buildInfo = bi } | beginsWithX f =+    Just $ e {buildInfo = bi{ customFieldsBI = (fromUTF8BS f, trim val) : customFieldsBI bi}}+storeXFieldsExe _ _ _ = Nothing++-------------------------------------------------------------------------------+-- TestSuite+-------------------------------------------------------------------------------++-- | An intermediate type just used for parsing the test-suite stanza.+-- After validation it is converted into the proper 'TestSuite' type.+data TestSuiteStanza = TestSuiteStanza+    { testStanzaTestType   :: Maybe TestType+    , testStanzaMainIs     :: Maybe FilePath+    , testStanzaTestModule :: Maybe ModuleName+    , testStanzaBuildInfo  :: BuildInfo+    }++emptyTestStanza :: TestSuiteStanza+emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty++testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]+testSuiteFieldDescrs =+    [ simpleField "type"+        (maybe mempty disp)   (Just <$> parsec)+        testStanzaTestType    (\x suite -> suite { testStanzaTestType = x })+    , simpleField "main-is"+        (maybe mempty showFilePath) (Just <$> parsecFilePath)+        testStanzaMainIs      (\x suite -> suite { testStanzaMainIs = x })+    , simpleField "test-module"+        (maybe mempty disp)   (Just <$> parsecMaybeQuoted parsec)+        testStanzaTestModule  (\x suite -> suite { testStanzaTestModule = x })+    ]+    ++ map biToTest binfoFieldDescrs+  where+    biToTest = liftField+        testStanzaBuildInfo+        (\bi suite -> suite { testStanzaBuildInfo = bi })++storeXFieldsTest :: UnknownFieldParser TestSuiteStanza+storeXFieldsTest f val t@TestSuiteStanza { testStanzaBuildInfo = bi }+    | beginsWithX f =+        Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (fromUTF8BS f,val):customFieldsBI bi}}+storeXFieldsTest _ _ _ = Nothing++validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite+validateTestSuite pos stanza = case testStanzaTestType stanza of+    Nothing -> return $+        emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }++    Just tt@(TestTypeUnknown _ _) ->+        pure emptyTestSuite+            { testInterface = TestSuiteUnsupported tt+            , testBuildInfo = testStanzaBuildInfo stanza+            }++    Just tt | tt `notElem` knownTestTypes ->+        pure emptyTestSuite+            { testInterface = TestSuiteUnsupported tt+            , testBuildInfo = testStanzaBuildInfo stanza+            }++    Just tt@(TestTypeExe ver) -> case testStanzaMainIs stanza of+        Nothing   -> do+            parseFailure pos (missingField "main-is" tt)+            pure emptyTestSuite+        Just file -> do+            when (isJust (testStanzaTestModule stanza)) $+                parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt)+            pure emptyTestSuite+                { testInterface = TestSuiteExeV10 ver file+                , testBuildInfo = testStanzaBuildInfo stanza+                }++    Just tt@(TestTypeLib ver) -> case testStanzaTestModule stanza of+         Nothing      -> do+             parseFailure pos (missingField "test-module" tt)+             pure emptyTestSuite+         Just module_ -> do+            when (isJust (testStanzaMainIs stanza)) $+                parseWarning pos PWTExtraMainIs (extraField "main-is" tt)+            pure emptyTestSuite+                { testInterface = TestSuiteLibV09 ver module_+                , testBuildInfo = testStanzaBuildInfo stanza+                }++  where+    missingField name tt = "The '" ++ name ++ "' field is required for the "+                        ++ display tt ++ " test suite type."++    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"+                        ++ display tt ++ "' test suite type."++-------------------------------------------------------------------------------+-- Benchmark+-------------------------------------------------------------------------------++-- | An intermediate type just used for parsing the benchmark stanza.+-- After validation it is converted into the proper 'Benchmark' type.+data BenchmarkStanza = BenchmarkStanza+    { benchmarkStanzaBenchmarkType   :: Maybe BenchmarkType+    , benchmarkStanzaMainIs          :: Maybe FilePath+    , benchmarkStanzaBenchmarkModule :: Maybe ModuleName+    , benchmarkStanzaBuildInfo        :: BuildInfo+    }++emptyBenchmarkStanza :: BenchmarkStanza+emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty++benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]+benchmarkFieldDescrs =+    [ simpleField "type"+        (maybe mempty disp)    (Just <$> parsec)+        benchmarkStanzaBenchmarkType+        (\x suite -> suite { benchmarkStanzaBenchmarkType = x })+    , simpleField "main-is"+        (maybe mempty showFilePath)  (Just <$> parsecFilePath)+        benchmarkStanzaMainIs+        (\x suite -> suite { benchmarkStanzaMainIs = x })+    ]+    ++ map biToBenchmark binfoFieldDescrs+  where+    biToBenchmark = liftField benchmarkStanzaBuildInfo+                    (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })++storeXFieldsBenchmark :: UnknownFieldParser BenchmarkStanza+storeXFieldsBenchmark f val t@BenchmarkStanza { benchmarkStanzaBuildInfo = bi } | beginsWithX f =+    Just $ t {benchmarkStanzaBuildInfo =+                       bi{ customFieldsBI = (fromUTF8BS f, trim val):customFieldsBI bi}}+storeXFieldsBenchmark _ _ _ = Nothing++validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark+validateBenchmark pos stanza = case benchmarkStanzaBenchmarkType stanza of+    Nothing -> pure emptyBenchmark+        { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }++    Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark+        { benchmarkInterface = BenchmarkUnsupported tt+        , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza+        }++    Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark+        { benchmarkInterface = BenchmarkUnsupported tt+        , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza+        }++    Just tt@(BenchmarkTypeExe ver) -> case benchmarkStanzaMainIs stanza of+        Nothing   -> do+            parseFailure pos (missingField "main-is" tt)+            pure emptyBenchmark+        Just file -> do+            when (isJust (benchmarkStanzaBenchmarkModule stanza)) $+                parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt)+            pure emptyBenchmark+                { benchmarkInterface = BenchmarkExeV10 ver file+                , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza+                }++  where+    missingField name tt = "The '" ++ name ++ "' field is required for the "+                        ++ display tt ++ " benchmark type."++    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"+                        ++ display tt ++ "' benchmark type."++-------------------------------------------------------------------------------+-- BuildInfo+-------------------------------------------------------------------------------++binfoFieldDescrs :: [FieldDescr BuildInfo]+binfoFieldDescrs =+ [ boolField "buildable"+           buildable          (\val binfo -> binfo{buildable=val})+ , commaListField  "build-tools"+           disp               parsec+           buildTools         (\xs  binfo -> binfo{buildTools=xs})+ , commaListFieldWithSep vcat "build-depends"+       disp               parsec+       targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs})+ , commaListFieldWithSep vcat "mixins"+       disp               parsec+       mixins (\xs binfo -> binfo{mixins=xs})+ , spaceListField "cpp-options"+           showToken          parsecToken'+           cppOptions          (\val binfo -> binfo{cppOptions=val})+ , spaceListField "cc-options"+           showToken          parsecToken'+           ccOptions          (\val binfo -> binfo{ccOptions=val})+ , spaceListField "ld-options"+           showToken          parsecToken'+           ldOptions          (\val binfo -> binfo{ldOptions=val})+ , commaListField  "pkgconfig-depends"+           disp               parsec+           pkgconfigDepends   (\xs  binfo -> binfo{pkgconfigDepends=xs})+ , listField "frameworks"+           showToken          parsecToken+           frameworks         (\val binfo -> binfo{frameworks=val})+ , listField "extra-framework-dirs"+           showToken          parsecFilePath+           extraFrameworkDirs (\val binfo -> binfo{extraFrameworkDirs=val})+ , listFieldWithSep vcat "c-sources"+           showFilePath       parsecFilePath+           cSources           (\paths binfo -> binfo{cSources=paths})+ , listFieldWithSep vcat "js-sources"+           showFilePath       parsecFilePath+           jsSources          (\paths binfo -> binfo{jsSources=paths})+   , simpleField "default-language"+       (maybe mempty disp) (Parsec.optionMaybe $ parsecMaybeQuoted parsec)+        defaultLanguage    (\lang  binfo -> binfo{defaultLanguage=lang})+ , listField   "other-languages"+           disp              (parsecMaybeQuoted parsec)+           otherLanguages     (\langs binfo -> binfo{otherLanguages=langs})+   , listField   "default-extensions"+       disp               (parsecMaybeQuoted parsec)+       defaultExtensions  (\exts  binfo -> binfo{defaultExtensions=exts})+   , listField   "other-extensions"+       disp               (parsecMaybeQuoted parsec)+       otherExtensions    (\exts  binfo -> binfo{otherExtensions=exts})+   , listField   "extensions"+       -- TODO: this is deprecated field, isn't it?+       disp               (parsecMaybeQuoted parsec)+       oldExtensions      (\exts  binfo -> binfo{oldExtensions=exts})+ , listFieldWithSep vcat "extra-libraries"+           showToken          parsecToken+           extraLibs          (\xs    binfo -> binfo{extraLibs=xs})+ , listFieldWithSep vcat "extra-ghci-libraries"+           showToken          parsecToken+           extraGHCiLibs      (\xs    binfo -> binfo{extraGHCiLibs=xs})+ , listField   "extra-lib-dirs"+           showFilePath       parsecFilePath+           extraLibDirs       (\xs    binfo -> binfo{extraLibDirs=xs})+ , listFieldWithSep vcat "includes"+           showFilePath       parsecFilePath+           includes           (\paths binfo -> binfo{includes=paths})+ , listFieldWithSep vcat "install-includes"+           showFilePath       parsecFilePath+           installIncludes    (\paths binfo -> binfo{installIncludes=paths})+ , listField   "include-dirs"+           showFilePath       parsecFilePath+           includeDirs        (\paths binfo -> binfo{includeDirs=paths})+   , listField   "hs-source-dirs"+       showFilePath        parsecFilePath+       hsSourceDirs       (\paths binfo -> binfo{hsSourceDirs=paths})+   , deprecatedField "hs-source-dirs" $ listField  "hs-source-dir"+       showFilePath        parsecFilePath+       (const [])          (\paths binfo -> binfo{hsSourceDirs=paths})+   , listFieldWithSep vcat "other-modules"+       disp               (parsecMaybeQuoted parsec)+       otherModules       (\val binfo -> binfo{otherModules=val})+   , listFieldWithSep vcat "autogen-modules"+       disp               (parsecMaybeQuoted parsec)+       autogenModules     (\val binfo -> binfo{autogenModules=val})+ , optsField   "ghc-prof-options" GHC+           profOptions        (\val binfo -> binfo{profOptions=val})+ , optsField   "ghcjs-prof-options" GHCJS+           profOptions        (\val binfo -> binfo{profOptions=val})+ , optsField   "ghc-shared-options" GHC+           sharedOptions      (\val binfo -> binfo{sharedOptions=val})+ , optsField   "ghcjs-shared-options" GHCJS+           sharedOptions      (\val binfo -> binfo{sharedOptions=val})+   , optsField   "ghc-options"  GHC+        options            (\path  binfo -> binfo{options=path})+ , optsField   "ghcjs-options" GHCJS+           options            (\path  binfo -> binfo{options=path})+ , optsField   "jhc-options"  JHC+           options            (\path  binfo -> binfo{options=path})+ -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept+ -- around for backwards compatibility.+ --+ -- TODO: deprecate?+ , optsField   "hugs-options" Hugs+           options            (const id)+ , optsField   "nhc98-options" NHC+           options            (const id)+   ]++{-+storeXFieldsBI :: UnknownFieldParser BuildInfo+--storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi }+storeXFieldsBI _ _ = Nothing+-}++-------------------------------------------------------------------------------+-- Flag+-------------------------------------------------------------------------------++flagFieldDescrs :: [FieldDescr Flag]+flagFieldDescrs =+    [ simpleField "description"+        showFreeText     freeTextFieldParser+        flagDescription  (\val fl -> fl{ flagDescription = val })+    , boolField "default"+        flagDefault      (\val fl -> fl{ flagDefault = val })+    , boolField "manual"+        flagManual       (\val fl -> fl{ flagManual = val })+    ]++-------------------------------------------------------------------------------+-- SourceRepo+-------------------------------------------------------------------------------++sourceRepoFieldDescrs :: [FieldDescr SourceRepo]+sourceRepoFieldDescrs =+    [ simpleField "type"+        (maybe mempty disp)         (Just <$> parsec)+        repoType                    (\val repo -> repo { repoType = val })+    , simpleField "location"+        (maybe mempty showFreeText) (Just <$> freeTextFieldParser)+        repoLocation                (\val repo -> repo { repoLocation = val })+    , simpleField "module"+        (maybe mempty showToken)    (Just <$> parsecToken)+        repoModule                  (\val repo -> repo { repoModule = val })+    , simpleField "branch"+        (maybe mempty showToken)    (Just <$> parsecToken)+        repoBranch                  (\val repo -> repo { repoBranch = val })+    , simpleField "tag"+        (maybe mempty showToken)    (Just <$> parsecToken)+        repoTag                     (\val repo -> repo { repoTag = val })+    , simpleField "subdir"+        (maybe mempty showFilePath) (Just <$> parsecFilePath)+        repoSubdir                  (\val repo -> repo { repoSubdir = val })+    ]++-------------------------------------------------------------------------------+-- SetupBuildInfo+-------------------------------------------------------------------------------++setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo]+setupBInfoFieldDescrs =+    [ commaListFieldWithSep vcat "setup-depends"+        disp         parsec+        setupDepends (\xs binfo -> binfo{setupDepends=xs})+    ]+++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++-- | Predicate to test field names beginning with "x-"+beginsWithX :: FieldName -> Bool+beginsWithX bs = BS.take 2 bs == "x-"++-- | Mark the field as deprecated.+deprecatedField+    :: FieldName   -- ^ alternative field+    -> FieldDescr a+    -> FieldDescr a+deprecatedField newFieldName fd = FieldDescr+    { fieldName   = oldFieldName+    , fieldPretty = const mempty  -- we don't print deprecated field+    , fieldParser = \x -> do+        parsecWarning PWTDeprecatedField $+            "The field " <> show oldFieldName <>+            " is deprecated, please use " <> show newFieldName+        fieldParser fd x+    }+  where+    oldFieldName = fieldName fd++-- Used to trim x-fields+trim :: String -> String+trim = dropWhile isSpace . dropWhileEnd isSpace
cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs view
@@ -13,29 +13,44 @@ -----------------------------------------------------------------------------  module Distribution.PackageDescription.PrettyPrint (+    -- * Generic package descriptions     writeGenericPackageDescription,     showGenericPackageDescription,++    -- * Package descriptions+     writePackageDescription,+     showPackageDescription,++     -- ** Supplementary build information+     writeHookedBuildInfo,+     showHookedBuildInfo, ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.ForeignLib+ import Distribution.PackageDescription import Distribution.Simple.Utils import Distribution.ParseUtils import Distribution.PackageDescription.Parse import Distribution.Package import Distribution.Text+import Distribution.ModuleName -import Data.Monoid as Mon (Monoid(mempty))-import Data.Maybe (isJust) import Text.PrettyPrint-       (hsep, parens, char, nest, empty, isEmpty, ($$), (<+>),-        colon, (<>), text, vcat, ($+$), Doc, render)+       (hsep, space, parens, char, nest, isEmpty, ($$), (<+>),+        colon, text, vcat, ($+$), Doc, render) +import qualified Data.ByteString.Lazy.Char8 as BS.Char8+ -- | Recompile with false for regression testing simplifiedPrinting :: Bool simplifiedPrinting = False  -- | Writes a .cabal file from a generic package description-writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()+writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> NoCallStackIO () writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)  -- | Writes a generic package description to a string@@ -46,11 +61,11 @@ ppGenericPackageDescription gpd          =         ppPackageDescription (packageDescription gpd)         $+$ ppGenPackageFlags (genPackageFlags gpd)-        $+$ ppLibraries (unPackageName (packageName (packageDescription gpd)))-                        (condLibraries gpd)-        $+$ ppExecutables (condExecutables gpd)-        $+$ ppTestSuites (condTestSuites gpd)-        $+$ ppBenchmarks (condBenchmarks gpd)+        $+$ ppCondLibrary (condLibrary gpd)+        $+$ ppCondSubLibraries (condSubLibraries gpd)+        $+$ ppCondExecutables (condExecutables gpd)+        $+$ ppCondTestSuites (condTestSuites gpd)+        $+$ ppCondBenchmarks (condBenchmarks gpd)  ppPackageDescription :: PackageDescription -> Doc ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd@@ -58,7 +73,7 @@                                                 $+$ ppSourceRepos (sourceRepos pd)  ppSourceRepos :: [SourceRepo] -> Doc-ppSourceRepos []                         = empty+ppSourceRepos []                         = mempty ppSourceRepos (hd:tl)                    = ppSourceRepo hd $+$ ppSourceRepos tl  ppSourceRepo :: SourceRepo -> Doc@@ -96,7 +111,7 @@ ppCustomFields flds                      = vcat [ppCustomField f | f <- flds]  ppCustomField :: (String,String) -> Doc-ppCustomField (name,val)                 = text name <> colon <+> showFreeText val+ppCustomField (name,val)                 = text name <<>> colon <+> showFreeText val  ppGenPackageFlags :: [Flag] -> Doc ppGenPackageFlags flds                   = vcat [ppFlag f | f <- flds]@@ -107,44 +122,50 @@   where     fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag -ppLibraries :: String -> [(String, CondTree ConfVar [Dependency] Library)] -> Doc-ppLibraries pn libs                           =-    vcat [emptyLine $ text (if n == pn then "library" else "library " ++ n)+ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc+ppCondLibrary Nothing = mempty+ppCondLibrary (Just condTree) =+    emptyLine $ text "library"+        $+$ nest indentWith (ppCondTree condTree Nothing ppLib) +ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> Doc+ppCondSubLibraries libs                           =+    vcat [emptyLine $ (text "library " <+> disp n)               $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs]-  where-    ppLib lib Nothing     = ppFieldsFiltered libDefaults libFieldDescrs lib-                            $$  ppCustomFields (customFieldsBI (libBuildInfo lib))-    ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib-                            $$  ppCustomFields (customFieldsBI (libBuildInfo lib)) -ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc-ppExecutables exes                       =-    vcat [emptyLine $ text ("executable " ++ n)+ppLib :: Library -> Maybe Library -> Doc+ppLib lib Nothing     = ppFieldsFiltered libDefaults libFieldDescrs lib+                        $$  ppCustomFields (customFieldsBI (libBuildInfo lib))+ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib+                        $$  ppCustomFields (customFieldsBI (libBuildInfo lib))++ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc+ppCondExecutables exes                       =+    vcat [emptyLine $ (text "executable " <+> disp n)               $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]   where     ppExe (Executable _ modulePath' buildInfo') Nothing =-        (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')+        (if modulePath' == "" then mempty else text "main-is:" <+> text modulePath')             $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo'             $+$  ppCustomFields (customFieldsBI buildInfo')     ppExe (Executable _ modulePath' buildInfo')             (Just (Executable _ modulePath2 buildInfo2)) =             (if modulePath' == "" || modulePath' == modulePath2-                then empty else text "main-is:" <+> text modulePath')+                then mempty else text "main-is:" <+> text modulePath')             $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2             $+$ ppCustomFields (customFieldsBI buildInfo') -ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc-ppTestSuites suites =-    emptyLine $ vcat [     text ("test-suite " ++ n)+ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc+ppCondTestSuites suites =+    emptyLine $ vcat [     (text "test-suite " <+> disp n)                        $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)                      | (n,condTree) <- suites]   where     ppTestSuite testsuite Nothing =-                maybe empty (\t -> text "type:"        <+> disp t)+                maybe mempty (\t -> text "type:"        <+> disp t)                             maybeTestType-            $+$ maybe empty (\f -> text "main-is:"     <+> text f)+            $+$ maybe mempty (\f -> text "main-is:"     <+> text f)                             (testSuiteMainIs testsuite)-            $+$ maybe empty (\m -> text "test-module:" <+> disp m)+            $+$ maybe mempty (\m -> text "test-module:" <+> disp m)                             (testSuiteModule testsuite)             $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)             $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))@@ -152,10 +173,10 @@         maybeTestType | testInterface testsuite == mempty = Nothing                       | otherwise = Just (testType testsuite) -    ppTestSuite (TestSuite _ _ buildInfo' _)-                    (Just (TestSuite _ _ buildInfo2 _)) =-            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2-            $+$ ppCustomFields (customFieldsBI buildInfo')+    ppTestSuite test' (Just test2) =+            ppDiffFields binfoFieldDescrs+                (testBuildInfo test') (testBuildInfo test2)+            $+$ ppCustomFields (customFieldsBI (testBuildInfo test'))      testSuiteMainIs test = case testInterface test of       TestSuiteExeV10 _ f -> Just f@@ -165,16 +186,16 @@       TestSuiteLibV09 _ m -> Just m       _                   -> Nothing -ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc-ppBenchmarks suites =-    emptyLine $ vcat [     text ("benchmark " ++ n)+ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc+ppCondBenchmarks suites =+    emptyLine $ vcat [     (text "benchmark " <+> disp n)                        $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)                      | (n,condTree) <- suites]   where     ppBenchmark benchmark Nothing =-                maybe empty (\t -> text "type:"        <+> disp t)+                maybe mempty (\t -> text "type:"        <+> disp t)                             maybeBenchmarkType-            $+$ maybe empty (\f -> text "main-is:"     <+> text f)+            $+$ maybe mempty (\f -> text "main-is:"     <+> text f)                             (benchmarkMainIs benchmark)             $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)             $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))@@ -182,10 +203,10 @@         maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing                            | otherwise = Just (benchmarkType benchmark) -    ppBenchmark (Benchmark _ _ buildInfo' _)-                    (Just (Benchmark _ _ buildInfo2 _)) =-            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2-            $+$ ppCustomFields (customFieldsBI buildInfo')+    ppBenchmark bench' (Just bench2) =+            ppDiffFields binfoFieldDescrs+                (benchmarkBuildInfo bench') (benchmarkBuildInfo bench2)+            $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo bench'))      benchmarkMainIs benchmark = case benchmarkInterface benchmark of       BenchmarkExeV10 _ f -> Just f@@ -194,19 +215,19 @@ ppCondition :: Condition ConfVar -> Doc ppCondition (Var x)                      = ppConfVar x ppCondition (Lit b)                      = text (show b)-ppCondition (CNot c)                     = char '!' <> (ppCondition c)+ppCondition (CNot c)                     = char '!' <<>> (ppCondition c) ppCondition (COr c1 c2)                  = parens (hsep [ppCondition c1, text "||"                                                          <+> ppCondition c2]) ppCondition (CAnd c1 c2)                 = parens (hsep [ppCondition c1, text "&&"                                                          <+> ppCondition c2]) ppConfVar :: ConfVar -> Doc-ppConfVar (OS os)                        = text "os"   <> parens (disp os)-ppConfVar (Arch arch)                    = text "arch" <> parens (disp arch)-ppConfVar (Flag name)                    = text "flag" <> parens (ppFlagName name)-ppConfVar (Impl c v)                     = text "impl" <> parens (disp c <+> disp v)+ppConfVar (OS os)                        = text "os"   <<>> parens (disp os)+ppConfVar (Arch arch)                    = text "arch" <<>> parens (disp arch)+ppConfVar (Flag name)                    = text "flag" <<>> parens (ppFlagName name)+ppConfVar (Impl c v)                     = text "impl" <<>> parens (disp c <+> disp v)  ppFlagName :: FlagName -> Doc-ppFlagName (FlagName name)               = text name+ppFlagName                               = text . unFlagName  ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =@@ -229,7 +250,7 @@            -> Doc ppIf' it ppIt c thenTree =   if isEmpty thenDoc-     then Mon.mempty+     then mempty      else ppIfCondition c $$ nest indentWith thenDoc   where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt @@ -240,7 +261,7 @@               -> Doc ppIfElse it ppIt c thenTree elseTree =   case (isEmpty thenDoc, isEmpty elseDoc) of-    (True,  True)  -> Mon.mempty+    (True,  True)  -> mempty     (False, True)  -> ppIfCondition c $$ nest indentWith thenDoc     (True,  False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc     (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc)@@ -251,3 +272,113 @@ emptyLine :: Doc -> Doc emptyLine d                              = text "" $+$ d +-- | @since 1.26.0.0@+writePackageDescription :: FilePath -> PackageDescription -> NoCallStackIO ()+writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)++--TODO: make this use section syntax+-- add equivalent for GenericPackageDescription++-- | @since 1.26.0.0@+showPackageDescription :: PackageDescription -> String+showPackageDescription pkg = render $+     ppPackageDescription pkg+     $+$ ppMaybeLibrary (library pkg)+     $+$ ppSubLibraries (subLibraries pkg)+     $+$ ppForeignLibs  (foreignLibs pkg)+     $+$ ppExecutables  (executables pkg)+     $+$ ppTestSuites   (testSuites pkg)+     $+$ ppBenchmarks   (benchmarks pkg)++ppMaybeLibrary :: Maybe Library -> Doc+ppMaybeLibrary Nothing = mempty+ppMaybeLibrary (Just lib) =+    emptyLine $ text "library"+        $+$ nest indentWith (ppFields libFieldDescrs lib)++ppSubLibraries :: [Library] -> Doc+ppSubLibraries libs = vcat [+    emptyLine $ text "library" <+> disp libname+        $+$ nest indentWith (ppFields libFieldDescrs lib)+    | lib@Library{ libName = Just libname } <- libs ]++ppForeignLibs :: [ForeignLib] -> Doc+ppForeignLibs flibs = vcat [+    emptyLine $ text "foreign library" <+> disp flibname+        $+$ nest indentWith (ppFields foreignLibFieldDescrs flib)+    | flib@ForeignLib{ foreignLibName = flibname } <- flibs ]++ppExecutables :: [Executable] -> Doc+ppExecutables exes = vcat [+    emptyLine $ text "executable" <+> disp (exeName exe)+        $+$ nest indentWith (ppFields executableFieldDescrs exe)+    | exe <- exes ]++ppTestSuites :: [TestSuite] -> Doc+ppTestSuites tests = vcat [+    emptyLine $ text "test-suite" <+> disp (testName test)+        $+$ nest indentWith (ppFields testSuiteFieldDescrs test_stanza)+    | test <- tests+    , let test_stanza+            = TestSuiteStanza {+                testStanzaTestType = Just (testSuiteInterfaceToTestType (testInterface test)),+                testStanzaMainIs = testSuiteInterfaceToMaybeMainIs (testInterface test),+                testStanzaTestModule = testSuiteInterfaceToMaybeModule (testInterface test),+                testStanzaBuildInfo = testBuildInfo test+            }+    ]++testSuiteInterfaceToTestType :: TestSuiteInterface -> TestType+testSuiteInterfaceToTestType (TestSuiteExeV10 ver _) = TestTypeExe ver+testSuiteInterfaceToTestType (TestSuiteLibV09 ver _) = TestTypeLib ver+testSuiteInterfaceToTestType (TestSuiteUnsupported ty) = ty++testSuiteInterfaceToMaybeMainIs :: TestSuiteInterface -> Maybe FilePath+testSuiteInterfaceToMaybeMainIs (TestSuiteExeV10 _ fp) = Just fp+testSuiteInterfaceToMaybeMainIs TestSuiteLibV09{} = Nothing+testSuiteInterfaceToMaybeMainIs TestSuiteUnsupported{} = Nothing++testSuiteInterfaceToMaybeModule :: TestSuiteInterface -> Maybe ModuleName+testSuiteInterfaceToMaybeModule (TestSuiteLibV09 _ mod_name) = Just mod_name+testSuiteInterfaceToMaybeModule TestSuiteExeV10{} = Nothing+testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing++ppBenchmarks :: [Benchmark] -> Doc+ppBenchmarks benchs = vcat [+    emptyLine $ text "benchmark" <+> disp (benchmarkName bench)+        $+$ nest indentWith (ppFields benchmarkFieldDescrs bench_stanza)+    | bench <- benchs+    , let bench_stanza = BenchmarkStanza {+                benchmarkStanzaBenchmarkType = Just (benchmarkInterfaceToBenchmarkType (benchmarkInterface bench)),+                benchmarkStanzaMainIs = benchmarkInterfaceToMaybeMainIs (benchmarkInterface bench),+                benchmarkStanzaBenchmarkModule = Nothing,+                benchmarkStanzaBuildInfo = benchmarkBuildInfo bench+            }]++benchmarkInterfaceToBenchmarkType :: BenchmarkInterface -> BenchmarkType+benchmarkInterfaceToBenchmarkType (BenchmarkExeV10 ver _)   = BenchmarkTypeExe ver+benchmarkInterfaceToBenchmarkType (BenchmarkUnsupported ty) = ty++benchmarkInterfaceToMaybeMainIs :: BenchmarkInterface -> Maybe FilePath+benchmarkInterfaceToMaybeMainIs (BenchmarkExeV10 _ fp) = Just fp+benchmarkInterfaceToMaybeMainIs BenchmarkUnsupported{} = Nothing+++-- | @since 1.26.0.0@+writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> NoCallStackIO ()+writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack+                             . showHookedBuildInfo++-- | @since 1.26.0.0@+showHookedBuildInfo :: HookedBuildInfo -> String+showHookedBuildInfo (mb_lib_bi, ex_bis) = render $+     (case mb_lib_bi of+        Nothing -> mempty+        Just bi -> ppBuildInfo bi)+   $$ vcat [    space+             $$ (text "executable:" <+> disp name)+             $$ ppBuildInfo bi+           | (name, bi) <- ex_bis ]+  where+     ppBuildInfo bi = ppFields binfoFieldDescrs bi+                   $$ ppCustomFields (customFieldsBI bi)
cabal/Cabal/Distribution/ParseUtils.hs view
@@ -19,6 +19,7 @@ -- This module is meant to be local-only to Distribution...  {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE Rank2Types #-} module Distribution.ParseUtils (         LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,         runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,@@ -27,18 +28,21 @@         showFields, showSingleNamedField, showSimpleSingleNamedField,         parseFields, parseFieldsFlat,         parseFilePathQ, parseTokenQ, parseTokenQ',-        parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,-        parseOptVersion, parsePackageNameQ, parseVersionRangeQ,+        parseModuleNameQ,+        parseOptVersion, parsePackageNameQ,         parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,         parseSepList, parseCommaList, parseOptCommaList,         showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,         field, simpleField, listField, listFieldWithSep, spaceListField,         commaListField, commaListFieldWithSep, commaNewLineListField,-        optsField, liftField, boolField, parseQuoted, indentWith,+        optsField, liftField, boolField, parseQuoted, parseMaybeQuoted, indentWith,          UnrecFieldParser, warnUnrec, ignoreUnrec,   ) where +import Prelude ()+import Distribution.Compat.Prelude hiding (get)+ import Distribution.Compiler import Distribution.License import Distribution.Version@@ -49,22 +53,22 @@ import Distribution.ReadE import Distribution.Text import Distribution.Simple.Utils+import Distribution.PrettyUtils import Language.Haskell.Extension -import Text.PrettyPrint hiding (braces)-import Data.Char (isSpace, toLower, isAlphaNum, isDigit)-import Data.Maybe       (fromMaybe)+import Text.PrettyPrint+    ( Doc, render, style, renderStyle+    , text, colon, nest, punctuate, comma, sep+    , fsep, hsep, isEmpty, vcat, mode, Mode (..)+    , ($+$), (<+>)+    ) import Data.Tree as Tree (Tree(..), flatten) import qualified Data.Map as Map-import Control.Monad (foldM, ap)-import Control.Applicative as AP (Applicative(..)) import System.FilePath (normalise)-import Data.List (sortBy)  -- -----------------------------------------------------------------------------  type LineNo    = Int-type Separator = ([Doc] -> Doc)  data PError = AmbiguousParse String LineNo             | NoParse String LineNo@@ -96,7 +100,7 @@   instance Monad ParseResult where-        return = AP.pure+        return = pure         ParseFailed err >>= _ = ParseFailed err         ParseOk ws x >>= f = case f x of                                ParseFailed err -> ParseFailed err@@ -268,9 +272,9 @@  ppField :: String -> Doc -> Doc ppField name fielddoc-   | isEmpty fielddoc         = empty-   | name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc-   | otherwise                = text name <> colon <+> fielddoc+   | isEmpty fielddoc         = mempty+   | name `elem` nestedFields = text name <<>> colon $+$ nest indentWith fielddoc+   | otherwise                = text name <<>> colon <+> fielddoc    where       nestedFields =          [ "description"@@ -285,6 +289,7 @@          , "includes"          , "install-includes"          , "other-modules"+         , "autogen-modules"          , "depends"          ] @@ -384,14 +389,14 @@  readFields :: String -> ParseResult [Field] readFields input = ifelse-               =<< mapM (mkField 0)+               =<< traverse (mkField 0)                =<< mkTree tokens    where ls = (lines . normaliseLineEndings) input         tokens = (concatMap tokeniseLine . trimLines) ls  readFieldsFlat :: String -> ParseResult [Field]-readFieldsFlat input = mapM (mkField 0)+readFieldsFlat input = traverse (mkField 0)                    =<< mkTree tokens   where ls = (lines . normaliseLineEndings) input         tokens = (concatMap tokeniseLineFlat . trimLines) ls@@ -565,7 +570,7 @@                         then tabsError n                         else return $ F n (map toLower name)                                           (fieldValue rest' followingLines)-    rest'       -> do ts' <- mapM (mkField (d+1)) ts+    rest'       -> do ts' <- traverse (mkField (d+1)) ts                       return (Section n (map toLower name) rest' ts')  where    fieldValue firstLine followingLines =             let firstLine' = trimLeading firstLine@@ -607,7 +612,7 @@  -- |parse a module name parseModuleNameQ :: ReadP r ModuleName-parseModuleNameQ = parseQuoted parse <++ parse+parseModuleNameQ = parseMaybeQuoted parse  parseFilePathQ :: ReadP r FilePath parseFilePathQ = parseTokenQ@@ -620,46 +625,16 @@                        skipSpaces                        return res -parseBuildTool :: ReadP r Dependency-parseBuildTool = do name <- parseBuildToolNameQ-                    ver <- betweenSpaces $-                           parseVersionRangeQ <++ return anyVersion-                    return $ Dependency name ver--parseBuildToolNameQ :: ReadP r PackageName-parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName---- like parsePackageName but accepts symbols in components-parseBuildToolName :: ReadP r PackageName-parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')-                        return (PackageName (intercalate "-" ns))-  where component = do-          cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_')-          if all isDigit cs then pfail else return cs---- pkg-config allows versions and other letters in package names,--- eg "gtk+-2.0" is a valid pkg-config package _name_.--- It then has a package version number like 2.10.13-parsePkgconfigDependency :: ReadP r Dependency-parsePkgconfigDependency = do name <- munch1-                                      (\c -> isAlphaNum c || c `elem` "+-._")-                              ver <- betweenSpaces $-                                     parseVersionRangeQ <++ return anyVersion-                              return $ Dependency (PackageName name) ver- parsePackageNameQ :: ReadP r PackageName-parsePackageNameQ = parseQuoted parse <++ parse--parseVersionRangeQ :: ReadP r VersionRange-parseVersionRangeQ = parseQuoted parse <++ parse+parsePackageNameQ = parseMaybeQuoted parse  parseOptVersion :: ReadP r Version-parseOptVersion = parseQuoted ver <++ ver+parseOptVersion = parseMaybeQuoted ver   where ver :: ReadP r Version-        ver = parse <++ return (Version [] [])+        ver = parse <++ return nullVersion  parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)-parseTestedWithQ = parseQuoted tw <++ tw+parseTestedWithQ = parseMaybeQuoted tw   where     tw :: ReadP r (CompilerFlavor,VersionRange)     tw = do compiler <- parseCompilerFlavorCompat@@ -667,7 +642,7 @@             return (compiler,version)  parseLicenseQ :: ReadP r License-parseLicenseQ = parseQuoted parse <++ parse+parseLicenseQ = parseMaybeQuoted parse  -- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a -- because the "compat" version of ReadP isn't quite powerful enough.  In@@ -675,10 +650,10 @@ -- Hence the trick above to make 'lic' polymorphic.  parseLanguageQ :: ReadP r Language-parseLanguageQ = parseQuoted parse <++ parse+parseLanguageQ = parseMaybeQuoted parse  parseExtensionQ :: ReadP r Extension-parseExtensionQ = parseQuoted parse <++ parse+parseExtensionQ = parseMaybeQuoted parse  parseHaskellString :: ReadP r String parseHaskellString = readS_to_P reads@@ -710,41 +685,8 @@ parseQuoted :: ReadP r a -> ReadP r a parseQuoted = between (ReadP.char '"') (ReadP.char '"') +parseMaybeQuoted :: (forall r. ReadP r a) -> ReadP r' a+parseMaybeQuoted p = parseQuoted p <++ p+ parseFreeText :: ReadP.ReadP s String parseFreeText = ReadP.munch (const True)---- ----------------------------------------------- ** Pretty printing--showFilePath :: FilePath -> Doc-showFilePath "" = empty-showFilePath x  = showToken x--showToken :: String -> Doc-showToken str- | not (any dodgy str) &&-   not (null str)       = text str- | otherwise            = text (show str)-  where dodgy c = isSpace c || c == ','--showTestedWith :: (CompilerFlavor,VersionRange) -> Doc-showTestedWith (compiler, version) = text (show compiler) <+> disp version---- | Pretty-print free-format text, ensuring that it is vertically aligned,--- and with blank lines replaced by dots for correct re-parsing.-showFreeText :: String -> Doc-showFreeText "" = empty-showFreeText s  = vcat [text (if null l then "." else l) | l <- lines_ s]---- | 'lines_' breaks a string up into a list of strings at newline--- characters.  The resulting strings do not contain newlines.-lines_                   :: String -> [String]-lines_ []                =  [""]-lines_ s                 =  let (l, s') = break (== '\n') s-                            in  l : case s' of-                                        []    -> []-                                        (_:s'') -> lines_ s''---- | the indentation used for pretty printing-indentWith :: Int-indentWith = 4
+ cabal/Cabal/Distribution/Parsec/Class.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE FlexibleContexts #-}+module Distribution.Parsec.Class (+    Parsec(..),+    -- * Warnings+    parsecWarning,+    -- * Utilities+    parsecTestedWith,+    parsecToken,+    parsecToken',+    parsecFilePath,+    parsecQuoted,+    parsecMaybeQuoted,+    parsecCommaList,+    parsecOptCommaList,+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import           Data.Functor.Identity                        (Identity)+import qualified Distribution.Compat.Parsec                   as P+import           Distribution.Parsec.Types.Common+                 (PWarnType (..), PWarning (..), Position (..))+import qualified Text.Parsec                                  as Parsec+import qualified Text.Parsec.Language                         as Parsec+import qualified Text.Parsec.Token                            as Parsec++-- Instances++import           Distribution.Compiler+                 (CompilerFlavor (..), classifyCompilerFlavor)+import           Distribution.License                         (License (..))+import           Distribution.ModuleName                      (ModuleName)+import qualified Distribution.ModuleName                      as ModuleName+import           Distribution.Package+                 (Dependency (..),+                 LegacyExeDependency (..), PkgconfigDependency (..),+                 UnqualComponentName, mkUnqualComponentName,+                 PackageName, mkPackageName,+                 PkgconfigName, mkPkgconfigName)+import           Distribution.System+                 (Arch (..), ClassificationStrictness (..), OS (..),+                 classifyArch, classifyOS)+import           Distribution.Text                            (display)+import           Distribution.Types.BenchmarkType+                 (BenchmarkType (..))+import           Distribution.Types.BuildType                 (BuildType (..))+import           Distribution.Types.GenericPackageDescription (FlagName, mkFlagName)+import           Distribution.Types.ModuleReexport+                 (ModuleReexport (..))+import           Distribution.Types.SourceRepo+                 (RepoKind, RepoType, classifyRepoKind, classifyRepoType)+import           Distribution.Types.TestType                  (TestType (..))+import           Distribution.Types.ForeignLibType            (ForeignLibType (..))+import           Distribution.Types.ForeignLibOption          (ForeignLibOption (..))+import           Distribution.Types.ModuleRenaming+import           Distribution.Types.IncludeRenaming+import           Distribution.Types.Mixin+import           Distribution.Version+                 (Version, VersionRange (..), anyVersion, earlierVersion,+                 intersectVersionRanges, laterVersion, majorBoundVersion,+                 mkVersion, noVersion, orEarlierVersion, orLaterVersion,+                 thisVersion, unionVersionRanges, withinVersion)+import           Language.Haskell.Extension+                 (Extension, Language, classifyExtension, classifyLanguage)++-------------------------------------------------------------------------------+-- Class+-------------------------------------------------------------------------------++-- |+--+-- TODO: implementation details: should be careful about consuming trailing whitespace?+-- Should we always consume it?+class Parsec a where+    parsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a++    -- | 'parsec' /could/ consume trailing spaces, this function /must/ consume.+    lexemeParsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a+    lexemeParsec = parsec <* P.spaces++parsecWarning :: PWarnType -> String -> P.Parsec s [PWarning] ()+parsecWarning t w =+    Parsec.modifyState (PWarning t (Position 0 0) w :)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++-- TODO: use lexemeParsec++-- TODO avoid String+parsecUnqualComponentName :: P.Stream s Identity Char => P.Parsec s [PWarning] String+parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-')+  where+    component :: P.Stream s Identity Char => P.Parsec s [PWarning] String+    component = do+      cs <- P.munch1 isAlphaNum+      if all isDigit cs+        then fail "all digits in portion of unqualified component name"+        else return cs++instance Parsec UnqualComponentName where+  parsec = mkUnqualComponentName <$> parsecUnqualComponentName++instance Parsec PackageName where+  parsec = mkPackageName <$> parsecUnqualComponentName++instance Parsec PkgconfigName where+  parsec = mkPkgconfigName <$> P.munch1 (\c -> isAlphaNum c || c `elem` "+-._")++instance Parsec ModuleName where+    parsec = ModuleName.fromComponents <$> P.sepBy1 component (P.char '.')+      where+        component = do+            c  <- P.satisfy isUpper+            cs <- P.munch validModuleChar+            return (c:cs)++        validModuleChar :: Char -> Bool+        validModuleChar c = isAlphaNum c || c == '_' || c == '\''++instance Parsec FlagName where+    parsec = mkFlagName . map toLower . intercalate "-" <$> P.sepBy1 component (P.char '-')+      where+        -- http://hackage.haskell.org/package/cabal-debian-4.24.8/cabal-debian.cabal+        -- has flag with all digit component: pretty-112+        component :: P.Stream s Identity Char => P.Parsec s [PWarning] String+        component = P.munch1 (\c -> isAlphaNum c || c `elem` "_")++instance Parsec Dependency where+    parsec = do+        name <- lexemeParsec+        ver  <- parsec <|> pure anyVersion+        return (Dependency name ver)++instance Parsec LegacyExeDependency where+    parsec = do+        name <- parsecMaybeQuoted nameP+        P.spaces+        verRange <- parsecMaybeQuoted parsec <|> pure anyVersion+        pure $ LegacyExeDependency name verRange+      where+        nameP = intercalate "-" <$> P.sepBy1 component (P.char '-')+        component = do+            cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_')+            if all isDigit cs then fail "invalid component" else return cs++instance Parsec PkgconfigDependency where+    parsec = do+        name <- parsec+        P.spaces+        verRange <- parsec <|> pure anyVersion+        pure $ PkgconfigDependency name verRange++instance Parsec Version where+    parsec = mkVersion <$>+        P.sepBy1 P.integral (P.char '.')+        <* tags+      where+        tags = do+            ts <- P.optionMaybe $ some $ P.char '-' *> some (P.satisfy isAlphaNum)+            case ts of+                Nothing -> pure ()+                -- TODO: make this warning severe+                Just _  -> parsecWarning PWTVersionTag "version with tags"++-- TODO: this is not good parsec code+-- use lexer, also see D.P.ConfVar+instance Parsec VersionRange where+    parsec = expr+      where+        expr   = do P.spaces+                    t <- term+                    P.spaces+                    (do _  <- P.string "||"+                        P.spaces+                        e <- expr+                        return (unionVersionRanges t e)+                     <|>+                     return t)+        term   = do f <- factor+                    P.spaces+                    (do _  <- P.string "&&"+                        P.spaces+                        t <- term+                        return (intersectVersionRanges f t)+                     <|>+                     return f)+        factor = P.choice+            $ parens expr+            : parseAnyVersion+            : parseNoVersion+            : parseWildcardRange+            : map parseRangeOp rangeOps+        parseAnyVersion    = P.string "-any" >> return anyVersion+        parseNoVersion     = P.string "-none" >> return noVersion++        parseWildcardRange = P.try $ do+          _ <- P.string "=="+          P.spaces+          branch <- some (P.integral <* P.char '.')+          _ <- P.char '*'+          return (withinVersion (mkVersion branch))++        parens p = P.between+            (P.char '(' >> P.spaces)+            (P.char ')' >> P.spaces)+            (do a <- p+                P.spaces+                return (VersionRangeParens a))++        -- TODO: make those non back-tracking+        parseRangeOp (s,f) = P.try (P.string s *> P.spaces *> fmap f parsec)+        rangeOps = [ ("<",  earlierVersion),+                     ("<=", orEarlierVersion),+                     (">",  laterVersion),+                     (">=", orLaterVersion),+                     ("^>=", majorBoundVersion),+                     ("==", thisVersion) ]++instance Parsec Language where+    parsec = classifyLanguage <$> P.munch1 isAlphaNum++instance Parsec Extension where+    parsec = classifyExtension <$> P.munch1 isAlphaNum++instance Parsec RepoType where+    parsec = classifyRepoType <$> P.munch1 isIdent++instance Parsec RepoKind where+    parsec = classifyRepoKind <$> P.munch1 isIdent++instance Parsec License where+  parsec = do+    name    <- P.munch1 isAlphaNum+    version <- P.optionMaybe (P.char '-' *> parsec)+    return $! case (name, version :: Maybe Version) of+      ("GPL",               _      ) -> GPL  version+      ("LGPL",              _      ) -> LGPL version+      ("AGPL",              _      ) -> AGPL version+      ("BSD2",              Nothing) -> BSD2+      ("BSD3",              Nothing) -> BSD3+      ("BSD4",              Nothing) -> BSD4+      ("ISC",               Nothing) -> ISC+      ("MIT",               Nothing) -> MIT+      ("MPL",         Just version') -> MPL version'+      ("Apache",            _      ) -> Apache version+      ("PublicDomain",      Nothing) -> PublicDomain+      ("AllRightsReserved", Nothing) -> AllRightsReserved+      ("OtherLicense",      Nothing) -> OtherLicense+      _                              -> UnknownLicense $ name +++                                        maybe "" (('-':) . display) version++instance Parsec BuildType where+  parsec = do+    name <- P.munch1 isAlphaNum+    return $ case name of+      "Simple"    -> Simple+      "Configure" -> Configure+      "Custom"    -> Custom+      "Make"      -> Make+      _           -> UnknownBuildType name++instance Parsec TestType where+  parsec = stdParse $ \ver name -> case name of+      "exitcode-stdio" -> TestTypeExe ver+      "detailed"       -> TestTypeLib ver+      _                -> TestTypeUnknown name ver++instance Parsec BenchmarkType where+    parsec = stdParse $ \ver name -> case name of+       "exitcode-stdio" -> BenchmarkTypeExe ver+       _                -> BenchmarkTypeUnknown name ver++instance Parsec ForeignLibType where+  parsec = do+    name <- P.munch1 (\c -> isAlphaNum c || c == '-')+    return $ case name of+      "native-shared" -> ForeignLibNativeShared+      "native-static" -> ForeignLibNativeStatic+      _               -> ForeignLibTypeUnknown++instance Parsec ForeignLibOption where+  parsec = do+    name <- P.munch1 (\c -> isAlphaNum c || c == '-')+    case name of+      "standalone" -> return ForeignLibStandalone+      _            -> fail "unrecognized foreign-library option"++instance Parsec OS where+    parsec = classifyOS Compat <$> parsecIdent++instance Parsec Arch where+    parsec = classifyArch Strict <$> parsecIdent++instance Parsec CompilerFlavor where+    parsec = classifyCompilerFlavor <$> component+      where+        component :: P.Stream s Identity Char => P.Parsec s [PWarning] String+        component = do+          cs <- P.munch1 isAlphaNum+          if all isDigit cs then fail "all digits compiler name" else return cs++instance Parsec ModuleReexport where+    parsec = do+        mpkgname <- P.optionMaybe (P.try $ parsec <* P.char ':')+        origname <- parsec+        newname  <- P.option origname $ P.try $ do+            P.spaces+            _ <- P.string "as"+            P.spaces+            parsec+        return (ModuleReexport mpkgname origname newname)++instance Parsec ModuleRenaming where+    -- NB: try not necessary as the first token is obvious+    parsec = P.choice [ parseRename, parseHiding, return DefaultRenaming ]+      where+        parseRename = do+            rns <- P.between (P.char '(') (P.char ')') parseList+            P.spaces+            return (ModuleRenaming rns)+        parseHiding = do+            _ <- P.string "hiding"+            P.spaces+            hides <- P.between (P.char '(') (P.char ')')+                        (P.sepBy parsec (P.char ',' >> P.spaces))+            return (HidingRenaming hides)+        parseList =+            P.sepBy parseEntry (P.char ',' >> P.spaces)+        parseEntry = do+            orig <- parsec+            P.spaces+            P.option (orig, orig) $ do+                _ <- P.string "as"+                P.spaces+                new <- parsec+                P.spaces+                return (orig, new)++instance Parsec IncludeRenaming where+    parsec = do+        prov_rn <- parsec+        req_rn <- P.option defaultRenaming $ P.try $ do+            P.spaces+            _ <- P.string "requires"+            P.spaces+            parsec+        return (IncludeRenaming prov_rn req_rn)++instance Parsec Mixin where+    parsec = do+        mod_name <- parsec+        P.spaces+        incl <- parsec+        return (Mixin mod_name incl)++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++isIdent :: Char -> Bool+isIdent c = isAlphaNum c || c == '_' || c == '-'++parsecTestedWith :: P.Stream s Identity Char => P.Parsec s [PWarning] (CompilerFlavor, VersionRange)+parsecTestedWith = do+    name <- lexemeParsec+    ver  <- parsec <|> pure anyVersion+    return (name, ver)++parsecToken :: P.Stream s Identity Char => P.Parsec s [PWarning] String+parsecToken = parsecHaskellString <|> (P.munch1 (\x -> not (isSpace x) && x /= ',')  P.<?> "identifier" )++parsecToken' :: P.Stream s Identity Char => P.Parsec s [PWarning] String+parsecToken' = parsecHaskellString <|> (P.munch1 (not . isSpace) P.<?> "token")++parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] String+parsecFilePath = parsecToken++-- | Parse a benchmark/test-suite types.+stdParse+    :: P.Stream s Identity Char+    => (Version -> String -> a)+    -> P.Parsec s [PWarning] a+stdParse f = do+    -- TODO: this backtracks+    cs   <- some $ P.try (component <* P.char '-')+    ver  <- parsec+    let name = map toLower (intercalate "-" cs)+    return $! f ver name+  where+    component = do+      cs <- P.munch1 isAlphaNum+      if all isDigit cs then fail "all digit component" else return cs+      -- each component must contain an alphabetic character, to avoid+      -- ambiguity in identifiers like foo-1 (the 1 is the version number).++parsecCommaList+    :: P.Stream s Identity Char+    => P.Parsec s [PWarning] a+    -> P.Parsec s [PWarning] [a]+parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces)++parsecOptCommaList+    :: P.Stream s Identity Char+    => P.Parsec s [PWarning] a+    -> P.Parsec s [PWarning] [a]+parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma)+  where+    comma = P.char ',' *>  P.spaces+++-- | Content isn't unquoted+parsecQuoted+     :: P.Stream s Identity Char+     => P.Parsec s [PWarning] a+     -> P.Parsec s [PWarning] a+parsecQuoted = P.between (P.char '"') (P.char '"')++-- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@.+parsecMaybeQuoted+     :: P.Stream s Identity Char+     => P.Parsec s [PWarning] a+     -> P.Parsec s [PWarning] a+parsecMaybeQuoted p = parsecQuoted p <|> p++parsecHaskellString :: P.Stream s Identity Char => P.Parsec s [PWarning] String+parsecHaskellString = Parsec.stringLiteral $ Parsec.makeTokenParser Parsec.emptyDef+    { Parsec.commentStart   = "{-"+    , Parsec.commentEnd     = "-}"+    , Parsec.commentLine    = "--"+    , Parsec.nestedComments = True+    , Parsec.identStart     = P.satisfy isAlphaNum+    , Parsec.identLetter    = P.satisfy isAlphaNum <|> P.oneOf "_'"+    , Parsec.opStart        = opl+    , Parsec.opLetter       = opl+    , Parsec.reservedOpNames= []+    , Parsec.reservedNames  = []+    , Parsec.caseSensitive  = True+    }+  where+    opl = P.oneOf ":!#$%&*+./<=>?@\\^|-~"++parsecIdent :: P.Stream s Identity Char => P.Parsec s [PWarning] String+parsecIdent = (:) <$> firstChar <*> rest+  where+    firstChar = P.satisfy isAlpha+    rest      = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')
+ cabal/Cabal/Distribution/Parsec/ConfVar.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}+module Distribution.Parsec.ConfVar (parseConditionConfVar) where++import           Prelude ()+import           Distribution.Compat.Prelude+import           Distribution.Compat.Parsec                   (integral)+import           Distribution.Parsec.Class                    (Parsec (..))+import           Distribution.Parsec.Types.Common+import           Distribution.Parsec.Types.Field              (SectionArg (..))+import           Distribution.Parsec.Types.ParseResult+import           Distribution.Simple.Utils                    (fromUTF8BS)+import           Distribution.Types.GenericPackageDescription+                 (Condition (..), ConfVar (..))+import           Distribution.Version+                 (anyVersion, earlierVersion, intersectVersionRanges,+                 laterVersion, majorBoundVersion, mkVersion, noVersion,+                 orEarlierVersion, orLaterVersion, thisVersion,+                 unionVersionRanges, withinVersion)+import qualified Text.Parsec                                  as P+import qualified Text.Parsec.Error                            as P++-- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec+-- based outline parser.+parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)+parseConditionConfVar args = do+    -- preprocess glued operators+    args' <- preprocess args+    -- The name of the input file is irrelevant, as we reformat the error message.+    case P.runParser (parser <* P.eof) () "<condition>" args' of+        Right x  -> pure x+        Left err -> do+            -- Mangle the position to the actual one+            let ppos = P.errorPos err+            let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos)+            let msg = P.showErrorMessages+                    "or" "unknown parse error" "expecting" "unexpected" "end of input"+                    (P.errorMessages err)+            parseFailure epos msg+            pure $ Lit True++-- This is a hack, as we have "broken" .cabal files on Hackage+--+-- There are glued operators "&&!" (no whitespace) in some cabal files.+-- E.g. http://hackage.haskell.org/package/hblas-0.2.0.0/hblas.cabal+preprocess :: [SectionArg Position] -> ParseResult [SectionArg Position]+preprocess (SecArgOther pos "&&!" : rest) = do+    parseWarning pos PWTGluedOperators "Glued operators: &&!"+    (\rest' -> SecArgOther pos "&&" : SecArgOther pos "!" : rest') <$> preprocess rest+preprocess (x : rest) =+    (x: ) <$> preprocess rest+preprocess [] = pure []++type Parser = P.Parsec [SectionArg Position] ()++parser :: Parser (Condition ConfVar)+parser = condOr+  where+    condOr       = P.sepBy1 condAnd (oper "||") >>= return . foldl1 COr+    condAnd      = P.sepBy1 cond    (oper "&&") >>= return . foldl1 CAnd+    cond         = P.choice+         [ boolLiteral, parens condOr,  notCond, osCond, archCond, flagCond, implCond ]++    notCond      = CNot <$ oper "!" <*> cond++    boolLiteral  = Lit <$> boolLiteral'+    osCond       = Var . OS   <$ string "os"   <*> parens fromParsec+    flagCond     = Var . Flag <$ string "flag" <*> parens fromParsec+    archCond     = Var . Arch <$ string "arch" <*> parens fromParsec+    implCond     = Var        <$ string "impl" <*> parens implCond'++    implCond'    = Impl+        <$> fromParsec+        <*> P.option anyVersion versionRange++    version = fromParsec+    versionStar  = mkVersion <$> fromParsec' versionStar' <* oper "*"+    versionStar' = some (integral <* P.char '.')++    versionRange = expr+      where+        expr = foldl1 unionVersionRanges     <$> P.sepBy1 term   (oper "||")+        term = foldl1 intersectVersionRanges <$> P.sepBy1 factor (oper "&&")++        factor = P.choice+            $ parens expr+            : parseAnyVersion+            : parseNoVersion+            : parseWildcardRange+            : map parseRangeOp rangeOps++        parseAnyVersion    = anyVersion <$ string "-any"+        parseNoVersion     = noVersion  <$ string "-none"++        parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar++        parseRangeOp (s,f) = P.try (f <$ oper s <*> version)+        rangeOps = [ ("<",  earlierVersion),+                     ("<=", orEarlierVersion),+                     (">",  laterVersion),+                     (">=", orLaterVersion),+                     ("^>=", majorBoundVersion),+                     ("==", thisVersion) ]++    -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1"+    ident = tokenPrim $ \t -> case t of+        SecArgName _ s -> Just $ fromUTF8BS s+        SecArgNum  _ s -> Just $ fromUTF8BS s+        _              -> Nothing++    boolLiteral' = tokenPrim $ \t -> case t of+        SecArgName _ s+            | s == "True"  -> Just True+            | s == "true"  -> Just True+            | s == "False" -> Just False+            | s == "false" -> Just False+        _                  -> Nothing++    string s = tokenPrim $ \t -> case t of+        SecArgName _ s' | s == s' -> Just ()+        _                         -> Nothing++    oper o = tokenPrim $ \t -> case t of+        SecArgOther _ o' | o == o' -> Just ()+        _                          -> Nothing++    parens = P.between (oper "(") (oper ")")++    tokenPrim = P.tokenPrim prettySectionArg updatePosition+    -- TODO: check where the errors are reported+    updatePosition x _ _ = x+    prettySectionArg = show++    fromParsec :: Parsec a => Parser a+    fromParsec = fromParsec' parsec++    fromParsec' p = do+        i <- ident+        case P.runParser (p <* P.eof) [] "<ident>" i of+            Right x  -> pure x+            -- TODO: better lifting or errors / warnings+            Left err -> fail $ show err
+ cabal/Cabal/Distribution/Parsec/Lexer.x view
@@ -0,0 +1,269 @@+{+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Parsec.Lexer+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Lexer for the cabal files.+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#ifdef CABAL_PARSEC_DEBUG+{-# LANGUAGE PatternGuards #-}+#endif+module Distribution.Parsec.Lexer+  (ltest, lexToken, Token(..), LToken(..)+  ,bol_section, in_section, in_field_layout, in_field_braces+  ,mkLexState) where++import Prelude ()+import qualified Prelude as Prelude+import Distribution.Compat.Prelude++import Distribution.Parsec.LexerMonad+import Distribution.Parsec.Types.Common (Position (..), incPos, retPos)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B.Char8+import qualified Data.Word as Word++#ifdef CABAL_PARSEC_DEBUG+import Debug.Trace+import qualified Data.Vector as V+import qualified Data.Text   as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+#endif++}+-- Various character classes++$space           = \          -- single space char+$digit           = 0-9        -- digits+$alpha           = [a-z A-Z]  -- alphabetic characters+$symbol          = [\= \< \> \+ \* \- \& \| \! \$ \% \^ \@ \# \? \/ \\ \~]+$ctlchar         = [\x0-\x1f \x7f]+$printable       = \x0-\x10ffff # $ctlchar   -- so no \n \r+$nbsp            = \xa0+$spacetab        = [$space \t]+$bom             = \xfeff+$nbspspacetab    = [$nbsp $space \t]++$paren           = [ \( \) \[ \] ]+$field_layout    = [$printable \t]+$field_layout'   = [$printable] # [$space]+$field_braces    = [$printable \t] # [\{ \}]+$field_braces'   = [$printable] # [\{ \} $space]+$comment         = [$printable \t]+$namecore        = [$alpha]+$nameextra       = [$namecore $digit \- \_ \. \']+$instr           = [$printable $space] # [\"]+$instresc        = $printable++@nl          = \n | \r\n | \r+@name        = $nameextra* $namecore $nameextra*+@string      = \" ( $instr | \\ $instresc )* \"+@numlike     = $digit [$digit \.]*+@oplike      = [ \, \. \= \< \> \+ \* \- \& \| \! \$ \% \^ \@ \# \? \/ \\ \~ ]+++tokens :-++<0> {+  $bom   { \_ _ _ -> addWarning LexWarningBOM "Byte-order mark found at the beginning of the file" >> lexToken }+  ()     ;+}++<bol_section, bol_field_layout, bol_field_braces> {+  $nbspspacetab* @nl         { \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken }+  -- no @nl here to allow for comments on last line of the file with no trailing \n+  $spacetab* "--" $comment*  ;  -- TODO: check the lack of @nl works here+                                -- including counting line numbers+}++<bol_section> {+  $nbspspacetab*  --TODO prevent or record leading tabs+                   { \pos len inp -> checkWhitespace len inp >>+                                     if B.length inp == len+                                       then return (L pos EOF)+                                       else setStartCode in_section+                                         >> return (L pos (Indent len)) }+  $spacetab* \{    { tok  OpenBrace }+  $spacetab* \}    { tok  CloseBrace }+}++<in_section> {+  $spacetab+   ; --TODO: don't allow tab as leading space++  "--" $comment* ;++  @name        { toki TokSym }+  @string      { \p l i -> case reads (B.Char8.unpack (B.take l i)) of+                             [(str,[])] -> return (L p (TokStr str))+                             _          -> lexicalError p i }+  @numlike     { toki TokNum }+  @oplike      { toki TokOther }+  $paren       { toki TokOther }+  \:           { tok  Colon }+  \{           { tok  OpenBrace }+  \}           { tok  CloseBrace }+  @nl          { \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken }+}++<bol_field_layout> {+  $spacetab*   --TODO prevent or record leading tabs+                { \pos len inp -> if B.length inp == len+                                    then return (L pos EOF)+                                    else setStartCode in_field_layout+                                      >> return (L pos (Indent len)) }+}++<in_field_layout> {+  $spacetab+; --TODO prevent or record leading tabs+  $field_layout' $field_layout*  { toki TokFieldLine }+  @nl             { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken }+}++<bol_field_braces> {+   ()                { \_ _ _ -> setStartCode in_field_braces >> lexToken }+}++<in_field_braces> {+  $spacetab+; --TODO prevent or record leading tabs+  $field_braces' $field_braces*    { toki TokFieldLine }+  \{                { tok  OpenBrace  }+  \}                { tok  CloseBrace }+  @nl               { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken }+}++{++-- | Tokens of outer cabal file structure. Field values are treated opaquely.+data Token = TokSym   !ByteString       -- ^ Haskell-like identifier+           | TokStr   !String           -- ^ String in quotes+           | TokNum   !ByteString       -- ^ Integral+           | TokOther !ByteString       -- ^ Operator like token+           | Indent   !Int              -- ^ Indentation token+           | TokFieldLine !ByteString   -- ^ Lines after @:@+           | Colon+           | OpenBrace+           | CloseBrace+           | EOF+           | LexicalError InputStream --TODO: add separate string lexical error+  deriving Show++data LToken = L !Position !Token+  deriving Show++toki :: Monad m => (ByteString -> Token) -> Position -> Int -> ByteString -> m LToken+toki t pos  len  input = return $! L pos (t (B.take len input))++tok :: Monad m => Token -> Position -> t -> t1 -> m LToken+tok  t pos _len _input = return $! L pos t++checkWhitespace :: Int -> ByteString -> Lex ()+checkWhitespace len bs+    | B.any (== 194) (B.take len bs) =+          addWarning LexWarningNBSP "Non-breaking space found"+    | otherwise = return ()++-- -----------------------------------------------------------------------------+-- The input type++type AlexInput = InputStream++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar _ = error "alexInputPrevChar not used"++alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput)+alexGetByte = B.uncons++lexicalError :: Position -> InputStream -> Lex LToken+lexicalError pos inp = do+  setInput B.empty+  return $! L pos (LexicalError inp)++lexToken :: Lex LToken+lexToken = do+  pos <- getPos+  inp <- getInput+  st  <- getStartCode+  case alexScan inp st of+    AlexEOF -> return (L pos EOF)+    AlexError inp' ->+        let !len_bytes = B.length inp - B.length inp' in+            --FIXME: we want len_chars here really+            -- need to decode utf8 up to this point+        lexicalError (incPos len_bytes pos) inp'+    AlexSkip  inp' len_chars -> do+        checkPosition pos inp inp' len_chars+        adjustPos (incPos len_chars)+        setInput inp'+        lexToken+    AlexToken inp' len_chars action -> do+        checkPosition pos inp inp' len_chars+        adjustPos (incPos len_chars)+        setInput inp'+        let !len_bytes = B.length inp - B.length inp'+        t <- action pos len_bytes inp+        --traceShow t $ return tok+        return t+++checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex ()+#ifdef CABAL_PARSEC_DEBUG+checkPosition pos@(Position lineno colno) inp inp' len_chars = do+    text_lines <- getDbgText+    let len_bytes = B.length inp - B.length inp'+        pos_txt   | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1)))+                  | otherwise = T.empty+        real_txt  = B.take len_bytes inp+    when (pos_txt /= T.decodeUtf8 real_txt) $+      traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $+      traceShow (take 3 (V.toList text_lines)) $ return ()+  where+    getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt+#else+checkPosition _ _ _ _ = return ()+#endif++lexAll :: Lex [LToken]+lexAll = do+  t <- lexToken+  case t of+    L _ EOF -> return [t]+    _       -> do ts <- lexAll+                  return (t : ts)++ltest :: Int -> String -> Prelude.IO ()+ltest code s =+  let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s)+   in traverse_ print ws >> traverse_ print xs+++mkLexState :: ByteString -> LexState+mkLexState input = LexState+  { curPos   = Position 1 1+  , curInput = input+  , curCode  = bol_section+  , warnings = []+#ifdef CABAL_PARSEC_DEBUG+  , dbgText  = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input+#endif+  }++#ifdef CABAL_PARSEC_DEBUG+lines' :: T.Text -> [T.Text]+lines' s1+  | T.null s1 = []+  | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of+                  (l, s2) | Just (c,s3) <- T.uncons s2+                         -> case T.uncons s3 of+                              Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4+                              _                           -> l `T.snoc` c : lines' s3++                          | otherwise+                         -> [l]+#endif+}
+ cabal/Cabal/Distribution/Parsec/LexerMonad.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Parsec.LexerMonad+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+module Distribution.Parsec.LexerMonad (+    InputStream,+    LexState(..),+    LexResult(..),++    Lex(..),+    execLexer,++    getPos,+    setPos,+    adjustPos,++    getInput,+    setInput,++    getStartCode,+    setStartCode,++    LexWarning(..),+    LexWarningType(..),+    addWarning,+    toPWarning,++  ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import qualified Data.ByteString                  as B+import           Distribution.Parsec.Types.Common+                 (PWarnType (..), PWarning (..), Position (..))++#ifdef CABAL_PARSEC_DEBUG+-- testing only:+import qualified Data.Text                        as T+import qualified Data.Text.Encoding               as T+import qualified Data.Vector                      as V+#endif++-- simple state monad+newtype Lex a = Lex { unLex :: LexState -> LexResult a }++instance Functor Lex where+  fmap = liftM++instance Applicative Lex where+  pure = returnLex+  (<*>) = ap++instance Monad Lex where+  return = pure+  (>>=)  = thenLex++data LexResult a = LexResult {-# UNPACK #-} !LexState a++data LexWarningType+    = LexWarningNBSP  -- ^ Encountered non breaking space+    | LexWarningBOM   -- ^ BOM at the start of the cabal file+  deriving (Show)++data LexWarning = LexWarning                !LexWarningType+                             {-# UNPACK #-} !Position+                                            !String+  deriving (Show)++toPWarning :: LexWarning -> PWarning+toPWarning (LexWarning t p s) = PWarning t' p s+  where+    t' = case t of+        LexWarningNBSP -> PWTLexNBSP+        LexWarningBOM  -> PWTLexBOM++data LexState = LexState {+        curPos   :: {-# UNPACK #-} !Position,        -- ^ position at current input location+        curInput :: {-# UNPACK #-} !InputStream,     -- ^ the current input+        curCode  :: {-# UNPACK #-} !StartCode,       -- ^ lexer code+        warnings :: [LexWarning]+#ifdef CABAL_PARSEC_DEBUG+        , dbgText  :: V.Vector T.Text                -- ^ input lines, to print pretty debug info+#endif+     } --TODO: check if we should cache the first token+       -- since it looks like parsec's uncons can be called many times on the same input++type StartCode   = Int    -- ^ An @alex@ lexer start code+type InputStream = B.ByteString++++-- | Execute the given lexer on the supplied input stream.+execLexer :: Lex a -> InputStream -> ([LexWarning], a)+execLexer (Lex lexer) input =+    case lexer initialState of+      LexResult LexState{ warnings = ws } result -> (ws, result)+  where+    initialState = LexState+      -- TODO: add 'startPosition'+      { curPos   = Position 1 1+      , curInput = input+      , curCode  = 0+      , warnings = []+#ifdef CABAL_PARSEC_DEBUG+      , dbgText  = V.fromList . T.lines . T.decodeUtf8 $ input+#endif+      }++{-# INLINE returnLex #-}+returnLex :: a -> Lex a+returnLex a = Lex $ \s -> LexResult s a++{-# INLINE thenLex #-}+thenLex :: Lex a -> (a -> Lex b) -> Lex b+(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s'++setPos :: Position -> Lex ()+setPos pos = Lex $ \s -> LexResult s{ curPos = pos } ()++getPos :: Lex Position+getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos++adjustPos :: (Position -> Position) -> Lex ()+adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } ()++getInput :: Lex InputStream+getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i++setInput :: InputStream -> Lex ()+setInput i = Lex $ \s -> LexResult s{ curInput = i } ()++getStartCode :: Lex Int+getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c++setStartCode :: Int -> Lex ()+setStartCode c = Lex $ \s -> LexResult s{ curCode = c } ()++-- | Add warning at the current position+addWarning :: LexWarningType -> String -> Lex ()+addWarning wt msg = Lex $ \s@LexState{ curPos = pos, warnings = ws  } ->+    LexResult s{ warnings = LexWarning wt pos msg : ws } ()
+ cabal/Cabal/Distribution/Parsec/Parser.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PatternGuards         #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Parsec.Parser+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+module Distribution.Parsec.Parser (+    -- * Types+    Field(..),+    Name(..),+    FieldLine(..),+    SectionArg(..),+    -- * Grammar and parsing+    -- $grammar+    readFields,+    readFields',+#ifdef CABAL_PARSEC_DEBUG+    -- * Internal+    parseFile,+    parseStr,+    parseBS,+#endif+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import           Control.Monad                    (guard)+import qualified Data.ByteString                  as B+import qualified Data.ByteString.Char8            as B8+import           Data.Functor.Identity+import           Distribution.Parsec.Lexer+import           Distribution.Parsec.LexerMonad+                 (LexResult (..), LexState (..), LexWarning (..),+                 LexWarningType (..), unLex)+import           Distribution.Parsec.Types.Common+import           Distribution.Parsec.Types.Field+import           Distribution.Utils.String+import           Text.Parsec.Combinator           hiding (eof, notFollowedBy)+import           Text.Parsec.Error+import           Text.Parsec.Pos+import           Text.Parsec.Prim                 hiding (many, (<|>))++#ifdef CABAL_PARSEC_DEBUG+import qualified Data.Text                        as T+import qualified Data.Text.Encoding               as T+import qualified Data.Text.Encoding.Error         as T+#endif++-- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream'+-- wrapped around lexer's 'LexState' (without a prime)+data LexState' = LexState' !LexState (LToken, LexState')++mkLexState' :: LexState -> LexState'+mkLexState' st = LexState' st+                   (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st'))++type Parser a = ParsecT LexState' () Identity a++instance Stream LexState' Identity LToken where+  uncons (LexState' _ (tok, st')) =+    case tok of+      L _ EOF -> return Nothing+      _       -> return (Just (tok, st'))++-- | Get lexer warnings accumulated so far+getLexerWarnings :: Parser [LexWarning]+getLexerWarnings = do+  LexState' (LexState { warnings = ws }) _ <- getInput+  return ws++-- | Set Alex code i.e. the mode "state" lexer is in.+setLexerMode :: Int -> Parser ()+setLexerMode code = do+  LexState' ls _ <- getInput+  setInput $! mkLexState' ls { curCode = code }++getToken :: (Token -> Maybe a) -> Parser a+getToken getTok = getTokenWithPos (\(L _ t) -> getTok t)++getTokenWithPos :: (LToken -> Maybe a) -> Parser a+getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTok+  where+    updatePos :: SourcePos -> LToken -> LexState' -> SourcePos+    updatePos pos (L (Position col line) _) _ = newPos (sourceName pos) col line++describeToken :: Token -> String+describeToken t = case t of+  TokSym   s      -> "name "   ++ show s+  TokStr   s      -> "string " ++ show s+  TokNum   s      -> "number " ++ show s+  TokOther s      -> "symbol " ++ show s+  Indent _        -> "new line"+  TokFieldLine _  -> "field content"+  Colon           -> "\":\""+  OpenBrace       -> "\"{\""+  CloseBrace      -> "\"}\""+--  SemiColon       -> "\";\""+  EOF             -> "end of file"+  LexicalError is -> "character in input " ++ show (B8.head is)++tokName :: Parser (Name Position)+tokName', tokStr, tokNum, tokOther :: Parser (SectionArg Position)+tokIndent :: Parser Int+tokColon, tokOpenBrace, tokCloseBrace :: Parser ()+tokFieldLine :: Parser (FieldLine Position)++tokName       = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x);  _ -> Nothing+tokName'      = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x);  _ -> Nothing+tokStr        = getTokenWithPos $ \t -> case t of L pos (TokStr   x) -> Just (SecArgStr pos x);  _ -> Nothing+tokNum        = getTokenWithPos $ \t -> case t of L pos (TokNum   x) -> Just (SecArgNum pos x);  _ -> Nothing+tokOther      = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x);  _ -> Nothing+tokIndent     = getToken $ \t -> case t of Indent   x -> Just x;  _ -> Nothing+tokColon      = getToken $ \t -> case t of Colon      -> Just (); _ -> Nothing+tokOpenBrace  = getToken $ \t -> case t of OpenBrace  -> Just (); _ -> Nothing+tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing+tokFieldLine  = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing++colon, openBrace, closeBrace :: Parser ()++sectionArg :: Parser (SectionArg Position)+sectionArg   = tokName' <|> tokStr+            <|> tokNum <|> tokOther <?> "section parameter"++fieldSecName :: Parser (Name Position)+fieldSecName = tokName              <?> "field or section name"++colon        = tokColon      <?> "\":\""+openBrace    = tokOpenBrace  <?> "\"{\""+closeBrace   = tokCloseBrace <?> "\"}\""++fieldContent :: Parser (FieldLine Position)+fieldContent = tokFieldLine <?> "field contents"++newtype IndentLevel = IndentLevel Int++zeroIndentLevel :: IndentLevel+zeroIndentLevel = IndentLevel 0++incIndentLevel :: IndentLevel -> IndentLevel+incIndentLevel (IndentLevel i) = IndentLevel (succ i)++indentOfAtLeast :: IndentLevel -> Parser IndentLevel+indentOfAtLeast (IndentLevel i) = try $ do+  j <- tokIndent+  guard (j >= i) <?> "indentation of at least " ++ show i+  return (IndentLevel j)+++newtype LexerMode = LexerMode Int++inLexerMode :: LexerMode -> Parser p -> Parser p+inLexerMode (LexerMode mode) p =+  do setLexerMode mode; x <- p; setLexerMode in_section; return x+++-----------------------+-- Cabal file grammar+--++-- $grammar+--+-- @+-- CabalStyleFile ::= SecElems+--+-- SecElems       ::= SecElem* '\n'?+-- SecElem        ::= '\n' SecElemLayout | SecElemBraces+-- SecElemLayout  ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces+-- SecElemBraces  ::= FieldInline | FieldBraces |                 SectionBraces+-- FieldLayout    ::= name ':' line? ('\n' line)*+-- FieldBraces    ::= name ':' '\n'? '{' content '}'+-- FieldInline    ::= name ':' content+-- SectionLayout  ::= name arg* SecElems+-- SectionBraces  ::= name arg* '\n'? '{' SecElems '}'+-- @+--+-- and the same thing but left factored...+--+-- @+-- SecElems              ::= SecElem*+-- SecElem               ::= '\n' name SecElemLayout+--                         |      name SecElemBraces+-- SecElemLayout         ::= ':'   FieldLayoutOrBraces+--                         | arg*  SectionLayoutOrBraces+-- FieldLayoutOrBraces   ::= '\n'? '{' content '}'+--                         | line? ('\n' line)*+-- SectionLayoutOrBraces ::= '\n'? '{' SecElems '\n'? '}'+--                         | SecElems+-- SecElemBraces         ::= ':' FieldInlineOrBraces+--                         | arg* '\n'? '{' SecElems '\n'? '}'+-- FieldInlineOrBraces   ::= '\n'? '{' content '}'+--                         | content+-- @+--+-- Note how we have several productions with the sequence:+--+-- > '\n'? '{'+--+-- That is, an optional newline (and indent) followed by a @{@ token.+-- In the @SectionLayoutOrBraces@ case you can see that this makes it+-- not fully left factored (because @SecElems@ can start with a @\n@).+-- Fully left factoring here would be ugly, and though we could use a+-- lookahead of two tokens to resolve the alternatives, we can't+-- conveniently use Parsec's 'try' here to get a lookahead of only two.+-- So instead we deal with this case in the lexer by making a line+-- where the first non-space is @{@ lex as just the @{@ token, without+-- the usual indent token. Then in the parser we can resolve everything+-- with just one token of lookahead and so without using 'try'.++-- Top level of a file using cabal syntax+--+cabalStyleFile :: Parser [Field Position]+cabalStyleFile = do es <- elements zeroIndentLevel+                    eof+                    return es++-- Elements that live at the top level or inside a section, ie fields+-- and sectionscontent+--+-- elements ::= element*+elements :: IndentLevel -> Parser [Field Position]+elements ilevel = many (element ilevel)++-- An individual element, ie a field or a section. These can either use+-- layout style or braces style. For layout style then it must start on+-- a line on it's own (so that we know its indentation level).+--+-- element ::= '\n' name elementInLayoutContext+--           |      name elementInNonLayoutContext+element :: IndentLevel -> Parser (Field Position)+element ilevel =+      (do ilevel' <- indentOfAtLeast ilevel+          name    <- fieldSecName+          elementInLayoutContext (incIndentLevel ilevel') name)+  <|> (do name    <- fieldSecName+          elementInNonLayoutContext name)++-- An element (field or section) that is valid in a layout context.+-- In a layout context we can have fields and sections that themselves+-- either use layout style or that use braces style.+--+-- elementInLayoutContext ::= ':'  fieldLayoutOrBraces+--                          | arg* sectionLayoutOrBraces+elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position)+elementInLayoutContext ilevel name =+      (do colon; fieldLayoutOrBraces ilevel name)+  <|> (do args  <- many sectionArg+          elems <- sectionLayoutOrBraces ilevel+          return (Section name args elems))++-- An element (field or section) that is valid in a non-layout context.+-- In a non-layout context we can have only have fields and sections that+-- themselves use braces style, or inline style fields.+--+-- elementInNonLayoutContext ::= ':' FieldInlineOrBraces+--                             | arg* '\n'? '{' elements '\n'? '}'+elementInNonLayoutContext :: Name Position -> Parser (Field Position)+elementInNonLayoutContext name =+      (do colon; fieldInlineOrBraces name)+  <|> (do args <- many sectionArg+          openBrace+          elems <- elements zeroIndentLevel+          optional tokIndent+          closeBrace+          return (Section name args elems))++-- The body of a field, using either layout style or braces style.+--+-- fieldLayoutOrBraces   ::= '\n'? '{' content '}'+--                         | line? ('\n' line)*+fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position)+fieldLayoutOrBraces ilevel name = braces <|> fieldLayout+  where+    braces = do+          openBrace+          ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)+          closeBrace+          return (Field name ls)+    fieldLayout = inLexerMode (LexerMode in_field_layout) $ do+          l  <- optionMaybe fieldContent+          ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent)+          return $ case l of+              Nothing -> Field name ls+              Just l' -> Field name (l' : ls)++-- The body of a section, using either layout style or braces style.+--+-- sectionLayoutOrBraces ::= '\n'? '{' elements \n? '}'+--                         | elements+sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position]+sectionLayoutOrBraces ilevel =+      (do openBrace+          elems <- elements zeroIndentLevel+          optional tokIndent+          closeBrace+          return elems)+  <|> (elements ilevel)++-- The body of a field, using either inline style or braces.+--+-- fieldInlineOrBraces   ::= '\n'? '{' content '}'+--                         | content+fieldInlineOrBraces :: Name Position -> Parser (Field Position)+fieldInlineOrBraces name =+      (do openBrace+          ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)+          closeBrace+          return (Field name ls))+  <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent))+          return (Field name ls))+++-- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST.+readFields :: B8.ByteString -> Either ParseError [Field Position]+readFields s = fmap fst (readFields' s)++-- | Like 'readFields' but also return lexer warnings+readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning])+readFields' s = do+    parse parser "the input" lexSt+  where+    parser = do+        fields <- cabalStyleFile+        ws     <- getLexerWarnings+        pure (fields, maybeToList w ++ ws)++    (w, s') = fmap B.pack . recodeStringUtf8 . B.unpack $ s+    lexSt = mkLexState' (mkLexState s')++-- TODO: For some reason alex parser cannot handle BOM.+--+-- There is $bom token in the lexer, but for some reason it's not matched,+-- and alex chockes.+--+-- It might be that I (phadej) don't have enough alex-fu+--+-- Anyway, we probably should operate alex in the byte mode, and do utf8 decoding+-- later in the fields where it's required (as we actually do atm). We'd need+-- alex-3.2 for that.+recodeStringUtf8 :: [Word8] -> (Maybe LexWarning, [Word8])+recodeStringUtf8 (0xef : 0xbb : 0xbf : bytes) =+    ( Just $ LexWarning LexWarningBOM (Position 1 1) "Byte-order mark found"+    , encodeStringUtf8 (decodeStringUtf8 bytes)+    )+recodeStringUtf8 bytes =+    (Nothing, encodeStringUtf8 (decodeStringUtf8 bytes))++#ifdef CABAL_PARSEC_DEBUG+parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO ()+parseTest' p fname s =+    case parse p fname (lexSt s) of+      Left err -> putStrLn (formatError s err)++      Right x  -> print x+  where+    lexSt = mkLexState' . mkLexState++parseFile :: Show a => Parser a -> FilePath -> IO ()+parseFile p f = B8.readFile f >>= \s -> parseTest' p f s++parseStr  :: Show a => Parser a -> String -> IO ()+parseStr p = parseBS p . B8.pack++parseBS  :: Show a => Parser a -> B8.ByteString -> IO ()+parseBS p = parseTest' p "<input string>"++formatError :: B8.ByteString -> ParseError -> String+formatError input perr =+    unlines+      [ "Parse error "++ show (errorPos perr) ++ ":"+      , errLine+      , indicator ++ errmsg ]+  where+    pos       = errorPos perr+    ls        = lines' (T.decodeUtf8With T.lenientDecode input)+    errLine   = T.unpack (ls !! (sourceLine pos - 1))+    indicator = replicate (sourceColumn pos) ' ' ++ "^"+    errmsg    = showErrorMessages "or" "unknown parse error"+                                  "expecting" "unexpected" "end of file"+                                  (errorMessages perr)++-- | Handles windows/osx/unix line breaks uniformly+lines' :: T.Text -> [T.Text]+lines' s1+  | T.null s1 = []+  | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of+                  (l, s2) | Just (c,s3) <- T.uncons s2+                         -> case T.uncons s3 of+                              Just ('\n', s4) | c == '\r' -> l : lines' s4+                              _               -> l : lines' s3+                          | otherwise -> [l]+#endif++eof :: Parser ()+eof = notFollowedBy anyToken <?> "end of file"+  where+    notFollowedBy :: Parser LToken -> Parser ()+    notFollowedBy p = try (    (do L _ t <- try p; unexpected (describeToken t))+                           <|> return ())
+ cabal/Cabal/Distribution/Parsec/Types/Common.hs view
@@ -0,0 +1,89 @@+-- | Module containing small types+module Distribution.Parsec.Types.Common (+    -- * Diagnostics+    PError (..),+    showPError,+    PWarning (..),+    PWarnType (..),+    showPWarning,+    -- * Field parser+    FieldParser,+    -- * Position+    Position (..),+    incPos,+    retPos,+    showPos,+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import           System.FilePath             (normalise)+import qualified Text.Parsec                 as Parsec++-- | Parser error.+data PError = PError Position String+    deriving (Show)++-- | Type of parser warning. We do classify warnings.+--+-- Different application may decide not to show some, or have fatal behaviour on others+data PWarnType+    = PWTOther                 -- ^ Unclassified warning+    | PWTUTF                   -- ^ Invalid UTF encoding+    | PWTBoolCase              -- ^ @true@ or @false@, not @True@ or @False@+    | PWTGluedOperators        -- ^ @&&!@+    | PWTVersionTag            -- ^ there are version with tags+    | PWTNewSyntax             -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified+    | PWTOldSyntax             -- ^ Old syntax used, and @cabal-version >= 1.2@ specified+    | PWTDeprecatedField+    | PWTInvalidSubsection+    | PWTUnknownField+    | PWTUnknownSection+    | PWTTrailingFields+    | PWTExtraMainIs           -- ^ extra main-is field+    | PWTExtraTestModule       -- ^ extra test-module field+    | PWTExtraBenchmarkModule  -- ^ extra benchmark-module field+    | PWTLexNBSP+    | PWTLexBOM+    deriving (Eq, Ord, Show, Enum, Bounded)++-- | Parser warning.+data PWarning = PWarning !PWarnType !Position String+    deriving (Show)++showPWarning :: FilePath -> PWarning -> String+showPWarning fpath (PWarning _ pos msg) =+  normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg++showPError :: FilePath -> PError -> String+showPError fpath (PError pos msg) =+  normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg++-------------------------------------------------------------------------------+-- Field parser+-------------------------------------------------------------------------------++-- | Field value parsers.+type FieldParser = Parsec.Parsec String [PWarning] -- :: * -> *+++-------------------------------------------------------------------------------+-- Position+-------------------------------------------------------------------------------++-- | 1-indexed row and column positions in a file.+data Position = Position+    {-# UNPACK #-}  !Int           -- row+    {-# UNPACK #-}  !Int           -- column+  deriving (Eq, Show)++-- | Shift position by n columns to the right.+incPos :: Int -> Position -> Position+incPos n (Position row col) = Position row (col + n)++-- | Shift position to beginning of next row.+retPos :: Position -> Position+retPos (Position row _col) = Position (row + 1) 1++showPos :: Position -> String+showPos (Position row col) = show row ++ ":" ++ show col
+ cabal/Cabal/Distribution/Parsec/Types/Field.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveFunctor #-}+-- | Cabal-like file AST types: 'Field', 'Section' etc+--+-- These types are parametrized by an annotation.+module Distribution.Parsec.Types.Field (+    -- * Cabal file+    Field (..),+    fieldAnn,+    FieldLine (..),+    SectionArg (..),+    sectionArgAnn,+    -- * Name+    Name (..),+    mkName,+    getName,+    nameAnn,+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import           Data.ByteString             (ByteString)+import qualified Data.ByteString.Char8       as B+import qualified Data.Char                   as Char++-------------------------------------------------------------------------------+-- Cabal file+-------------------------------------------------------------------------------++-- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@).+data Field ann+    = Field   !(Name ann) [FieldLine ann]+    | Section !(Name ann) [SectionArg ann] [Field ann]+  deriving (Eq, Show, Functor)++fieldAnn :: Field ann -> ann+fieldAnn (Field (Name ann _) _)     = ann+fieldAnn (Section (Name ann _) _ _) = ann++-- | A line of text representing the value of a field from a Cabal file.+-- A field may contain multiple lines.+--+-- /Invariant:/ 'ByteString' has no newlines.+data FieldLine ann  = FieldLine  !ann !ByteString+  deriving (Eq, Show, Functor)++-- | Section arguments, e.g. name of the library+data SectionArg ann+    = SecArgName  !ann !ByteString+      -- ^ identifier+    | SecArgStr   !ann !String+      -- ^ quoted string+    | SecArgNum   !ann !ByteString+      -- ^ Something which loos like number. Also many dot numbers, i.e. "7.6.3"+    | SecArgOther !ann !ByteString+      -- ^ everything else, mm. operators (e.g. in if-section conditionals)+  deriving (Eq, Show, Functor)++-- | Extract annotation from 'SectionArg'.+sectionArgAnn :: SectionArg ann -> ann+sectionArgAnn (SecArgName ann _)  = ann+sectionArgAnn (SecArgStr ann _)   = ann+sectionArgAnn (SecArgNum ann _)   = ann+sectionArgAnn (SecArgOther ann _) = ann++-------------------------------------------------------------------------------+-- Name+-------------------------------------------------------------------------------++-- | A field name.+--+-- /Invariant/: 'ByteString' is lower-case ASCII.+data Name ann  = Name       !ann !ByteString+  deriving (Eq, Show, Functor)++mkName :: ann -> ByteString -> Name ann+mkName ann bs = Name ann (B.map Char.toLower bs)++getName :: Name ann -> ByteString+getName (Name _ bs) = bs++nameAnn :: Name ann -> ann+nameAnn (Name ann _) = ann
+ cabal/Cabal/Distribution/Parsec/Types/FieldDescr.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Parsec.Types.FieldDescr+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+module Distribution.Parsec.Types.FieldDescr (+    -- * Field name+    FieldName,+    -- * Field description+    FieldDescr (..),+    liftField,+    simpleField,+    boolField,+    optsField,+    listField,+    listFieldWithSep,+    commaListField,+    commaListFieldWithSep,+    spaceListField,+    -- ** Pretty printing+    ppFields,+    ppField,+    -- * Unknown fields+    UnknownFieldParser,+    warnUnrec,+    ignoreUnrec,+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude      hiding (get)+import qualified Data.ByteString                  as BS+import           Data.Ord                         (comparing)+import qualified Distribution.Compat.Parsec       as P+import           Distribution.Compiler            (CompilerFlavor)+import           Distribution.Parsec.Class+import           Distribution.Parsec.Types.Common+import           Distribution.PrettyUtils+import           Text.PrettyPrint+                 (Doc, colon, comma, fsep, hsep, isEmpty, nest, punctuate,+                 text, vcat, ($+$), (<+>))++type FieldName = BS.ByteString++-------------------------------------------------------------------------------+-- Unrecoginsed fields+-------------------------------------------------------------------------------++-- | How to handle unknown fields.+type UnknownFieldParser a = FieldName -> String -> a -> Maybe a++-- | A default unrecognized field parser which simply returns Nothing,+--   i.e. ignores all unrecognized fields, so warnings will be generated.+warnUnrec :: UnknownFieldParser a+warnUnrec _ _ _ = Nothing++-- | A default unrecognized field parser which silently (i.e. no+--   warnings will be generated) ignores unrecognized fields, by+--   returning the structure being built unmodified.+ignoreUnrec :: UnknownFieldParser a+ignoreUnrec _ _ = Just++-------------------------------------------------------------------------------+-- Field description+-------------------------------------------------------------------------------++data FieldDescr a = FieldDescr+    { fieldName   :: FieldName+    , fieldPretty :: a -> Doc+    , fieldParser :: a -> FieldParser a+    }++liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b+liftField get set fd = FieldDescr+    (fieldName fd)+    (fieldPretty fd . get)+    (\b -> flip set b <$> fieldParser fd (get b))++simpleField+    :: FieldName       -- ^ fieldname+    -> (a -> Doc)      -- ^ show+    -> FieldParser a   -- ^ parser+    -> (b -> a)        -- ^ getter+    -> (a -> b -> b)   -- ^ setter+    -> FieldDescr b+simpleField name pretty parse get set = FieldDescr+    name+    (pretty . get)+    (\a -> flip set a <$> parse)++boolField+    :: FieldName+    -> (b -> Bool)+    -> (Bool -> b -> b)+    -> FieldDescr b+boolField name get set = liftField get set (FieldDescr name showF parseF)+  where+    showF = text . show+    parseF _ = P.munch1 isAlpha >>= postprocess+    postprocess str+        |  str == "True"  = pure True+        |  str == "False" = pure False+        | lstr == "true"  = parsecWarning PWTBoolCase caseWarning *> pure True+        | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False+        | otherwise       = fail $ "Not a boolena: " ++ str+      where+        lstr = map toLower str+        caseWarning =+            "The " ++ show name ++ " field is case sensitive, use 'True' or 'False'."++optsField+    :: FieldName+    -> CompilerFlavor+    -> (b -> [(CompilerFlavor,[String])])+    -> ([(CompilerFlavor,[String])] -> b -> b)+    -> FieldDescr b+optsField name flavor get set = liftField+    (fromMaybe [] . lookup flavor . get)+    (\opts b -> set (reorder (update flavor opts (get b))) b)+    $ field name showF (many $ parsecToken' <* P.munch isSpace)+  where+    update _ opts l | all null opts = l  --empty opts as if no opts+    update f opts [] = [(f,opts)]+    update f opts ((f',opts'):rest)+        | f == f'   = (f, opts' ++ opts) : rest+        | otherwise = (f',opts') : update f opts rest+    reorder = sortBy (comparing fst)+    showF   = hsep . map text++listField+    :: FieldName+    -> (a -> Doc)+    -> FieldParser a+    -> (b -> [a])+    -> ([a] -> b -> b)+    -> FieldDescr b+listField = listFieldWithSep fsep++listFieldWithSep+    :: Separator+    -> FieldName+    -> (a -> Doc)+    -> FieldParser a+    -> (b -> [a])+    -> ([a] -> b -> b)+    -> FieldDescr b+listFieldWithSep separator name showF parseF get set =+    liftField get set' $+        field name showF' (parsecOptCommaList parseF)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = separator . map showF+++commaListField+    :: FieldName -> (a -> Doc) -> FieldParser a+    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaListField = commaListFieldWithSep fsep++commaListFieldWithSep+    :: Separator -> FieldName  -> (a -> Doc) -> FieldParser a+    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaListFieldWithSep separator name showF parseF get set =+    liftField get set' $+        field name showF' (parsecCommaList parseF)+   where+     set' xs b = set (get b ++ xs) b+     showF'    = separator . punctuate comma . map showF++spaceListField+    :: FieldName -> (a -> Doc) -> FieldParser a+    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+spaceListField name showF parseF get set = liftField get set' $+    field name showF' (many $ parseF <* P.spaces)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = fsep . map showF++-- Overriding field+field :: FieldName -> (a -> Doc) -> FieldParser a -> FieldDescr a+field name showF parseF =+    FieldDescr name showF (const parseF)++-------------------------------------------------------------------------------+-- Pretty printing+-------------------------------------------------------------------------------++ppFields :: [FieldDescr a] -> a -> Doc+ppFields fields x =+   vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ]++ppField :: FieldName -> Doc -> Doc+ppField name fielddoc+   | isEmpty fielddoc         = mempty+   | name `elem` nestedFields = text namestr <<>> colon $+$ nest indentWith fielddoc+   | otherwise                = text namestr <<>> colon <+> fielddoc+   where+      namestr = show name -- TODO: do this+      nestedFields :: [BS.ByteString]+      nestedFields =+         [ "description"+         , "build-depends"+         , "data-files"+         , "extra-source-files"+         , "extra-tmp-files"+         , "exposed-modules"+         , "c-sources"+         , "js-sources"+         , "extra-libraries"+         , "includes"+         , "install-includes"+         , "other-modules"+         , "depends"+         ]++-- | Handle deprecated fields+--+-- *TODO:* use Parsec+{-+deprecField :: Field Position -> Parsec (Field Position)+deprecField = undefined  {-+-}++ (Field (Name pos fld) val) = do+  fld' <- case lookup fld deprecatedFields of+            Nothing -> return fld+            Just newName -> do+              warning $ "The field " ++ show fld+                      ++ " is deprecated, please use " ++ show newName+              return newName+  return (Field (Name pos fld') val)+deprecField _ = cabalBug "'deprecField' called on a non-field"+-}
+ cabal/Cabal/Distribution/Parsec/Types/ParseResult.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+-- | A parse result type for parsers from AST to Haskell types.+module Distribution.Parsec.Types.ParseResult (+    ParseResult,+    runParseResult,+    recoverWith,+    parseWarning,+    parseFailure,+    parseFatalFailure,+    parseFatalFailure',+    parseWarnings',+    ) where++import           Prelude ()+import           Distribution.Compat.Prelude+import           Distribution.Parsec.Types.Common+                 (PError (..), PWarnType (..), PWarning (..), Position (..))++-- | A monad with failure and accumulating errors and warnings.+newtype ParseResult a = PR { runPR :: PRState -> (Maybe a, PRState) }++data PRState = PRState ![PWarning] ![PError]++emptyPRState :: PRState+emptyPRState = PRState [] []++-- | Destruct a 'ParseResult' into the emitted warnings and errors, and+-- possibly the final result if there were no errors.+runParseResult :: ParseResult a -> ([PWarning], [PError], Maybe a)+runParseResult pr = case runPR pr emptyPRState of+    (res, PRState warns errs)+        -- If there are any errors, don't return the result+        | null errs -> (warns, [], res)+        | otherwise -> (warns, errs, Nothing)++instance Functor ParseResult where+    fmap f (PR pr) = PR $ \s -> case pr s of+        (r, s') -> (fmap f r, s')++instance Applicative ParseResult where+    pure x = PR $ \s -> (Just x, s)+    -- | Make it concat perrors+    (<*>) = ap+    PR a *> PR b = PR $ \s0 -> case a s0 of+        (x, s1) -> case b s1 of+            (y, s2) -> (x *> y, s2)++instance Monad ParseResult where+    return = pure+    (>>) = (*>)+    PR m >>= k = PR $ \s -> case m s of+        (Nothing, s') -> (Nothing, s')+        (Just x,  s') -> runPR (k x) s'++-- | "Recover" the parse result, so we can proceed parsing.+-- 'runParseResult' will still result in 'Nothing', if there are recorded errors.+recoverWith :: ParseResult a -> a -> ParseResult a+recoverWith (PR f) x = PR $ \s -> case f s of+    (Nothing, s') -> (Just x, s')+    r             -> r++parseWarning :: Position -> PWarnType -> String -> ParseResult ()+parseWarning pos t msg = PR $ \(PRState warns errs) ->+    (Just (), PRState (PWarning t pos msg : warns) errs)++parseWarnings' :: [PWarning] -> ParseResult ()+parseWarnings' newWarns = PR $ \(PRState warns errs) ->+    (Just (), PRState (warns ++ newWarns) errs)++-- | Add an error, but not fail the parser yet.+--+-- For fatal failure use 'parseFatalFailure'+parseFailure :: Position -> String -> ParseResult ()+parseFailure pos msg = PR $ \(PRState warns errs) ->+    (Just (), PRState warns (PError pos msg : errs))++-- | Add an fatal error.+parseFatalFailure :: Position -> String -> ParseResult a+parseFatalFailure pos msg = PR $ \(PRState warns errs) ->+    (Nothing, PRState warns (PError pos msg : errs))++parseFatalFailure' :: ParseResult a+parseFatalFailure' = PR f+  where+    f s@(PRState warns errs)+        | null errs = (Nothing, PRState warns [PError (Position 0 0) "Unknown failure"])+        | otherwise = (Nothing, s)
+ cabal/Cabal/Distribution/PrettyUtils.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PrettyUtils+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Utilities for pretty printing.+{-# OPTIONS_HADDOCK hide #-}+module Distribution.PrettyUtils (+    Separator,+    -- * Internal+    showFilePath,+    showToken,+    showTestedWith,+    showFreeText,+    indentWith,+    ) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Compiler (CompilerFlavor)+import Distribution.Version  (VersionRange)++import Distribution.Text     (disp)+import Text.PrettyPrint      (Doc, text, vcat, (<+>))++type Separator = ([Doc] -> Doc)++showFilePath :: FilePath -> Doc+showFilePath "" = mempty+showFilePath x  = showToken x++showToken :: String -> Doc+showToken str+    | not (any dodgy str) && not (null str)  = text str+    | otherwise                              = text (show str)+  where+    dodgy c = isSpace c || c == ','++showTestedWith :: (CompilerFlavor, VersionRange) -> Doc+showTestedWith (compiler, vr) = text (show compiler) <+> disp vr++-- | Pretty-print free-format text, ensuring that it is vertically aligned,+-- and with blank lines replaced by dots for correct re-parsing.+showFreeText :: String -> Doc+showFreeText "" = mempty+showFreeText s  = vcat [text (if null l then "." else l) | l <- lines_ s]++-- | 'lines_' breaks a string up into a list of strings at newline+-- characters.  The resulting strings do not contain newlines.+lines_                   :: String -> [String]+lines_ []                =  [""]+lines_ s                 =  let (l, s') = break (== '\n') s+                            in  l : case s' of+                                        []    -> []+                                        (_:s'') -> lines_ s''++-- | the indentation used for pretty printing+indentWith :: Int+indentWith = 4
cabal/Cabal/Distribution/ReadE.hs view
@@ -17,8 +17,10 @@    readP_to_E   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Compat.ReadP-import Data.Char ( isSpace )  -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}
cabal/Cabal/Distribution/Simple.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple@@ -45,6 +49,7 @@         -- * Customization         UserHooks(..), Args,         defaultMainWithHooks, defaultMainWithHooksArgs,+        defaultMainWithHooksNoRead,         -- ** Standard sets of hooks         simpleUserHooks,         autoconfUserHooks,@@ -53,12 +58,14 @@         defaultHookedPackageDesc   ) where +import Prelude ()+import Distribution.Compat.Prelude+ -- local import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.UserHooks import Distribution.Package import Distribution.PackageDescription hiding (Flag)-import Distribution.PackageDescription.Parse import Distribution.PackageDescription.Configuration import Distribution.Simple.Program import Distribution.Simple.Program.Db@@ -87,17 +94,23 @@ import Distribution.Text  -- Base-import System.Environment(getArgs, getProgName)-import System.Directory(removeFile, doesFileExist,-                        doesDirectoryExist, removeDirectoryRecursive)-import System.Exit       (exitWith,ExitCode(..))-import System.FilePath(searchPathSeparator)-import Distribution.Compat.Environment (getEnvironment)+import System.Environment (getArgs, getProgName)+import System.Directory   (removeFile, doesFileExist+                          ,doesDirectoryExist, removeDirectoryRecursive)+import System.Exit                          (exitWith,ExitCode(..))+import System.FilePath                      (searchPathSeparator)+import Distribution.Compat.Environment      (getEnvironment)+import Distribution.Compat.GetShortPathName (getShortPathName) -import Control.Monad   (when)-import Data.Foldable   (traverse_)-import Data.List       (unionBy)+import Data.List       (unionBy, (\\)) +#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+import Distribution.PackageDescription.Parse (readHookedBuildInfo)+#else+import Distribution.PackageDescription.Parse+#endif+ -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the -- action specified on the command line.@@ -121,9 +134,13 @@ -- | Like 'defaultMain', but accepts the package description as input -- rather than using IO to read it. defaultMainNoRead :: GenericPackageDescription -> IO ()-defaultMainNoRead pkg_descr =+defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks++-- | A customizable version of 'defaultMainNoRead'.+defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO ()+defaultMainWithHooksNoRead hooks pkg_descr =   getArgs >>=-  defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) }+  defaultMainHelper hooks { readDesc = return (Just pkg_descr) }  defaultMainHelper :: UserHooks -> Args -> IO () defaultMainHelper hooks args = topHandler $@@ -150,10 +167,10 @@     printVersion        = putStrLn $ "Cabal library version "                                   ++ display cabalVersion -    progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration+    progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb     commands =-      [configureCommand progs `commandAddAction` \fs as ->-                                                 configureAction    hooks fs as >> return ()+      [configureCommand progs `commandAddAction`+        \fs as -> configureAction hooks fs as >> return ()       ,buildCommand     progs `commandAddAction` buildAction        hooks       ,replCommand      progs `commandAddAction` replAction         hooks       ,installCommand         `commandAddAction` installAction      hooks@@ -181,18 +198,17 @@ configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do     distPref <- findDistPrefOrDefault (configDistPref flags)-    let flags' = flags { configDistPref = toFlag distPref }+    let flags' = flags { configDistPref = toFlag distPref+                       , configArgs = args }++    -- See docs for 'HookedBuildInfo'     pbi <- preConf hooks args flags' -    (mb_pd_file, pkg_descr0) <- confPkgDescr+    (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity+                                    (flagToMaybe (configCabalFilePath flags)) -    --get_pkg_descr (configVerbosity flags')-    --let pkg_descr = updatePackageDescription pbi pkg_descr0     let epkg_descr = (pkg_descr0, pbi) -    --(warns, ers) <- sanityCheckPackage pkg_descr-    --errorOut (configVerbosity flags') warns ers-     localbuildinfo0 <- confHook hooks epkg_descr flags'      -- remember the .cabal filename if we know it@@ -208,16 +224,25 @@     return localbuildinfo   where     verbosity = fromFlag (configVerbosity flags)-    confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription)-    confPkgDescr = do-        mdescr <- readDesc hooks-        case mdescr of-          Just descr -> return (Nothing, descr)-          Nothing -> do-              pdfile <- defaultPackageDesc verbosity-              descr  <- readPackageDescription verbosity pdfile-              return (Just pdfile, descr) +confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath+             -> IO (Maybe FilePath, GenericPackageDescription)+confPkgDescr hooks verbosity mb_path = do+  mdescr <- readDesc hooks+  case mdescr of+    Just descr -> return (Nothing, descr)+    Nothing -> do+        pdfile <- case mb_path of+                    Nothing -> defaultPackageDesc verbosity+                    Just path -> return path+#ifdef CABAL_PARSEC+        info verbosity "Using Parsec parser"+        descr  <- readGenericPackageDescription verbosity pdfile+#else+        descr  <- readPackageDescription verbosity pdfile+#endif+        return (Just pdfile, descr)+ buildAction :: UserHooks -> BuildFlags -> Args -> IO () buildAction hooks flags args = do   distPref <- findDistPrefOrDefault (buildDistPref flags)@@ -246,10 +271,15 @@              (replProgramArgs flags')              (withPrograms lbi) +  -- As far as I can tell, the only reason this doesn't use+  -- 'hookedActionWithArgs' is because the arguments of 'replHook'+  -- takes the args explicitly.  UGH.   -- ezyang   pbi <- preRepl hooks args flags'-  let lbi' = lbi { withPrograms = progs }-      pkg_descr0 = localPkgDescr lbi'-      pkg_descr = updatePackageDescription pbi pkg_descr0+  let pkg_descr0 = localPkgDescr lbi+  sanityCheckHookedBuildInfo pkg_descr0 pbi+  let pkg_descr = updatePackageDescription pbi pkg_descr0+      lbi' = lbi { withPrograms = progs+                 , localPkgDescr = pkg_descr }   replHook hooks pkg_descr lbi' hooks flags' args   postRepl hooks args flags' pkg_descr lbi' @@ -285,8 +315,13 @@      pbi <- preClean hooks args flags' -    pdfile <- defaultPackageDesc verbosity-    ppd <- readPackageDescription verbosity pdfile+    (_, ppd) <- confPkgDescr hooks verbosity Nothing+    -- It might seem like we are doing something clever here+    -- but we're really not: if you look at the implementation+    -- of 'clean' in the end all the package description is+    -- used for is to clear out @extra-tmp-files@.  IMO,+    -- the configure script goo should go into @dist@ too!+    --          -- ezyang     let pkg_descr0 = flattenPackageDescription ppd     -- We don't sanity check for clean as an error     -- here would prevent cleaning:@@ -323,14 +358,26 @@     pbi <- preSDist hooks args flags'      mlbi <- maybeGetPersistBuildConfig distPref-    pdfile <- defaultPackageDesc verbosity-    ppd <- readPackageDescription verbosity pdfile++    -- NB: It would be TOTALLY WRONG to use the 'PackageDescription'+    -- store in the 'LocalBuildInfo' for the rest of @sdist@, because+    -- that would result in only the files that would be built+    -- according to the user's configure being packaged up.+    -- In fact, it is not obvious why we need to read the+    -- 'LocalBuildInfo' in the first place, except that we want+    -- to do some architecture-independent preprocessing which+    -- needs to be configured.  This is totally awful, see+    -- GH#130.++    (_, ppd) <- confPkgDescr hooks verbosity Nothing+     let pkg_descr0 = flattenPackageDescription ppd     sanityCheckHookedBuildInfo pkg_descr0 pbi     let pkg_descr = updatePackageDescription pbi pkg_descr0+        mlbi' = fmap (\lbi -> lbi { localPkgDescr = pkg_descr }) mlbi -    sDistHook hooks pkg_descr mlbi hooks flags'-    postSDist hooks args flags' pkg_descr mlbi+    sDistHook hooks pkg_descr mlbi' hooks flags'+    postSDist hooks args flags' pkg_descr mlbi'   where     verbosity = fromFlag (sDistVerbosity flags) @@ -366,7 +413,7 @@         flags' = flags { regDistPref = toFlag distPref }     hookedAction preReg regHook postReg                  (getBuildConfig hooks verbosity distPref)-                 hooks flags' args+                 hooks flags' { regArgs = args } args  unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () unregisterAction hooks flags args = do@@ -385,7 +432,8 @@         -> IO LocalBuildInfo         -> UserHooks -> flags -> Args -> IO () hookedAction pre_hook cmd_hook =-    hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags)+    hookedActionWithArgs pre_hook (\h _ pd lbi uh flags ->+                                     cmd_hook h pd lbi uh flags)  hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)         -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo@@ -394,28 +442,31 @@                       -> LocalBuildInfo -> IO ())         -> IO LocalBuildInfo         -> UserHooks -> flags -> Args -> IO ()-hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do+hookedActionWithArgs pre_hook cmd_hook post_hook+  get_build_config hooks flags args = do    pbi <- pre_hook hooks args flags-   localbuildinfo <- get_build_config-   let pkg_descr0 = localPkgDescr localbuildinfo-   --pkg_descr0 <- get_pkg_descr (get_verbose flags)+   lbi0 <- get_build_config+   let pkg_descr0 = localPkgDescr lbi0    sanityCheckHookedBuildInfo pkg_descr0 pbi    let pkg_descr = updatePackageDescription pbi pkg_descr0-   -- TODO: should we write the modified package descr back to the-   -- localbuildinfo?-   cmd_hook hooks args pkg_descr localbuildinfo hooks flags-   post_hook hooks args flags pkg_descr localbuildinfo+       lbi = lbi0 { localPkgDescr = pkg_descr }+   cmd_hook hooks args pkg_descr lbi hooks flags+   post_hook hooks args flags pkg_descr lbi  sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO ()-sanityCheckHookedBuildInfo pkg_descr hooked_bis-    | not (null nonExistentComponents)-    = die $ "The buildinfo contains info for these non-existent components:"-         ++ intercalate ", " (map showComponentName nonExistentComponents)+sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_)+    = die $ "The buildinfo contains info for a library, "+         ++ "but the package does not have a library."++sanityCheckHookedBuildInfo pkg_descr (_, hookExes)+    | not (null nonExistant)+    = die $ "The buildinfo contains info for an executable called '"+         ++ display (head nonExistant) ++ "' but the package does not have a "+         ++ "executable with that name."   where-    nonExistentComponents =-        [ cname-        | (cname, _) <- hooked_bis-        , Nothing <- [lookupComponent pkg_descr cname] ]+    pkgExeNames  = nub (map exeName (executables pkg_descr))+    hookExeNames = nub (map fst hookExes)+    nonExistant  = hookExeNames \\ pkgExeNames  sanityCheckHookedBuildInfo _ _ = return () @@ -425,7 +476,7 @@   lbi_wo_programs <- getPersistBuildConfig distPref   -- Restore info about unconfigured programs, since it is not serialized   let lbi = lbi_wo_programs {-    withPrograms = restoreProgramConfiguration+    withPrograms = restoreProgramDb                      (builtinPrograms ++ hookedPrograms hooks)                      (withPrograms lbi_wo_programs)   }@@ -449,7 +500,7 @@             -- Since the list of unconfigured programs is not serialized,             -- restore it to the same value as normally used at the beginning             -- of a configure run:-            configPrograms_ = restoreProgramConfiguration+            configPrograms_ = restoreProgramDb                                (builtinPrograms ++ hookedPrograms hooks)                                `fmap` configPrograms_ cFlags, @@ -478,13 +529,13 @@       when exists (removeDirectoryRecursive distPref)      -- Any extra files the user wants to remove-    mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)+    traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr)      -- If the user wanted to save the config, write it back     traverse_ (writePersistBuildConfig distPref) maybeConfig    where-        removeFileOrDirectory :: FilePath -> IO ()+        removeFileOrDirectory :: FilePath -> NoCallStackIO ()         removeFileOrDirectory fname = do             isDir <- doesDirectoryExist fname             isFile <- doesFileExist fname@@ -504,7 +555,8 @@        postConf  = finalChecks,        buildHook = defaultBuildHook,        replHook  = defaultReplHook,-       copyHook  = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params+       copyHook  = \desc lbi _ f -> install desc lbi f,+                   -- 'install' has correct 'copy' behavior with params        testHook  = defaultTestHook,        benchHook = defaultBenchHook,        instHook  = defaultInstallHook,@@ -548,7 +600,6 @@     -- https://github.com/haskell/cabal/issues/158     where oldCompatPostConf args flags pkg_descr lbi               = do let verbosity = fromFlag (configVerbosity flags)-                   noExtraFlags args                    confExists <- doesFileExist "configure"                    when confExists $                        runConfigureScript verbosity@@ -557,7 +608,8 @@                    pbi <- getHookedBuildInfo verbosity                    sanityCheckHookedBuildInfo pkg_descr pbi                    let pkg_descr' = updatePackageDescription pbi pkg_descr-                   postConf simpleUserHooks args flags pkg_descr' lbi+                       lbi' = lbi { localPkgDescr = pkg_descr' }+                   postConf simpleUserHooks args flags pkg_descr' lbi'            backwardsCompatHack = True @@ -575,10 +627,10 @@        preReg      = readHook regVerbosity,        preUnreg    = readHook regVerbosity       }-    where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+    where defaultPostConf :: Args -> ConfigFlags -> PackageDescription+                          -> LocalBuildInfo -> IO ()           defaultPostConf args flags pkg_descr lbi               = do let verbosity = fromFlag (configVerbosity flags)-                   noExtraFlags args                    confExists <- doesFileExist "configure"                    if confExists                      then runConfigureScript verbosity@@ -588,11 +640,13 @@                    pbi <- getHookedBuildInfo verbosity                    sanityCheckHookedBuildInfo pkg_descr pbi                    let pkg_descr' = updatePackageDescription pbi pkg_descr-                   postConf simpleUserHooks args flags pkg_descr' lbi+                       lbi' = lbi { localPkgDescr = pkg_descr' }+                   postConf simpleUserHooks args flags pkg_descr' lbi'            backwardsCompatHack = False -          readHookWithArgs :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo+          readHookWithArgs :: (a -> Flag Verbosity) -> Args -> a+                           -> IO HookedBuildInfo           readHookWithArgs get_verbosity _ flags = do               getHookedBuildInfo verbosity             where@@ -609,8 +663,9 @@                    -> IO () runConfigureScript verbosity backwardsCompatHack flags lbi = do   env <- getEnvironment-  let programConfig = withPrograms lbi-  (ccProg, ccFlags) <- configureCCompiler verbosity programConfig+  let programDb = withPrograms lbi+  (ccProg, ccFlags) <- configureCCompiler verbosity programDb+  ccProgShort <- getShortPathName ccProg   -- The C compiler's compilation and linker flags (e.g.   -- "C compiler flags" and "Gcc Linker flags" from GHC) have already   -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS@@ -618,24 +673,32 @@   -- We don't try and tell configure which ld to use, as we don't have   -- a way to pass its flags too   let extraPath = fromNubList $ configProgramPathExtra flags-  let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $ lookup "CFLAGS" env+  let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags))+                  $ lookup "CFLAGS" env       spSep = [searchPathSeparator]-      pathEnv = maybe (intercalate spSep extraPath) ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env-      overEnv = ("CFLAGS", Just cflagsEnv) : [("PATH", Just pathEnv) | not (null extraPath)]-      args' = args ++ ["CC=" ++ ccProg]+      pathEnv = maybe (intercalate spSep extraPath)+                ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env+      overEnv = ("CFLAGS", Just cflagsEnv) :+                [("PATH", Just pathEnv) | not (null extraPath)]+      args' = args ++ ["CC=" ++ ccProgShort]       shProg = simpleProgram "sh"-      progDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb-  shConfiguredProg <- lookupProgram shProg `fmap` configureProgram  verbosity shProg progDb+      progDb = modifyProgramSearchPath+               (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb+  shConfiguredProg <- lookupProgram shProg+                      `fmap` configureProgram  verbosity shProg progDb   case shConfiguredProg of-      Just sh -> runProgramInvocation verbosity (programInvocation (sh {programOverrideEnv = overEnv}) args')+      Just sh -> runProgramInvocation verbosity+                 (programInvocation (sh {programOverrideEnv = overEnv}) args')       Nothing -> die notFoundMsg    where     args = "./configure" : configureArgs backwardsCompatHack flags -    notFoundMsg = "The package has a './configure' script. If you are on Windows, This requires a "+    notFoundMsg = "The package has a './configure' script. "+               ++ "If you are on Windows, This requires a "                ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "-               ++ "If you are not on Windows, ensure that an 'sh' command is discoverable in your path."+               ++ "If you are not on Windows, ensure that an 'sh' command "+               ++ "is discoverable in your path."  getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo getHookedBuildInfo verbosity = do
cabal/Cabal/Distribution/Simple/Bench.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Bench@@ -15,6 +18,10 @@     ( bench     ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler@@ -25,7 +32,6 @@ import Distribution.Simple.Utils import Distribution.Text -import Control.Monad ( when, unless, forM ) import System.Exit ( ExitCode(..), exitFailure, exitSuccess ) import System.Directory ( doesFileExist ) import System.FilePath ( (</>), (<.>) )@@ -40,20 +46,16 @@     let verbosity         = fromFlag $ benchmarkVerbosity flags         benchmarkNames    = args         pkgBenchmarks     = PD.benchmarks pkg_descr-        enabledBenchmarks = [ t | t <- pkgBenchmarks-                            , PD.benchmarkEnabled t-                            , PD.buildable (PD.benchmarkBuildInfo t) ]+        enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)          -- Run the benchmark         doBench :: PD.Benchmark -> IO ExitCode         doBench bm =             case PD.benchmarkInterface bm of               PD.BenchmarkExeV10 _ _ -> do-                  let cmd = LBI.buildDir lbi </> PD.benchmarkName bm-                            </> PD.benchmarkName bm <.> exeExtension+                  let cmd = LBI.buildDir lbi </> name </> name <.> exeExtension                       options = map (benchOption pkg_descr lbi bm) $                                 benchmarkOptions flags-                      name = PD.benchmarkName bm                   -- Check that the benchmark executable exists.                   exists <- doesFileExist cmd                   unless exists $ die $@@ -69,9 +71,10 @@                _ -> do                   notice verbosity $ "No support for running "-                      ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: "-                      ++ show (disp $ PD.benchmarkType bm)+                      ++ "benchmark " ++ name ++ " of type: "+                      ++ display (PD.benchmarkType bm)                   exitFailure+          where name = unUnqualComponentName $ PD.benchmarkName bm      unless (PD.hasBenchmarks pkg_descr) $ do         notice verbosity "Package has no benchmarks."@@ -83,20 +86,20 @@      bmsToRun <- case benchmarkNames of             [] -> return enabledBenchmarks-            names -> forM names $ \bmName ->+            names -> for names $ \bmName ->                 let benchmarkMap = zip enabledNames enabledBenchmarks                     enabledNames = map PD.benchmarkName enabledBenchmarks                     allNames = map PD.benchmarkName pkgBenchmarks-                in case lookup bmName benchmarkMap of+                in case lookup (mkUnqualComponentName bmName) benchmarkMap of                     Just t -> return t-                    _ | bmName `elem` allNames ->+                    _ | mkUnqualComponentName bmName `elem` allNames ->                           die $ "Package configured with benchmark "                                 ++ bmName ++ " disabled."                       | otherwise -> die $ "no such benchmark: " ++ bmName      let totalBenchmarks = length bmsToRun     notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."-    exitcodes <- mapM doBench bmsToRun+    exitcodes <- traverse doBench bmsToRun     let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)     unless allOk exitFailure   where@@ -120,4 +123,4 @@     env = initialPathTemplateEnv           (PD.package pkg_descr) (LBI.localUnitId lbi)           (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]+          [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)]
cabal/Cabal/Distribution/Simple/Build.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Build@@ -23,13 +26,23 @@     writeAutogenFiles,   ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.ForeignLib+ import Distribution.Package+import Distribution.Backpack import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC   as JHC import qualified Distribution.Simple.LHC   as LHC import qualified Distribution.Simple.UHC   as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite+import qualified Distribution.Simple.PackageIndex as Index  import qualified Distribution.Simple.Build.Macros      as Build.Macros import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule@@ -38,6 +51,7 @@ import Distribution.Simple.Compiler hiding (Flag) import Distribution.PackageDescription hiding (Flag) import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.ModuleName as ModuleName  import Distribution.Simple.Setup@@ -56,16 +70,13 @@ import Distribution.Text import Distribution.Verbosity -import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.List-         ( intersect )+import Distribution.Compat.Graph (IsNode(..))+ import Control.Monad-         ( when, unless )-import System.FilePath-         ( (</>), (<.>) )-import System.Directory-         ( getCurrentDirectory )+import qualified Data.Set as Set+import Data.List ( intersect )+import System.FilePath ( (</>), (<.>), takeDirectory )+import System.Directory ( getCurrentDirectory )  -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package.@@ -76,14 +87,12 @@          -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling          -> IO () build pkg_descr lbi flags suffixes = do-  let distPref  = fromFlag (buildDistPref flags)-      verbosity = fromFlag (buildVerbosity flags)--  targets  <- readBuildTargets pkg_descr (buildArgs flags)-  targets' <- checkBuildTargets verbosity pkg_descr targets-  let componentsToBuild = componentsInBuildOrder lbi (map fst targets')+  targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)+  let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)   info verbosity $ "Component build order: "-                ++ intercalate ", " (map (showComponentName . componentLocalName) componentsToBuild)+                ++ intercalate ", "+                    (map (showComponentName . componentLocalName . targetCLBI)+                        componentsToBuild)    when (null targets) $     -- Only bother with this message if we're building the whole package@@ -91,17 +100,24 @@    internalPackageDB <- createInternalPackageDB verbosity lbi distPref -  -- TODO: we're computing this twice, do it once!-  withComponentsInBuildOrder pkg_descr lbi (map fst targets') $ \comp clbi -> do+  (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do+    let comp = targetComponent target+        clbi = targetCLBI target     initialBuildSteps distPref pkg_descr lbi clbi verbosity     let bi     = componentBuildInfo comp         progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)         lbi'   = lbi {                    withPrograms  = progs',-                   withPackageDB = withPackageDB lbi ++ [internalPackageDB]+                   withPackageDB = withPackageDB lbi ++ [internalPackageDB],+                   installedPkgs = index                  }-    buildComponent verbosity (buildNumJobs flags) pkg_descr+    mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr                    lbi' suffixes comp clbi distPref+    return (maybe index (Index.insert `flip` index) mb_ipi)+  return ()+ where+  distPref  = fromFlag (buildDistPref flags)+  verbosity = fromFlag (buildVerbosity flags)   repl     :: PackageDescription  -- ^ Mostly information from the .cabal file@@ -114,17 +130,16 @@   let distPref  = fromFlag (replDistPref flags)       verbosity = fromFlag (replVerbosity flags) -  targets  <- readBuildTargets pkg_descr args-  targets' <- case targets of-    []       -> return $ take 1 [ componentName c-                                | c <- pkgEnabledComponents pkg_descr ]-    [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target])+  target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of+    -- This seems DEEPLY questionable.+    []       -> return (head (allTargetsInBuildOrder' pkg_descr lbi))+    [target] -> return target     _        -> die $ "The 'repl' command does not support multiple targets at once."-  let componentsToBuild = componentsInBuildOrder lbi targets'-      componentForRepl  = last componentsToBuild+  let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]   debug verbosity $ "Component build order: "                  ++ intercalate ", "-                      [ showComponentName (componentLocalName clbi) | clbi <- componentsToBuild ]+                      (map (showComponentName . componentLocalName . targetCLBI)+                           componentsToBuild)    internalPackageDB <- createInternalPackageDB verbosity lbi distPref @@ -137,18 +152,17 @@    -- build any dependent components   sequence_-    [ do let cname = componentLocalName clbi-             comp = getComponent pkg_descr cname+    [ do let clbi = targetCLBI subtarget+             comp = targetComponent subtarget              lbi' = lbiForComponent comp lbi          initialBuildSteps distPref pkg_descr lbi clbi verbosity          buildComponent verbosity NoFlag                         pkg_descr lbi' suffixes comp clbi distPref-    | clbi <- init componentsToBuild ]+    | subtarget <- init componentsToBuild ]    -- REPL for target components-  let clbi = componentForRepl-      cname = componentLocalName clbi-      comp = getComponent pkg_descr cname+  let clbi = targetCLBI target+      comp = targetComponent target       lbi' = lbiForComponent comp lbi   initialBuildSteps distPref pkg_descr lbi clbi verbosity   replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref@@ -171,34 +185,54 @@                -> Component                -> ComponentLocalBuildInfo                -> FilePath-               -> IO ()+               -> IO (Maybe InstalledPackageInfo) buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CLib lib) clbi distPref = do     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi-    info verbosity $ "Building library " ++ libName lib ++ "..."+    case libName lib of+        Nothing -> info verbosity $ "Building library..."+        Just n -> info verbosity $ "Building library " ++ display n ++ "..."     let libbi = libBuildInfo lib         lib' = lib { libBuildInfo = addExtraCSources libbi extras }     buildLib verbosity numJobs pkg_descr lbi lib' clbi -    -- Register the library in-place, so exes can depend-    -- on internally defined libraries.-    pwd <- getCurrentDirectory-    let -- The in place registration uses the "-inplace" suffix, not an ABI hash-        installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr-                                                       (AbiHash "") lib' lbi clbi+    let oneComponentRequested (OneComponentRequestedSpec _) = True+        oneComponentRequested _ = False+    -- Don't register inplace if we're only building a single component;+    -- it's not necessary because there won't be any subsequent builds+    -- that need to tag us+    if (not (oneComponentRequested (componentEnabledSpec lbi)))+      then do+        -- Register the library in-place, so exes can depend+        -- on internally defined libraries.+        pwd <- getCurrentDirectory+        let -- The in place registration uses the "-inplace" suffix, not an ABI hash+            installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr+                                                           (mkAbiHash "") lib' lbi clbi -    registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance-                    (withPackageDB lbi) installedPkgInfo+        debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)+        registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance+                        (withPackageDB lbi) installedPkgInfo+        return (Just installedPkgInfo)+      else return Nothing  buildComponent verbosity numJobs pkg_descr lbi suffixes+               comp@(CFLib flib) clbi _distPref = do+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes+    info verbosity $ "Building foreign library " ++ display (foreignLibName flib) ++ "..."+    buildFLib verbosity numJobs pkg_descr lbi flib clbi+    return Nothing++buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CExe exe) clbi _ = do     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi-    info verbosity $ "Building executable " ++ exeName exe ++ "..."+    info verbosity $ "Building executable " ++ display (exeName exe) ++ "..."     let ebi = buildInfo exe         exe' = exe { buildInfo = addExtraCSources ebi extras }     buildExe verbosity numJobs pkg_descr lbi exe' clbi+    return Nothing   buildComponent verbosity numJobs pkg_descr lbi suffixes@@ -207,10 +241,11 @@     let exe = testSuiteExeV10AsExe test     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi-    info verbosity $ "Building test suite " ++ testName test ++ "..."+    info verbosity $ "Building test suite " ++ display (testName test) ++ "..."     let ebi = buildInfo exe         exe' = exe { buildInfo = addExtraCSources ebi extras }     buildExe verbosity numJobs pkg_descr lbi exe' clbi+    return Nothing   buildComponent verbosity numJobs pkg_descr lbi0 suffixes@@ -227,7 +262,7 @@           testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi-    info verbosity $ "Building test suite " ++ testName test ++ "..."+    info verbosity $ "Building test suite " ++ display (testName test) ++ "..."     buildLib verbosity numJobs pkg lbi lib libClbi     -- NB: need to enable multiple instances here, because on 7.10+     -- the package name is the same as the library, and we still@@ -237,6 +272,7 @@     let ebi = buildInfo exe         exe' = exe { buildInfo = addExtraCSources ebi extras }     buildExe verbosity numJobs pkg_descr lbi exe' exeClbi+    return Nothing -- Can't depend on test suite   buildComponent _ _ _ _ _@@ -251,10 +287,11 @@     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi-    info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."+    info verbosity $ "Building benchmark " ++ display (benchmarkName bm) ++ "..."     let ebi = buildInfo exe         exe' = exe { buildInfo = addExtraCSources ebi extras }     buildExe verbosity numJobs pkg_descr lbi exe' exeClbi+    return Nothing   buildComponent _ _ _ _ _@@ -289,6 +326,11 @@     replLib verbosity pkg_descr lbi lib' clbi  replComponent verbosity pkg_descr lbi suffixes+               comp@(CFLib flib) clbi _ = do+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes+    replFLib verbosity pkg_descr lbi flib clbi++replComponent verbosity pkg_descr lbi suffixes                comp@(CExe exe) clbi _ = do     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi@@ -377,11 +419,10 @@   where     bi  = testBuildInfo test     lib = Library {-            libName = testName test,+            libName = Nothing,             exposedModules = [ m ],             reexportedModules = [],-            requiredSignatures = [],-            exposedSignatures = [],+            signatures = [],             libExposed     = True,             libBuildInfo   = bi           }@@ -392,10 +433,15 @@     compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)     libClbi = LibComponentLocalBuildInfo                 { componentPackageDeps = componentPackageDeps clbi-                , componentLocalName = CLibName (testName test)+                , componentInternalDeps = componentInternalDeps clbi+                , componentIsIndefinite_ = False+                , componentExeDeps = componentExeDeps clbi+                , componentLocalName = CSubLibName (testName test)                 , componentIsPublic = False                 , componentIncludes = componentIncludes clbi                 , componentUnitId = componentUnitId clbi+                , componentComponentId = componentComponentId clbi+                , componentInstantiatedWith = []                 , componentCompatPackageName = compat_name                 , componentCompatPackageKey = compat_key                 , componentExposedModules = [IPI.ExposedModule m Nothing]@@ -405,35 +451,41 @@           , buildDepends = targetBuildDepends $ testBuildInfo test           , executables  = []           , testSuites   = []-          , libraries    = [lib]+          , subLibraries = [lib]           }-    ipi    = inplaceInstalledPackageInfo pwd distPref pkg (AbiHash "") lib lbi libClbi+    ipi    = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi     testDir = buildDir lbi </> stubName test           </> stubName test ++ "-tmp"     testLibDep = thisPackageVersion $ package pkg     exe = Executable {-            exeName    = stubName test,+            exeName    = mkUnqualComponentName $ stubName test,             modulePath = stubFilePath test,             buildInfo  = (testBuildInfo test) {                            hsSourceDirs       = [ testDir ],                            targetBuildDepends = testLibDep-                             : (targetBuildDepends $ testBuildInfo test),-                           targetBuildRenaming = Map.empty+                             : (targetBuildDepends $ testBuildInfo test)                          }           }     -- | The stub executable needs a new 'ComponentLocalBuildInfo'     -- that exposes the relevant test suite library.     deps = (IPI.installedUnitId ipi, packageId ipi)-         : (filter (\(_, x) -> let PackageName name = pkgName x+         : (filter (\(_, x) -> let name = unPackageName $ pkgName x                                in name == "Cabal" || name == "base")                    (componentPackageDeps clbi))     exeClbi = ExeComponentLocalBuildInfo {                 -- TODO: this is a hack, but as long as this is unique                 -- (doesn't clobber something) we won't run into trouble                 componentUnitId = mkUnitId (stubName test),-                componentLocalName = CExeName (stubName test),+                componentComponentId = mkComponentId (stubName test),+                componentInternalDeps = [componentUnitId clbi],+                componentExeDeps = [],+                componentLocalName = CExeName $ mkUnqualComponentName $ stubName test,                 componentPackageDeps = deps,-                componentIncludes = zip (map fst deps) (repeat defaultRenaming)+                -- Assert DefUnitId invariant!+                -- Executable can't be indefinite, so dependencies must+                -- be definite packages.+                componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps)+                                        (repeat defaultRenaming)               } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" @@ -452,7 +504,10 @@           }     exeClbi = ExeComponentLocalBuildInfo {                 componentUnitId = componentUnitId clbi,+                componentComponentId = componentComponentId clbi,                 componentLocalName = CExeName (benchmarkName bm),+                componentInternalDeps = componentInternalDeps clbi,+                componentExeDeps = componentExeDeps clbi,                 componentPackageDeps = componentPackageDeps clbi,                 componentIncludes = componentIncludes clbi               }@@ -465,12 +520,10 @@ createInternalPackageDB verbosity lbi distPref = do     existsAlready <- doesPackageDBExist dbPath     when existsAlready $ deletePackageDB dbPath-    createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath +    createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath     return (SpecificPackageDB dbPath)   where-      dbPath = case compilerFlavor (compiler lbi) of-        UHC -> UHC.inplacePackageDbPath lbi-        _   -> distPref </> "package.conf.inplace"+    dbPath = internalPackageDBPath lbi distPref  addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo                       -> ProgramDb -> ProgramDb@@ -482,10 +535,10 @@       | toolName <- toolNames       , let toolLocation = buildDir lbi </> toolName </> toolName <.> exeExtension ]     toolNames = intersect buildToolNames internalExeNames-    internalExeNames = map exeName (executables pkg)+    internalExeNames = map (unUnqualComponentName . exeName) (executables pkg)     buildToolNames   = map buildToolName (buildTools bi)       where-        buildToolName (Dependency (PackageName name) _ ) = name+        buildToolName (LegacyExeDependency pname _) = pname   -- TODO: build separate libs in separate dirs so that we can build@@ -503,6 +556,18 @@     HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi     _    -> die "Building is not supported with this compiler." +-- | Build a foreign library+--+-- NOTE: We assume that we already checked that we can actually build the+-- foreign library in configure.+buildFLib :: Verbosity -> Flag (Maybe Int)+                       -> PackageDescription -> LocalBuildInfo+                       -> ForeignLib         -> ComponentLocalBuildInfo -> IO ()+buildFLib verbosity numJobs pkg_descr lbi flib clbi =+    case compilerFlavor (compiler lbi) of+      GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi+      _   -> die "Building is not supported with this compiler."+ buildExe :: Verbosity -> Flag (Maybe Int)                       -> PackageDescription -> LocalBuildInfo                       -> Executable         -> ComponentLocalBuildInfo -> IO ()@@ -533,6 +598,12 @@     GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi     _     -> die "A REPL is not supported for this compiler." +replFLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> ForeignLib         -> ComponentLocalBuildInfo -> IO ()+replFLib verbosity pkg_descr lbi exe clbi =+  case compilerFlavor (compiler lbi) of+    GHC -> GHC.replFLib verbosity NoFlag pkg_descr lbi exe clbi+    _   -> die "A REPL is not supported for this compiler."  initialBuildSteps :: FilePath -- ^"dist" prefix                   -> PackageDescription  -- ^mostly information from the .cabal file@@ -541,12 +612,6 @@                   -> Verbosity -- ^The verbosity to use                   -> IO () initialBuildSteps _distPref pkg_descr lbi clbi verbosity = do-  -- check that there's something to build-  unless (not . null $ allBuildInfo pkg_descr) $ do-    let name = display (packageId pkg_descr)-    die $ "No libraries, executables, tests, or benchmarks "-       ++ "are enabled for package " ++ name ++ "."-   createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi)    writeAutogenFiles verbosity pkg_descr lbi clbi@@ -559,11 +624,27 @@                   -> ComponentLocalBuildInfo                   -> IO () writeAutogenFiles verbosity pkg lbi clbi = do-  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi clbi)+  createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi) -  let pathsModulePath = autogenModulesDir lbi clbi-                    </> ModuleName.toFilePath (autogenModuleName pkg) <.> "hs"+  let pathsModulePath = autogenComponentModulesDir lbi clbi+                 </> ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs"   rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi clbi) -  let cppHeaderPath = autogenModulesDir lbi clbi </> cppHeaderName+  --TODO: document what we're doing here, and move it to its own function+  case clbi of+    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->+        -- Write out empty hsig files for all requirements, so that GHC+        -- has a source file to look at it when it needs to typecheck+        -- a signature.  It's harmless to write these out even when+        -- there is a real hsig file written by the user, since+        -- include path ordering ensures that the real hsig file+        -- will always be picked up before the autogenerated one.+        for_ (map fst insts) $ \mod_name -> do+            let sigPath = autogenComponentModulesDir lbi clbi+                      </> ModuleName.toFilePath mod_name <.> "hsig"+            createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath)+            rewriteFile sigPath $ "signature " ++ display mod_name ++ " where"+    _ -> return ()++  let cppHeaderPath = autogenComponentModulesDir lbi clbi </> cppHeaderName   rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi clbi)
cabal/Cabal/Distribution/Simple/Build/Macros.hs view
@@ -22,6 +22,9 @@     generatePackageVersionMacros,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Package import Distribution.Version import Distribution.PackageDescription@@ -30,13 +33,40 @@ import Distribution.Simple.Program.Types import Distribution.Text -import Data.Maybe-         ( isJust )- -- ------------------------------------------------------------ -- * Generate cabal_macros.h -- ------------------------------------------------------------ +-- Invariant: HeaderLines always has a trailing newline+type HeaderLines = String++line :: String -> HeaderLines+line str = str ++ "\n"++ifndef :: String -> HeaderLines -> HeaderLines+ifndef macro body =+    line ("#ifndef " ++ macro) +++    body +++    line ("#endif /* " ++ macro ++ " */")++define :: String -> Maybe [String] -> String -> HeaderLines+define macro params val =+    line ("#define " ++ macro ++ f params ++ " " ++ val)+  where+    f Nothing = ""+    f (Just xs) = "(" ++ intercalate "," xs ++ ")"++defineStr :: String -> String -> HeaderLines+defineStr macro str = define macro Nothing (show str)++ifndefDefine :: String -> Maybe [String] -> String -> HeaderLines+ifndefDefine macro params str =+    ifndef macro (define macro params str)++ifndefDefineStr :: String -> String -> HeaderLines+ifndefDefineStr macro str =+    ifndef macro (defineStr macro str)+ -- | The contents of the @cabal_macros.h@ for the given configured package. -- generate :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String@@ -53,7 +83,7 @@ -- generatePackageVersionMacros :: [PackageIdentifier] -> String generatePackageVersionMacros pkgids = concat-  [ "/* package " ++ display pkgid ++ " */\n"+  [ line ("/* package " ++ display pkgid ++ " */")   ++ generateMacros "" pkgname version   | pkgid@(PackageIdentifier name version) <- pkgids   , let pkgname = map fixchar (display name)@@ -64,7 +94,7 @@ -- generateToolVersionMacros :: [ConfiguredProgram] -> String generateToolVersionMacros progs = concat-  [ "/* tool " ++ progid ++ " */\n"+  [ line ("/* tool " ++ progid ++ " */")   ++ generateMacros "TOOL_" progname version   | prog <- progs   , isJust . programVersion $ prog@@ -79,29 +109,30 @@ generateMacros :: String -> String -> Version -> String generateMacros macro_prefix name version =   concat-  ["#define ", macro_prefix, "VERSION_",name," ",show (display version),"\n"-  ,"#define MIN_", macro_prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"-  ,"  (major1) <  ",major1," || \\\n"-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-  ,"\n\n"-  ]+  [ifndefDefineStr (macro_prefix ++ "VERSION_" ++ name) (display version)+  ,ifndefDefine ("MIN_" ++ macro_prefix ++ "VERSION_" ++ name)+                (Just ["major1","major2","minor"])+    $ concat [+       "(\\\n"+      ,"  (major1) <  ",major1," || \\\n"+      ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+      ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+    ]+  ,"\n"]   where-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)+    (major1:major2:minor:_) = map show (versionNumbers version ++ repeat 0)  -- | Generate the @CURRENT_COMPONENT_ID@ definition for the component ID --   of the current package. generateComponentIdMacro :: LocalBuildInfo -> ComponentLocalBuildInfo -> String-generateComponentIdMacro lbi clbi =+generateComponentIdMacro _lbi clbi =   concat $-      (case clbi of+      [case clbi of         LibComponentLocalBuildInfo{} ->-          ["#define CURRENT_PACKAGE_KEY \"" ++ componentCompatPackageKey clbi ++ "\"\n"]-        _ -> [])-      ++-      ["#define CURRENT_COMPONENT_ID \"" ++ display (componentComponentId clbi) ++ "\"\n"-      ,"#define LOCAL_COMPONENT_ID \"" ++ display (localComponentId lbi) ++ "\"\n"-      ,"\n"]+          ifndefDefineStr "CURRENT_PACKAGE_KEY" (componentCompatPackageKey clbi)+        _ -> ""+      ,ifndefDefineStr "CURRENT_COMPONENT_ID" (display (componentComponentId clbi))+      ]  fixchar :: Char -> Char fixchar '-' = '_'
cabal/Cabal/Distribution/Simple/Build/PathsModule.hs view
@@ -18,6 +18,9 @@     generate, pkgPathEnvVar   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.System import Distribution.Simple.Compiler import Distribution.Package@@ -28,10 +31,7 @@ import Distribution.Text import Distribution.Version -import System.FilePath-         ( pathSeparator )-import Data.Maybe-         ( fromJust, isNothing )+import System.FilePath ( pathSeparator )  -- ------------------------------------------------------------ -- * Building Paths_<pkg>.hs@@ -71,7 +71,7 @@         pragmas++         "module " ++ display paths_modulename ++ " (\n"++         "    version,\n"++-        "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"+++        "    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n"++         "    getDataFileName, getSysconfDir\n"++         "  ) where\n"++         "\n"++@@ -100,17 +100,18 @@         "catchIO = Exception.catch\n" ++         "\n"++         "version :: Version"++-        "\nversion = Version " ++ show branch ++ " " ++ show tags-          where Version branch tags = packageVersion pkg_descr+        "\nversion = Version " ++ show branch ++ " []"+          where branch = versionNumbers $ packageVersion pkg_descr         body         | reloc =           "\n\nbindirrel :: FilePath\n" ++           "bindirrel = " ++ show flat_bindirreloc ++           "\n"++-          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"+++          "\ngetBinDir, getLibDir, genDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++           "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++           "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"+++          "getDynLibDir = "++mkGetEnvOrReloc "libdir" flat_dynlibdirreloc++"\n"++           "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++           "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++           "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++@@ -124,16 +125,18 @@           "\n"++           filename_stuff         | absolute =-          "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"+++          "\nbindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n"++           "\nbindir     = " ++ show flat_bindir ++           "\nlibdir     = " ++ show flat_libdir +++          "\ndynlibdir  = " ++ show flat_dynlibdir ++           "\ndatadir    = " ++ show flat_datadir ++           "\nlibexecdir = " ++ show flat_libexecdir ++           "\nsysconfdir = " ++ show flat_sysconfdir ++           "\n"++-          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"+++          "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++           "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++           "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"+++          "getDynLibDir = "++mkGetEnvOr "dynlibdir" "return dynlibdir"++"\n"++           "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++           "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++           "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++@@ -145,12 +148,14 @@         | otherwise =           "\nprefix, bindirrel :: FilePath" ++           "\nprefix        = " ++ show flat_prefix ++-          "\nbindirrel     = " ++ show (fromJust flat_bindirrel) +++          "\nbindirrel     = " ++ show (fromMaybe (error "PathsModule.generate") flat_bindirrel) ++           "\n\n"++           "getBinDir :: IO FilePath\n"++           "getBinDir = getPrefixDirRel bindirrel\n\n"++           "getLibDir :: IO FilePath\n"++           "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"+++          "getDynLibDir :: IO FilePath\n"+++          "getDynLibDir = "++mkGetDir flat_dynlibdir flat_dynlibdirrel++"\n\n"++           "getDataDir :: IO FilePath\n"++           "getDataDir =  "++ mkGetEnvOr "datadir"                               (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++@@ -175,6 +180,7 @@           prefix     = flat_prefix,           bindir     = flat_bindir,           libdir     = flat_libdir,+          dynlibdir  = flat_dynlibdir,           datadir    = flat_datadir,           libexecdir = flat_libexecdir,           sysconfdir = flat_sysconfdir@@ -182,6 +188,7 @@         InstallDirs {           bindir     = flat_bindirrel,           libdir     = flat_libdirrel,+          dynlibdir  = flat_dynlibdirrel,           datadir    = flat_datadirrel,           libexecdir = flat_libexecdirrel,           sysconfdir = flat_sysconfdirrel@@ -189,6 +196,7 @@          flat_bindirreloc = shortRelativePath flat_prefix flat_bindir         flat_libdirreloc = shortRelativePath flat_prefix flat_libdir+        flat_dynlibdirreloc = shortRelativePath flat_prefix flat_dynlibdir         flat_datadirreloc = shortRelativePath flat_prefix flat_datadir         flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir         flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir@@ -221,7 +229,7 @@                            _         -> False         supportsRelocatableProgs _    = False -        paths_modulename = autogenModuleName pkg_descr+        paths_modulename = autogenPathsModuleName pkg_descr          get_prefix_stuff = get_prefix_win32 buildArch @@ -232,11 +240,14 @@         supports_language_pragma =           (compilerFlavor (compiler lbi) == GHC &&             (compilerVersion (compiler lbi)-              `withinRange` orLaterVersion (Version [6,6,1] []))) ||+              `withinRange` orLaterVersion (mkVersion [6,6,1]))) ||            compilerFlavor (compiler lbi) == GHCJS  -- | Generates the name of the environment variable controlling the path -- component of interest.+--+-- Note: The format of these strings is part of Cabal's public API;+-- changing this function constitutes a *backwards-compatibility* break. pkgPathEnvVar :: PackageDescription               -> String     -- ^ path component; one of \"bindir\", \"libdir\",                             -- \"datadir\", \"libexecdir\", or \"sysconfdir\"
cabal/Cabal/Distribution/Simple/BuildPaths.hs view
@@ -13,10 +13,13 @@  module Distribution.Simple.BuildPaths (     defaultDistPref, srcPref,-    hscolourPref, haddockPref,+    haddockDirName, hscolourPref, haddockPref,     autogenModulesDir,+    autogenPackageModulesDir,+    autogenComponentModulesDir,      autogenModuleName,+    autogenPathsModuleName,     cppHeaderName,     haddockName, @@ -27,9 +30,11 @@     exeExtension,     objExtension,     dllExtension,-+    staticLibExtension,   ) where +import Prelude ()+import Distribution.Compat.Prelude  import Distribution.Package import Distribution.ModuleName as ModuleName@@ -48,25 +53,49 @@ srcPref :: FilePath -> FilePath srcPref distPref = distPref </> "src" -hscolourPref :: FilePath -> PackageDescription -> FilePath+hscolourPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath hscolourPref = haddockPref -haddockPref :: FilePath -> PackageDescription -> FilePath-haddockPref distPref pkg_descr-    = distPref </> "doc" </> "html" </> display (packageName pkg_descr)+-- | This is the name of the directory in which the generated haddocks+-- should be stored. It does not include the @<dist>/doc/html@ prefix.+haddockDirName :: HaddockTarget -> PackageDescription -> FilePath+haddockDirName ForDevelopment = display . packageName+haddockDirName ForHackage = (++ "-docs") . display . packageId --- |The directory in which we put auto-generated modules-autogenModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String-autogenModulesDir lbi clbi = componentBuildDir lbi clbi </> "autogen"+-- | The directory to which generated haddock documentation should be written.+haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath+haddockPref haddockTarget distPref pkg_descr+    = distPref </> "doc" </> "html" </> haddockDirName haddockTarget pkg_descr++-- | The directory in which we put auto-generated modules for EVERY+-- component in the package.  See deprecation notice.+{-# DEPRECATED autogenModulesDir "If you can, use 'autogenComponentModulesDir' instead, but if you really wanted package-global generated modules, use 'autogenPackageModulesDir'.  In Cabal 2.0, we avoid using autogenerated files which apply to all components, because the information you often want in these files, e.g., dependency information, is best specified per component, so that reconfiguring a different component (e.g., enabling tests) doesn't force the entire to be rebuilt.  'autogenPackageModulesDir' still provides a place to put files you want to apply to the entire package, but most users of 'autogenModulesDir' should seriously consider 'autogenComponentModulesDir' if you really wanted the module to apply to one component." #-}+autogenModulesDir :: LocalBuildInfo -> String+autogenModulesDir = autogenPackageModulesDir++-- | The directory in which we put auto-generated modules for EVERY+-- component in the package.+autogenPackageModulesDir :: LocalBuildInfo -> String+autogenPackageModulesDir lbi = buildDir lbi </> "global-autogen"++-- | The directory in which we put auto-generated modules for a+-- particular component.+autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String+autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi </> "autogen" -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted.  cppHeaderName :: String cppHeaderName = "cabal_macros.h" +{-# DEPRECATED autogenModuleName "Use autogenPathsModuleName instead" #-} -- |The name of the auto-generated module associated with a package autogenModuleName :: PackageDescription -> ModuleName-autogenModuleName pkg_descr =+autogenModuleName = autogenPathsModuleName++-- | The name of the auto-generated Paths_* module associated with a package+autogenPathsModuleName :: PackageDescription -> ModuleName+autogenPathsModuleName pkg_descr =   ModuleName.fromString $     "Paths_" ++ map fixchar (display (packageName pkg_descr))   where fixchar '-' = '_'@@ -78,9 +107,11 @@ -- --------------------------------------------------------------------------- -- Library file names +-- TODO: Should this use staticLibExtension? mkLibName :: UnitId -> String mkLibName lib = "lib" ++ getHSLibraryName lib <.> "a" +-- TODO: Should this use staticLibExtension? mkProfLibName :: UnitId -> String mkProfLibName lib =  "lib" ++ getHSLibraryName lib ++ "_p" <.> "a" @@ -114,3 +145,12 @@                    Windows -> "dll"                    OSX     -> "dylib"                    _       -> "so"++-- | Extension for static libraries+--+-- TODO: Here, as well as in dllExtension, it's really the target OS that we're+-- interested in, not the build OS.+staticLibExtension :: String+staticLibExtension = case buildOS of+                       Windows -> "lib"+                       _       -> "a"
cabal/Cabal/Distribution/Simple/BuildTarget.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.BuildTargets@@ -10,10 +13,12 @@ -- Handling for user-specified build targets ----------------------------------------------------------------------------- module Distribution.Simple.BuildTarget (+    -- * Main interface+    readTargetInfos,+    readBuildTargets, -- in case you don't have LocalBuildInfo      -- * Build targets     BuildTarget(..),-    readBuildTargets,     showBuildTarget,     QualLevel(..),     buildTargetComponentName,@@ -29,11 +34,17 @@     resolveBuildTargets,     BuildTargetProblem(..),     reportBuildTargetProblems,--    -- * Checking build targets-    checkBuildTargets   ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.TargetInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.ForeignLib++import Distribution.Package import Distribution.PackageDescription import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo@@ -41,29 +52,25 @@ import Distribution.Simple.Utils import Distribution.Verbosity -import Distribution.Compat.Binary (Binary) import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP-         ( (+++), (<++) )+import Distribution.Compat.ReadP ( (+++), (<++) ) -import Data.List-         ( nub, stripPrefix, sortBy, groupBy, partition )-import Data.Maybe-         ( listToMaybe, catMaybes )-import Data.Either-         ( partitionEithers )-import GHC.Generics (Generic)-import qualified Data.Map as Map-import Control.Monad-import Control.Applicative as AP (Alternative(..), Applicative(..))-import Data.Char-         ( isSpace, isAlphaNum )+import Control.Monad ( msum )+import Data.List ( stripPrefix, groupBy, partition )+import Data.Either ( partitionEithers ) import System.FilePath as FilePath          ( dropExtension, normalise, splitDirectories, joinPath, splitPath          , hasTrailingPathSeparator )-import System.Directory-         ( doesFileExist, doesDirectoryExist )+import System.Directory ( doesFileExist, doesDirectoryExist )+import qualified Data.Map as Map +-- | Take a list of 'String' build targets, and parse and validate them+-- into actual 'TargetInfo's to be built/registered/whatever.+readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]+readTargetInfos verbosity pkg_descr lbi args = do+    build_targets <- readBuildTargets pkg_descr args+    checkBuildTargets verbosity pkg_descr lbi build_targets+ -- ------------------------------------------------------------ -- * User build targets -- ------------------------------------------------------------@@ -91,7 +98,7 @@      --    | UserBuildTargetDouble String String -     -- A fully qualified target, either a module or file qualified by a+     -- | A fully qualified target, either a module or file qualified by a      -- component name with the component namespace kind.      --      -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs@@ -138,14 +145,14 @@     let (uproblems, utargets) = readUserBuildTargets targetStrs     reportUserBuildTargetProblems uproblems -    utargets' <- mapM checkTargetExistsAsFile utargets+    utargets' <- traverse checkTargetExistsAsFile utargets      let (bproblems, btargets) = resolveBuildTargets pkg utargets'     reportBuildTargetProblems bproblems      return btargets -checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)+checkTargetExistsAsFile :: UserBuildTarget -> NoCallStackIO (UserBuildTarget, Bool) checkTargetExistsAsFile t = do     fexists <- existsAsFile (fileComponentOfTarget t)     return (t, fexists)@@ -231,11 +238,22 @@     getComponents (UserBuildTargetDouble s1 s2)    = [s1,s2]     getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] -showBuildTarget :: QualLevel -> BuildTarget -> String-showBuildTarget ql bt =-    showUserBuildTarget (renderBuildTarget ql bt)+-- | Unless you use 'QL1', this function is PARTIAL;+-- use 'showBuildTarget' instead.+showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String+showBuildTarget' ql pkgid bt =+    showUserBuildTarget (renderBuildTarget ql bt pkgid) +-- | Unambiguously render a 'BuildTarget', so that it can+-- be parsed in all situations.+showBuildTarget :: PackageId -> BuildTarget -> String+showBuildTarget pkgid t =+    showBuildTarget' (qlBuildTarget t) pkgid t+  where+    qlBuildTarget BuildTargetComponent{} = QL2+    qlBuildTarget _                      = QL3 + -- ------------------------------------------------------------ -- * Resolving user targets to build targets -- ------------------------------------------------------------@@ -270,6 +288,7 @@       Unambiguous target  -> Right target       Ambiguous   targets -> Left (BuildTargetAmbiguous userTarget targets')                                where targets' = disambiguateBuildTargets+                                                    (packageId pkg)                                                     userTarget                                                     targets       None        errs    -> Left (classifyMatchErrors errs)@@ -294,9 +313,9 @@   deriving Show  -disambiguateBuildTargets :: UserBuildTarget -> [BuildTarget]+disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]                          -> [(UserBuildTarget, BuildTarget)]-disambiguateBuildTargets original =+disambiguateBuildTargets pkgid original =     disambiguate (userTargetQualLevel original)   where     disambiguate ql ts@@ -315,13 +334,13 @@             . partition (\g -> length g > 1)             . groupBy (equating fst)             . sortBy (comparing fst)-            . map (\t -> (renderBuildTarget ql t, t))+            . map (\t -> (renderBuildTarget ql t pkgid, t))  data QualLevel = QL1 | QL2 | QL3   deriving (Enum, Show) -renderBuildTarget :: QualLevel -> BuildTarget -> UserBuildTarget-renderBuildTarget ql target =+renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget+renderBuildTarget ql target pkgid =     case ql of       QL1 -> UserBuildTargetSingle s1        where  s1          = single target       QL2 -> UserBuildTargetDouble s1 s2     where (s1, s2)     = double target@@ -340,7 +359,7 @@     triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, display m)     triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f) -    dispCName = componentStringName+    dispCName = componentStringName pkgid     dispKind  = showComponentKindShort . componentKind  reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()@@ -443,7 +462,7 @@ pkgComponentInfo pkg =     [ ComponentInfo {         cinfoName    = componentName c,-        cinfoStrName = componentStringName (componentName c),+        cinfoStrName = componentStringName pkg (componentName c),         cinfoSrcDirs = hsSourceDirs bi,         cinfoModules = componentModules c,         cinfoHsFiles = componentHsFiles c,@@ -453,14 +472,24 @@     | c <- pkgComponents pkg     , let bi = componentBuildInfo c ] -componentStringName :: ComponentName -> ComponentStringName-componentStringName (CLibName   name) = name-componentStringName (CExeName   name) = name-componentStringName (CTestName  name) = name-componentStringName (CBenchName name) = name+componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName+componentStringName pkg CLibName          = display (packageName pkg)+componentStringName _   (CSubLibName name) = unUnqualComponentName name+componentStringName _   (CFLibName  name) = unUnqualComponentName name+componentStringName _   (CExeName   name) = unUnqualComponentName name+componentStringName _   (CTestName  name) = unUnqualComponentName name+componentStringName _   (CBenchName name) = unUnqualComponentName name  componentModules :: Component -> [ModuleName]-componentModules (CLib   lib)   = libModules lib+-- TODO: Use of 'explicitLibModules' here is a bit wrong:+-- a user could very well ask to build a specific signature+-- that was inherited from other packages.  To fix this+-- we have to plumb 'LocalBuildInfo' through this code.+-- Fortunately, this is only used by 'pkgComponentInfo' +-- Please don't export this function unless you plan on fixing+-- this.+componentModules (CLib   lib)   = explicitLibModules lib+componentModules (CFLib  flib)  = foreignLibModules flib componentModules (CExe   exe)   = exeModules exe componentModules (CTest  test)  = testModules test componentModules (CBench bench) = benchmarkModules bench@@ -493,11 +522,13 @@ -- Matching component kinds -- -data ComponentKind = LibKind | ExeKind | TestKind | BenchKind+data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind   deriving (Eq, Ord, Show)  componentKind :: ComponentName -> ComponentKind-componentKind (CLibName   _) = LibKind+componentKind CLibName = LibKind+componentKind (CSubLibName _) = LibKind+componentKind (CFLibName  _) = FLibKind componentKind (CExeName   _) = ExeKind componentKind (CTestName  _) = TestKind componentKind (CBenchName _) = BenchKind@@ -507,23 +538,25 @@  matchComponentKind :: String -> Match ComponentKind matchComponentKind s-  | s `elem` ["lib", "library"]            = increaseConfidence >> return LibKind-  | s `elem` ["exe", "executable"]         = increaseConfidence >> return ExeKind-  | s `elem` ["tst", "test", "test-suite"] = increaseConfidence-                                             >> return TestKind-  | s `elem` ["bench", "benchmark"]        = increaseConfidence-                                             >> return BenchKind-  | otherwise                              = matchErrorExpected-                                             "component kind" s+  | s `elem` ["lib", "library"]                 = return' LibKind+  | s `elem` ["foreign-lib", "foreign-library"] = return' FLibKind+  | s `elem` ["exe", "executable"]              = return' ExeKind+  | s `elem` ["tst", "test", "test-suite"]      = return' TestKind+  | s `elem` ["bench", "benchmark"]             = return' BenchKind+  | otherwise = matchErrorExpected "component kind" s+  where+    return' ck = increaseConfidence >> return ck  showComponentKind :: ComponentKind -> String showComponentKind LibKind   = "library"+showComponentKind FLibKind  = "foreign-library" showComponentKind ExeKind   = "executable" showComponentKind TestKind  = "test-suite" showComponentKind BenchKind = "benchmark"  showComponentKindShort :: ComponentKind -> String showComponentKindShort LibKind   = "lib"+showComponentKindShort FLibKind  = "flib" showComponentKindShort ExeKind   = "exe" showComponentKindShort TestKind  = "test" showComponentKindShort BenchKind = "bench"@@ -805,7 +838,7 @@   (<*>) = ap  instance Monad Match where-  return = AP.pure+  return = pure    NoMatch      d ms >>= _ = NoMatch d ms   ExactMatch   d xs >>= f = addDepth d@@ -947,32 +980,40 @@ -- -- Also swizzle into a more convenient form. ---checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]-                  -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]-checkBuildTargets _ pkg []      =-    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]+checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]+                  -> IO [TargetInfo]+checkBuildTargets _ pkg_descr lbi []      =+    return (allTargetsInBuildOrder' pkg_descr lbi) -checkBuildTargets verbosity pkg targets = do+checkBuildTargets verbosity pkg_descr lbi targets = do      let (enabled, disabled) =           partitionEithers-            [ case componentDisabledReason (getComponent pkg cname) of+            [ case componentDisabledReason (componentEnabledSpec lbi) comp of                 Nothing     -> Left  target'                 Just reason -> Right (cname, reason)             | target <- targets-            , let target'@(cname,_) = swizzleTarget target ]+            , let target'@(cname,_) = swizzleTarget target+            , let comp = getComponent pkg_descr cname ]      case disabled of       []                 -> return ()       ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason -    forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->+    for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->       warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "                     ++ showComponentName c ++ " will be processed. (Support for "                     ++ "module and file targets has not been implemented yet.)" -    return enabled+    -- Pick out the actual CLBIs for each of these cnames+    enabled' <- for enabled $ \(cname, _) -> do+        case componentNameTargets' pkg_descr lbi cname of+            [] -> error "checkBuildTargets: nothing enabled"+            [target] -> return target+            _targets -> error "checkBuildTargets: multiple copies enabled" +    return enabled'+   where     swizzleTarget (BuildTargetComponent c)   = (c, Nothing)     swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))@@ -987,3 +1028,7 @@     formatReason cn DisabledAllBenchmarks =         "Cannot process the " ++ cn ++ " because benchmarks are not "      ++ "enabled. Re-run configure with the flag --enable-benchmarks"+    formatReason cn (DisabledAllButOne cn') =+        "Cannot process the " ++ cn ++ " because this package was "+     ++ "configured only to build " ++ cn' ++ ". Re-run configure "+     ++ "with the argument " ++ cn
cabal/Cabal/Distribution/Simple/CCompiler.hs view
@@ -46,7 +46,8 @@    filenameCDialect   ) where -import Distribution.Compat.Semigroup as Semi+import Prelude ()+import Distribution.Compat.Prelude  import System.FilePath      ( takeExtension )@@ -63,7 +64,7 @@  instance Monoid CDialect where   mempty = C-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup CDialect where   C                  <> anything           = anything
cabal/Cabal/Distribution/Simple/Command.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Command@@ -65,17 +68,15 @@    ) where +import Prelude ()+import Distribution.Compat.Prelude hiding (get)+ import qualified Distribution.GetOpt as GetOpt import Distribution.Text import Distribution.ParseUtils import Distribution.ReadE import Distribution.Simple.Utils -import Control.Monad-import Data.Char (isAlpha, toLower)-import Data.List (sortBy)-import Data.Maybe-import Data.Monoid as Mon import Text.PrettyPrint ( punctuate, cat, comma, text ) import Text.PrettyPrint as PP ( empty ) @@ -174,7 +175,7 @@     reqArg ad (succeedReadE mkflag) showflag  -- | (String -> a) variant of "optArg"-optArg' :: Mon.Monoid b => ArgPlaceHolder -> (Maybe String -> b)+optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)            -> (b -> [Maybe String])            -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag =
cabal/Cabal/Distribution/Simple/Compiler.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}  ----------------------------------------------------------------------------- -- |@@ -26,6 +27,7 @@         Compiler(..),         showCompilerId, showCompilerIdWithAbi,         compilerFlavor, compilerVersion,+        compilerCompatFlavor,         compilerCompatVersion,         compilerInfo, @@ -56,6 +58,10 @@         unifiedIPIDRequired,         packageKeySupported,         unitIdSupported,+        coverageSupported,+        profilingSupported,+        backpackSupported,+        libraryDynDirSupported,          -- * Support for profiling detail levels         ProfDetailLevel(..),@@ -64,35 +70,35 @@         showProfDetailLevel,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Compiler import Distribution.Version import Distribution.Text import Language.Haskell.Extension import Distribution.Simple.Utils-import Distribution.Compat.Binary -import Control.Monad (liftM)-import Data.List (nub)-import qualified Data.Map as M (Map, lookup)-import Data.Maybe (catMaybes, isNothing, listToMaybe)-import GHC.Generics (Generic)+import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath)  data Compiler = Compiler {         compilerId              :: CompilerId,         -- ^ Compiler flavour and version.         compilerAbiTag          :: AbiTag,-        -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os.+        -- ^ Tag for distinguishing incompatible ABI's on the same+        -- architecture/os.         compilerCompat          :: [CompilerId],-        -- ^ Other implementations that this compiler claims to be compatible with.+        -- ^ Other implementations that this compiler claims to be+        -- compatible with.         compilerLanguages       :: [(Language, Flag)],         -- ^ Supported language standards.         compilerExtensions      :: [(Extension, Flag)],         -- ^ Supported extensions.-        compilerProperties      :: M.Map String String+        compilerProperties      :: Map String String         -- ^ A key-value map for properties not covered by the above fields.     }-    deriving (Eq, Generic, Show, Read)+    deriving (Eq, Generic, Typeable, Show, Read)  instance Binary Compiler @@ -112,6 +118,30 @@ compilerVersion :: Compiler -> Version compilerVersion = (\(CompilerId _ v) -> v) . compilerId ++-- | Is this compiler compatible with the compiler flavour we're interested in?+--+-- For example this checks if the compiler is actually GHC or is another+-- compiler that claims to be compatible with some version of GHC, e.g. GHCJS.+--+-- > if compilerCompatFlavor GHC compiler then ... else ...+--+compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool+compilerCompatFlavor flavor comp =+    flavor == compilerFlavor comp+ || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ]+++-- | Is this compiler compatible with the compiler flavour we're interested in,+-- and if so what version does it claim to be compatible with.+--+-- For example this checks if the compiler is actually GHC-7.x or is another+-- compiler that claims to be compatible with some GHC-7.x version.+--+-- > case compilerCompatVersion GHC compiler of+-- >   Just (Version (7:_)) -> ...+-- >   _                    -> ...+-- compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version compilerCompatVersion flavor comp   | compilerFlavor comp == flavor = Just (compilerVersion comp)@@ -171,10 +201,10 @@ -- | Make package paths absolute  -absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack-absolutePackageDBPaths = mapM absolutePackageDBPath+absolutePackageDBPaths :: PackageDBStack -> NoCallStackIO PackageDBStack+absolutePackageDBPaths = traverse absolutePackageDBPath -absolutePackageDBPath :: PackageDB -> IO PackageDB+absolutePackageDBPath :: PackageDB -> NoCallStackIO PackageDB absolutePackageDBPath GlobalPackageDB        = return GlobalPackageDB absolutePackageDBPath UserPackageDB          = return UserPackageDB absolutePackageDBPath (SpecificPackageDB db) =@@ -277,7 +307,8 @@  -- | Does this compiler support thinning/renaming on package flags? renamingPackageFlagsSupported :: Compiler -> Bool-renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags"+renamingPackageFlagsSupported = ghcSupported+  "Support thinning and renaming package flags"  -- | Does this compiler have unified IPIDs (so no package keys) unifiedIPIDRequired :: Compiler -> Bool@@ -291,6 +322,40 @@ unitIdSupported :: Compiler -> Bool unitIdSupported = ghcSupported "Uses unit IDs" +-- | Does this compiler support Backpack?+backpackSupported :: Compiler -> Bool+backpackSupported = ghcSupported "Support Backpack"++-- | Does this compiler support a package database entry with:+-- "dynamic-library-dirs"?+libraryDynDirSupported :: Compiler -> Bool+libraryDynDirSupported comp = case compilerFlavor comp of+  GHC ->+      -- Not just v >= mkVersion [8,0,1,20161022], as there+      -- are many GHC 8.1 nightlies which don't support this.+    ((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) ||+      v >= mkVersion [8,1,20161021])+  _   -> False+ where+  v = compilerVersion comp++-- | Does this compiler support Haskell program coverage?+coverageSupported :: Compiler -> Bool+coverageSupported comp =+  case compilerFlavor comp of+    GHC   -> True+    GHCJS -> True+    _     -> False++-- | Does this compiler support profiling?+profilingSupported :: Compiler -> Bool+profilingSupported comp =+  case compilerFlavor comp of+    GHC   -> True+    GHCJS -> True+    LHC   -> True+    _     -> False+ -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp =@@ -299,7 +364,7 @@     GHCJS -> checkProp     _     -> False   where checkProp =-          case M.lookup key (compilerProperties comp) of+          case Map.lookup key (compilerProperties comp) of             Just "YES" -> True             _          -> False
cabal/Cabal/Distribution/Simple/Configure.hs view
@@ -1,2137 +1,1914 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE NoMonoLocalBinds #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Configure--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This deals with the /configure/ phase. It provides the 'configure' action--- which is given the package description and configure flags. It then tries--- to: configure the compiler; resolves any conditionals in the package--- description; resolve the package dependencies; check if all the extensions--- used by this package are supported by the compiler; check that all the build--- tools are available (including version checks if appropriate); checks for--- any required @pkg-config@ packages (updating the 'BuildInfo' with the--- results)------ Then based on all this it saves the info in the 'LocalBuildInfo' and writes--- it out to the @dist\/setup-config@ file. It also displays various details to--- the user, the amount of information displayed depending on the verbosity--- level.--module Distribution.Simple.Configure (configure,-                                      writePersistBuildConfig,-                                      getConfigStateFile,-                                      getPersistBuildConfig,-                                      checkPersistBuildConfigOutdated,-                                      tryGetPersistBuildConfig,-                                      maybeGetPersistBuildConfig,-                                      findDistPref, findDistPrefOrDefault,-                                      computeComponentId,-                                      computeCompatPackageKey,-                                      computeCompatPackageName,-                                      localBuildInfoFile,-                                      getInstalledPackages,-                                      getInstalledPackagesMonitorFiles,-                                      getPackageDBContents,-                                      configCompiler, configCompilerAux,-                                      configCompilerEx, configCompilerAuxEx,-                                      ccLdOptionsBuildInfo,-                                      checkForeignDeps,-                                      interpretPackageDbFlags,-                                      ConfigStateFileError(..),-                                      tryGetConfigStateFile,-                                      platformDefines,-                                      relaxPackageDeps,-                                     )-    where--import Distribution.Compiler-import Distribution.Utils.NubList-import Distribution.Simple.Compiler hiding (Flag)-import Distribution.Simple.PreProcess-import Distribution.Package-import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.InstalledPackageInfo (InstalledPackageInfo-                                         ,emptyInstalledPackageInfo)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.PackageDescription as PD hiding (Flag)-import Distribution.ModuleName-import Distribution.PackageDescription.Configuration-import Distribution.PackageDescription.Check hiding (doesFileExist)-import Distribution.Simple.Program-import Distribution.Simple.Setup as Setup-import qualified Distribution.Simple.InstallDirs as InstallDirs-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Utils-import Distribution.System-import Distribution.Version-import Distribution.Verbosity--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.JHC   as JHC-import qualified Distribution.Simple.LHC   as LHC-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite---- Prefer the more generic Data.Traversable.mapM to Prelude.mapM-import Prelude hiding ( mapM )-import Control.Exception-    ( Exception, evaluate, throw, throwIO, try )-import Control.Exception ( ErrorCall )-import Control.Monad-    ( liftM, when, unless, foldM, filterM, mplus )-import Distribution.Compat.Binary ( decodeOrFailIO, encode )-import GHC.Fingerprint ( Fingerprint(..), fingerprintString )-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.List-    ( (\\), nub, partition, isPrefixOf, inits, stripPrefix )-import Data.Maybe-    ( isNothing, catMaybes, fromMaybe, mapMaybe, isJust )-import Data.Either-    ( partitionEithers )-import qualified Data.Set as Set-import Data.Monoid as Mon ( Monoid(..) )-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Traversable-    ( mapM )-import Data.Typeable-import Data.Char ( chr, isAlphaNum )-import Numeric ( showIntAtBase )-import System.Directory-    ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )-import System.FilePath-    ( (</>), isAbsolute )-import qualified System.Info-    ( compilerName, compilerVersion )-import System.IO-    ( hPutStrLn, hClose )-import Distribution.Text-    ( Text(disp), defaultStyle, display, simpleParse )-import Text.PrettyPrint-    ( Doc, (<>), (<+>), ($+$), char, comma, empty, hsep, nest-    , punctuate, quotes, render, renderStyle, sep, text )-import Distribution.Compat.Environment ( lookupEnv )-import Distribution.Compat.Exception ( catchExit, catchIO )--import Data.Graph (graphFromEdges, topSort)---- | The errors that can be thrown when reading the @setup-config@ file.-data ConfigStateFileError-    = ConfigStateFileNoHeader -- ^ No header found.-    | ConfigStateFileBadHeader -- ^ Incorrect header.-    | ConfigStateFileNoParse -- ^ Cannot parse file contents.-    | ConfigStateFileMissing -- ^ No file!-    | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier-      (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version.-  deriving (Typeable)---- | Format a 'ConfigStateFileError' as a user-facing error message.-dispConfigStateFileError :: ConfigStateFileError -> Doc-dispConfigStateFileError ConfigStateFileNoHeader =-    text "Saved package config file header is missing."-    <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileBadHeader =-    text "Saved package config file header is corrupt."-    <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileNoParse =-    text "Saved package config file is corrupt."-    <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileMissing =-    text "Run the 'configure' command first."-dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) =-    text "Saved package config file is outdated:"-    $+$ badCabal $+$ badCompiler-    $+$ text "Re-run the 'configure' command."-    where-      badCabal =-          text "• the Cabal version changed from"-          <+> disp oldCabal <+> "to" <+> disp currentCabalId-      badCompiler-        | oldCompiler == currentCompilerId = empty-        | otherwise =-            text "• the compiler changed from"-            <+> disp oldCompiler <+> "to" <+> disp currentCompilerId--instance Show ConfigStateFileError where-    show = renderStyle defaultStyle . dispConfigStateFileError--instance Exception ConfigStateFileError---- | Read the 'localBuildInfoFile'.  Throw an exception if the file is--- missing, if the file cannot be read, or if the file was created by an older--- version of Cabal.-getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.-                   -> IO LocalBuildInfo-getConfigStateFile filename = do-    exists <- doesFileExist filename-    unless exists $ throwIO ConfigStateFileMissing-    -- Read the config file into a strict ByteString to avoid problems with-    -- lazy I/O, then convert to lazy because the binary package needs that.-    contents <- BS.readFile filename-    let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])--    headerParseResult <- try $ evaluate $ parseHeader header-    let (cabalId, compId) =-            case headerParseResult of-              Left (_ :: ErrorCall) -> throw ConfigStateFileBadHeader-              Right x -> x--    let getStoredValue = do-          result <- decodeOrFailIO (BLC8.tail body)-          case result of-            Left _ -> throw ConfigStateFileNoParse-            Right x -> return x-        deferErrorIfBadVersion act-          | cabalId /= currentCabalId = do-              eResult <- try act-              throw $ ConfigStateFileBadVersion cabalId compId eResult-          | otherwise = act-    deferErrorIfBadVersion getStoredValue---- | Read the 'localBuildInfoFile', returning either an error or the local build--- info.-tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.-                      -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetConfigStateFile = try . getConfigStateFile---- | Try to read the 'localBuildInfoFile'.-tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                         -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetPersistBuildConfig = try . getPersistBuildConfig---- | Read the 'localBuildInfoFile'. Throw an exception if the file is--- missing, if the file cannot be read, or if the file was created by an older--- version of Cabal.-getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                      -> IO LocalBuildInfo-getPersistBuildConfig = getConfigStateFile . localBuildInfoFile---- | Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                           -> IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig =-    liftM (either (const Nothing) Just) . tryGetPersistBuildConfig---- | After running configure, output the 'LocalBuildInfo' to the--- 'localBuildInfoFile'.-writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                        -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.-                        -> IO ()-writePersistBuildConfig distPref lbi = do-    createDirectoryIfMissing False distPref-    writeFileAtomic (localBuildInfoFile distPref) $-      BLC8.unlines [showHeader pkgId, encode lbi]-  where-    pkgId = packageId $ localPkgDescr lbi---- | Identifier of the current Cabal package.-currentCabalId :: PackageIdentifier-currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion---- | Identifier of the current compiler package.-currentCompilerId :: PackageIdentifier-currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)-                                      System.Info.compilerVersion---- | Parse the @setup-config@ file header, returning the package identifiers--- for Cabal and the compiler.-parseHeader :: ByteString -- ^ The file contents.-            -> (PackageIdentifier, PackageIdentifier)-parseHeader header = case BLC8.words header of-  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId,-   "using", compId] ->-      fromMaybe (throw ConfigStateFileBadHeader) $ do-          _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier-          cabalId' <- simpleParse (BLC8.unpack cabalId)-          compId' <- simpleParse (BLC8.unpack compId)-          return (cabalId', compId')-  _ -> throw ConfigStateFileNoHeader---- | Generate the @setup-config@ file header.-showHeader :: PackageIdentifier -- ^ The processed package.-            -> ByteString-showHeader pkgId = BLC8.unwords-    [ "Saved", "package", "config", "for"-    , BLC8.pack $ display pkgId-    , "written", "by"-    , BLC8.pack $ display currentCabalId-    , "using"-    , BLC8.pack $ display currentCompilerId-    ]---- | Check that localBuildInfoFile is up-to-date with respect to the--- .cabal file.-checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool-checkPersistBuildConfigOutdated distPref pkg_descr_file = do-  pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)---- | Get the path of @dist\/setup-config@.-localBuildInfoFile :: FilePath -- ^ The @dist@ directory path.-                    -> FilePath-localBuildInfoFile distPref = distPref </> "setup-config"---- -------------------------------------------------------------------------------- * Configuration--- --------------------------------------------------------------------------------- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken--- from (in order of highest to lowest preference) the override prefix, the--- \"CABAL_BUILDDIR\" environment variable, or the default prefix.-findDistPref :: FilePath  -- ^ default \"dist\" prefix-             -> Setup.Flag FilePath  -- ^ override \"dist\" prefix-             -> IO FilePath-findDistPref defDistPref overrideDistPref = do-    envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")-    return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)-  where-    parseEnvDistPref env =-      case env of-        Just distPref | not (null distPref) -> toFlag distPref-        _ -> NoFlag---- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken--- from (in order of highest to lowest preference) the override prefix, the--- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call--- this function to resolve a @*DistPref@ flag whenever it is not known to be--- set. (The @*DistPref@ flags are always set to a definite value before--- invoking 'UserHooks'.)-findDistPrefOrDefault :: Setup.Flag FilePath  -- ^ override \"dist\" prefix-                      -> IO FilePath-findDistPrefOrDefault = findDistPref defaultDistPref---- |Perform the \"@.\/setup configure@\" action.--- Returns the @.setup-config@ file.-configure :: (GenericPackageDescription, HookedBuildInfo)-          -> ConfigFlags -> IO LocalBuildInfo-configure (pkg_descr0', pbi) cfg = do-    let pkg_descr0 =-          -- Ignore '--allow-newer' when we're given '--exact-configuration'.-          if fromFlagOrDefault False (configExactConfiguration cfg)-          then pkg_descr0'-          else relaxPackageDeps-               (fromMaybe AllowNewerNone $ configAllowNewer cfg)-               pkg_descr0'--    setupMessage verbosity "Configuring" (packageId pkg_descr0)--    checkDeprecatedFlags verbosity cfg-    checkExactConfiguration pkg_descr0 cfg--    -- Where to build the package-    let buildDir :: FilePath -- e.g. dist/build-        -- fromFlag OK due to Distribution.Simple calling-        -- findDistPrefOrDefault to fill it in-        buildDir = fromFlag (configDistPref cfg) </> "build"-    createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir--    -- What package database(s) to use-    let packageDbs :: PackageDBStack-        packageDbs-         = interpretPackageDbFlags-            (fromFlag (configUserInstall cfg))-            (configPackageDBs cfg)--    -- comp:            the compiler we're building with-    -- compPlatform:    the platform we're building for-    -- programsConfig:  location and args of all programs we're-    --                  building with-    (comp           :: Compiler,-     compPlatform   :: Platform,-     programsConfig :: ProgramConfiguration)-        <- configCompilerEx-            (flagToMaybe (configHcFlavor cfg))-            (flagToMaybe (configHcPath cfg))-            (flagToMaybe (configHcPkg cfg))-            (mkProgramsConfig cfg (configPrograms cfg))-            (lessVerbose verbosity)--    -- The InstalledPackageIndex of all installed packages-    installedPackageSet :: InstalledPackageIndex-        <- getInstalledPackages (lessVerbose verbosity) comp-                                  packageDbs programsConfig--    -- An approximate InstalledPackageIndex of all (possible) internal libraries.-    -- This database is used to bootstrap the process before we know precisely-    -- what these libraries are supposed to be.-    let internalPackageSet :: InstalledPackageIndex-        internalPackageSet = getInternalPackages pkg_descr0--    -- allConstraints:  The set of all 'Dependency's we have.  Used ONLY-    --                  to 'configureFinalizedPackage'.-    -- requiredDepsMap: A map from 'PackageName' to the specifically-    --                  required 'InstalledPackageInfo', due to --dependency-    ---    -- NB: These constraints are to be applied to ALL components of-    -- a package.  Thus, it's not an error if allConstraints contains-    -- more constraints than is necessary for a component (another-    -- component might need it.)-    ---    -- NB: The fact that we bundle all the constraints together means-    -- that is not possible to configure a test-suite to use one-    -- version of a dependency, and the executable to use another.-    (allConstraints  :: [Dependency],-     requiredDepsMap :: Map PackageName InstalledPackageInfo)-        <- either die return $-              combinedConstraints (configConstraints cfg)-                                  (configDependencies cfg)-                                  installedPackageSet--    -- pkg_descr:   The resolved package description, that does not contain any-    --              conditionals, because we have have an assignment for-    --              every flag, either picking them ourselves using a-    --              simple naive algorithm, or having them be passed to-    --              us by 'configConfigurationsFlags')-    -- flags:       The 'FlagAssignment' that the conditionals were-    --              resolved with.-    ---    -- NB: Why doesn't finalizing a package also tell us what the-    -- dependencies are (e.g. when we run the naive algorithm,-    -- we are checking if dependencies are satisfiable)?  The-    -- primary reason is that we may NOT have done any solving:-    -- if the flags are all chosen for us, this step is a simple-    -- matter of flattening according to that assignment.  It's-    -- cleaner to then configure the dependencies afterwards.-    (pkg_descr :: PackageDescription,-     flags     :: FlagAssignment)-        <- configureFinalizedPackage verbosity cfg-                allConstraints-                (dependencySatisfiable-                    (fromFlagOrDefault False (configExactConfiguration cfg))-                    installedPackageSet-                    internalPackageSet-                    requiredDepsMap)-                comp-                compPlatform-                pkg_descr0--    checkCompilerProblems comp pkg_descr-    checkPackageProblems verbosity pkg_descr0-        (updatePackageDescription pbi pkg_descr)--    -- The list of 'InstalledPackageInfo' recording the selected-    -- dependencies...-    -- internalPkgDeps: ...on internal packages (these are fake!)-    -- externalPkgDeps: ...on external packages-    ---    -- Invariant: For any package name, there is at most one package-    -- in externalPackageDeps which has that name.-    ---    -- NB: The dependency selection is global over ALL components-    -- in the package (similar to how allConstraints and-    -- requiredDepsMap are global over all components).  In particular,-    -- if *any* component (post-flag resolution) has an unsatisfiable-    -- dependency, we will fail.  This can sometimes be undesirable-    -- for users, see #1786 (benchmark conflicts with executable),-    (internalPkgDeps :: [PackageId],-     externalPkgDeps :: [InstalledPackageInfo])-        <- configureDependencies-                verbosity-                internalPackageSet-                installedPackageSet-                requiredDepsMap-                pkg_descr--    -- The database of transitively reachable installed packages that the-    -- external components the package (as a whole) depends on.  This will be-    -- used in several ways:-    ---    --      * We'll use it to do a consistency check so we're not depending-    --        on multiple versions of the same package (TODO: someday relax-    --        this for private dependencies.)  See right below.-    ---    --      * We feed it in when configuring the components to resolve-    --        module reexports.  (TODO: axe this.)-    ---    --      * We'll pass it on in the LocalBuildInfo, where preprocessors-    --        and other things will incorrectly use it to determine what-    --        the include paths and everything should be.-    ---    packageDependsIndex :: InstalledPackageIndex <--      case PackageIndex.dependencyClosure installedPackageSet-              (map Installed.installedUnitId externalPkgDeps) of-        Left packageDependsIndex -> return packageDependsIndex-        Right broken ->-          die $ "The following installed packages are broken because other"-             ++ " packages they depend on are missing. These broken "-             ++ "packages must be rebuilt before they can be used.\n"-             ++ unlines [ "package "-                       ++ display (packageId pkg)-                       ++ " is broken due to missing package "-                       ++ intercalate ", " (map display deps)-                        | (pkg, deps) <- broken ]--    -- In this section, we'd like to look at the 'packageDependsIndex'-    -- and see if we've picked multiple versions of the same-    -- installed package (this is bad, because it means you might-    -- get an error could not match foo-0.1:Type with foo-0.2:Type).-    ---    -- What is pseudoTopPkg for? I have no idea.  It was used-    -- in the very original commit which introduced checking for-    -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012,-    -- and then moved out of PackageIndex and put here later.-    -- TODO: Try this code without it...-    ---    -- TODO: Move this into a helper function-    let pseudoTopPkg :: InstalledPackageInfo-        pseudoTopPkg = emptyInstalledPackageInfo {-            Installed.installedUnitId =-               mkLegacyUnitId (packageId pkg_descr),-            Installed.sourcePackageId = packageId pkg_descr,-            Installed.depends =-              map Installed.installedUnitId externalPkgDeps-          }-    case PackageIndex.dependencyInconsistencies-       . PackageIndex.insert pseudoTopPkg-       $ packageDependsIndex of-      [] -> return ()-      inconsistencies ->-        warn verbosity $-             "This package indirectly depends on multiple versions of the same "-          ++ "package. This is highly likely to cause a compile failure.\n"-          ++ unlines [ "package " ++ display pkg ++ " requires "-                    ++ display (PackageIdentifier name ver)-                     | (name, uses) <- inconsistencies-                     , (pkg, ver) <- uses ]--    -- Compute installation directory templates, based on user-    -- configuration.-    ---    -- TODO: Move this into a helper function.-    defaultDirs :: InstallDirTemplates-        <- defaultInstallDirs (compilerFlavor comp)-                              (fromFlag (configUserInstall cfg))-                              (hasLibs pkg_descr)-    let installDirs :: InstallDirTemplates-        installDirs = combineInstallDirs fromFlagOrDefault-                        defaultDirs (configInstallDirs cfg)--    -- Check languages and extensions-    -- TODO: Move this into a helper function.-    let langlist = nub $ catMaybes $ map defaultLanguage-                   (allBuildInfo pkg_descr)-    let langs = unsupportedLanguages comp langlist-    when (not (null langs)) $-      die $ "The package " ++ display (packageId pkg_descr0)-         ++ " requires the following languages which are not "-         ++ "supported by " ++ display (compilerId comp) ++ ": "-         ++ intercalate ", " (map display langs)-    let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr)-    let exts = unsupportedExtensions comp extlist-    when (not (null exts)) $-      die $ "The package " ++ display (packageId pkg_descr0)-         ++ " requires the following language extensions which are not "-         ++ "supported by " ++ display (compilerId comp) ++ ": "-         ++ intercalate ", " (map display exts)--    -- Configure known/required programs & external build tools.-    -- Exclude build-tool deps on "internal" exes in the same package-    ---    -- TODO: Factor this into a helper package.-    let requiredBuildTools =-          [ buildTool-          | let exeNames = map exeName (executables pkg_descr)-          , bi <- allBuildInfo pkg_descr-          , buildTool@(Dependency (PackageName toolName) reqVer)-            <- buildTools bi-          , let isInternal =-                    toolName `elem` exeNames-                    -- we assume all internal build-tools are-                    -- versioned with the package:-                 && packageVersion pkg_descr `withinRange` reqVer-          , not isInternal ]--    programsConfig' <--          configureAllKnownPrograms (lessVerbose verbosity) programsConfig-      >>= configureRequiredPrograms verbosity requiredBuildTools--    (pkg_descr', programsConfig'') <--      configurePkgconfigPackages verbosity pkg_descr programsConfig'--    -- Compute internal component graph-    ---    -- The general idea is that we take a look at all the source level-    -- components (which may build-depends on each other) and form a graph.-    -- From there, we build a ComponentLocalBuildInfo for each of the-    -- components, which lets us actually build each component.-    buildComponents <--      case mkComponentsGraph pkg_descr internalPkgDeps of-        Left  componentCycle -> reportComponentCycle componentCycle-        Right comps          ->-          mkComponentsLocalBuildInfo cfg comp packageDependsIndex pkg_descr-                                     internalPkgDeps externalPkgDeps-                                     comps (configConfigurationsFlags cfg)--    -- Decide if we're going to compile with split objects.-    split_objs :: Bool <--       if not (fromFlag $ configSplitObjs cfg)-            then return False-            else case compilerFlavor comp of-                        GHC | compilerVersion comp >= Version [6,5] []-                          -> return True-                        GHCJS-                          -> return True-                        _ -> do warn verbosity-                                     ("this compiler does not support " ++-                                      "--enable-split-objs; ignoring")-                                return False--    let ghciLibByDefault =-          case compilerId comp of-            CompilerId GHC _ ->-              -- If ghc is non-dynamic, then ghci needs object files,-              -- so we build one by default.-              ---              -- Technically, archive files should be sufficient for ghci,-              -- but because of GHC bug #8942, it has never been safe to-              -- rely on them. By the time that bug was fixed, ghci had-              -- been changed to read shared libraries instead of archive-              -- files (see next code block).-              not (GHC.isDynamic comp)-            CompilerId GHCJS _ ->-              not (GHCJS.isDynamic comp)-            _ -> False--    let sharedLibsByDefault-          | fromFlag (configDynExe cfg) =-              -- build a shared library if dynamically-linked-              -- executables are requested-              True-          | otherwise = case compilerId comp of-            CompilerId GHC _ ->-              -- if ghc is dynamic, then ghci needs a shared-              -- library, so we build one by default.-              GHC.isDynamic comp-            CompilerId GHCJS _ ->-              GHCJS.isDynamic comp-            _ -> False-        withSharedLib_ =-            -- build shared libraries if required by GHC or by the-            -- executable linking mode, but allow the user to force-            -- building only static library archives with-            -- --disable-shared.-            fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg-        withDynExe_ = fromFlag $ configDynExe cfg-    when (withDynExe_ && not withSharedLib_) $ warn verbosity $-           "Executables will use dynamic linking, but a shared library "-        ++ "is not being built. Linking will fail if any executables "-        ++ "depend on the library."--    -- The --profiling flag sets the default for both libs and exes,-    -- but can be overidden by --library-profiling, or the old deprecated-    -- --executable-profiling flag.-    let profEnabledLibOnly = configProfLib cfg-        profEnabledBoth    = fromFlagOrDefault False (configProf cfg)-        profEnabledLib = fromFlagOrDefault profEnabledBoth profEnabledLibOnly-        profEnabledExe = fromFlagOrDefault profEnabledBoth (configProfExe cfg)--    -- The --profiling-detail and --library-profiling-detail flags behave-    -- similarly-    profDetailLibOnly <- checkProfDetail (configProfLibDetail cfg)-    profDetailBoth    <- liftM (fromFlagOrDefault ProfDetailDefault)-                               (checkProfDetail (configProfDetail cfg))-    let profDetailLib = fromFlagOrDefault profDetailBoth profDetailLibOnly-        profDetailExe = profDetailBoth--    when (profEnabledExe && not profEnabledLib) $-      warn verbosity $-           "Executables will be built with profiling, but library "-        ++ "profiling is disabled. Linking will fail if any executables "-        ++ "depend on the library."--    let configCoverage_ =-          mappend (configCoverage cfg) (configLibCoverage cfg)--        cfg' = cfg { configCoverage = configCoverage_ }--    reloc <--       if not (fromFlag $ configRelocatable cfg)-            then return False-            else return True--    let lbi = LocalBuildInfo {-                configFlags         = cfg',-                flagAssignment      = flags,-                extraConfigArgs     = [],  -- Currently configure does not-                                           -- take extra args, but if it-                                           -- did they would go here.-                installDirTemplates = installDirs,-                compiler            = comp,-                hostPlatform        = compPlatform,-                buildDir            = buildDir,-                componentsConfigs   = buildComponents,-                installedPkgs       = packageDependsIndex,-                pkgDescrFile        = Nothing,-                localPkgDescr       = pkg_descr',-                withPrograms        = programsConfig'',-                withVanillaLib      = fromFlag $ configVanillaLib cfg,-                withProfLib         = profEnabledLib,-                withSharedLib       = withSharedLib_,-                withDynExe          = withDynExe_,-                withProfExe         = profEnabledExe,-                withProfLibDetail   = profDetailLib,-                withProfExeDetail   = profDetailExe,-                withOptimization    = fromFlag $ configOptimization cfg,-                withDebugInfo       = fromFlag $ configDebugInfo cfg,-                withGHCiLib         = fromFlagOrDefault ghciLibByDefault $-                                      configGHCiLib cfg,-                splitObjs           = split_objs,-                stripExes           = fromFlag $ configStripExes cfg,-                stripLibs           = fromFlag $ configStripLibs cfg,-                withPackageDB       = packageDbs,-                progPrefix          = fromFlag $ configProgPrefix cfg,-                progSuffix          = fromFlag $ configProgSuffix cfg,-                relocatable         = reloc-              }--    when reloc (checkRelocatable verbosity pkg_descr lbi)--    -- TODO: This is not entirely correct, because the dirs may vary-    -- across libraries/executables-    let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest-        relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi--    unless (isAbsolute (prefix dirs)) $ die $-        "expected an absolute directory name for --prefix: " ++ prefix dirs--    info verbosity $ "Using " ++ display currentCabalId-                  ++ " compiled by " ++ display currentCompilerId-    info verbosity $ "Using compiler: " ++ showCompilerId comp-    info verbosity $ "Using install prefix: " ++ prefix dirs--    let dirinfo name dir isPrefixRelative =-          info verbosity $ name ++ " installed in: " ++ dir ++ relNote-          where relNote = case buildOS of-                  Windows | not (hasLibs pkg_descr)-                         && isNothing isPrefixRelative-                         -> "  (fixed location)"-                  _      -> ""--    dirinfo "Binaries"         (bindir dirs)     (bindir relative)-    dirinfo "Libraries"        (libdir dirs)     (libdir relative)-    dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)-    dirinfo "Data files"       (datadir dirs)    (datadir relative)-    dirinfo "Documentation"    (docdir dirs)     (docdir relative)-    dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)--    sequence_ [ reportProgram verbosity prog configuredProg-              | (prog, configuredProg) <- knownPrograms programsConfig'' ]--    return lbi--    where-      verbosity = fromFlag (configVerbosity cfg)--      checkProfDetail (Flag (ProfDetailOther other)) = do-        warn verbosity $-             "Unknown profiling detail level '" ++ other-          ++ "', using default.\n"-          ++ "The profiling detail levels are: " ++ intercalate ", "-             [ name | (name, _, _) <- knownProfDetailLevels ]-        return (Flag ProfDetailDefault)-      checkProfDetail other = return other--mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration-mkProgramsConfig cfg initialProgramsConfig = programsConfig-  where-    programsConfig = userSpecifyArgss (configProgramArgs cfg)-                   . userSpecifyPaths (configProgramPaths cfg)-                   . setProgramSearchPath searchpath-                   $ initialProgramsConfig-    searchpath     = getProgramSearchPath (initialProgramsConfig)-                  ++ map ProgramSearchPathDir-                     (fromNubList $ configProgramPathExtra cfg)---- -------------------------------------------------------------------------------- Helper functions for configure---- | Check if the user used any deprecated flags.-checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO ()-checkDeprecatedFlags verbosity cfg = do-    unless (configProfExe cfg == NoFlag) $ do-      let enable | fromFlag (configProfExe cfg) = "enable"-                 | otherwise = "disable"-      warn verbosity-        ("The flag --" ++ enable ++ "-executable-profiling is deprecated. "-         ++ "Please use --" ++ enable ++ "-profiling instead.")--    unless (configLibCoverage cfg == NoFlag) $ do-      let enable | fromFlag (configLibCoverage cfg) = "enable"-                 | otherwise = "disable"-      warn verbosity-        ("The flag --" ++ enable ++ "-library-coverage is deprecated. "-         ++ "Please use --" ++ enable ++ "-coverage instead.")---- | Sanity check: if '--exact-configuration' was given, ensure that the--- complete flag assignment was specified on the command line.-checkExactConfiguration :: GenericPackageDescription -> ConfigFlags -> IO ()-checkExactConfiguration pkg_descr0 cfg = do-    when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do-      let cmdlineFlags = map fst (configConfigurationsFlags cfg)-          allFlags     = map flagName . genPackageFlags $ pkg_descr0-          diffFlags    = allFlags \\ cmdlineFlags-      when (not . null $ diffFlags) $-        die $ "'--exact-configuration' was given, "-        ++ "but the following flags were not specified: "-        ++ intercalate ", " (map show diffFlags)---- | Create a PackageIndex that makes *any libraries that might be*--- defined internally to this package look like installed packages, in--- case an executable should refer to any of them as dependencies.------ It must be *any libraries that might be* defined rather than the--- actual definitions, because these depend on conditionals in the .cabal--- file, and we haven't resolved them yet.  finalizePackageDescription--- does the resolution of conditionals, and it takes internalPackageSet--- as part of its input.-getInternalPackages :: GenericPackageDescription-                    -> InstalledPackageIndex-getInternalPackages pkg_descr0 =-    let pkg_descr = flattenPackageDescription pkg_descr0-        mkInternalPackage lib = emptyInstalledPackageInfo {-            --TODO: should use a per-compiler method to map the source-            --      package ID into an installed package id we can use-            --      for the internal package set.  What we do here-            --      is skeevy, but we're highly unlikely to accidentally-            --      shadow something legitimate.-            Installed.installedUnitId = mkUnitId (libName lib),-            -- NB: we TEMPORARILY set the package name to be the-            -- library name.  When we actually register, it won't-            -- look like this; this is just so that internal-            -- build-depends get resolved correctly.-            Installed.sourcePackageId = PackageIdentifier (PackageName (libName lib))-                                            (pkgVersion (package pkg_descr))-          }-    in PackageIndex.fromList (map mkInternalPackage (libraries pkg_descr))----- | Returns true if a dependency is satisfiable.  This is to be passed--- to finalizePackageDescription.-dependencySatisfiable-    :: Bool-    -> InstalledPackageIndex -- ^ installed set-    -> InstalledPackageIndex -- ^ internal set-    -> Map PackageName InstalledPackageInfo -- ^ required dependencies-    -> (Dependency -> Bool)-dependencySatisfiable-    exact_config installedPackageSet internalPackageSet requiredDepsMap-    d@(Dependency depName _)-      | exact_config =-        -- When we're given '--exact-configuration', we assume that all-        -- dependencies and flags are exactly specified on the command-        -- line. Thus we only consult the 'requiredDepsMap'. Note that-        -- we're not doing the version range check, so if there's some-        -- dependency that wasn't specified on the command line,-        -- 'finalizePackageDescription' will fail.-        ---        -- TODO: mention '--exact-configuration' in the error message-        -- when this fails?-        ---        -- (However, note that internal deps don't have to be-        -- specified!)-        (depName `Map.member` requiredDepsMap) || isInternalDep--      | otherwise =-        -- Normal operation: just look up dependency in the combined-        -- package index.-        not . null . PackageIndex.lookupDependency pkgs $ d-      where-        -- NB: Prefer the INTERNAL package set-        pkgs = PackageIndex.merge installedPackageSet internalPackageSet-        isInternalDep = not . null-                      $ PackageIndex.lookupDependency internalPackageSet d---- | Relax the dependencies of this package if needed.-relaxPackageDeps :: AllowNewer -> GenericPackageDescription-                 -> GenericPackageDescription-relaxPackageDeps AllowNewerNone gpd = gpd-relaxPackageDeps AllowNewerAll  gpd = transformAllBuildDepends relaxAll gpd-  where-    relaxAll = \(Dependency pkgName verRange) ->-      Dependency pkgName (removeUpperBound verRange)-relaxPackageDeps (AllowNewerSome allowNewerDeps') gpd =-  transformAllBuildDepends relaxSome gpd-  where-    thisPkgName    = packageName gpd-    allowNewerDeps = mapMaybe f allowNewerDeps'--    f (Setup.AllowNewerDep p) = Just p-    f (Setup.AllowNewerDepScoped scope p) | scope == thisPkgName = Just p-                                          | otherwise            = Nothing--    relaxSome = \d@(Dependency depName verRange) ->-      if depName `elem` allowNewerDeps-      then Dependency depName (removeUpperBound verRange)-      else d---- | Finalize a generic package description.  The workhorse is--- 'finalizePackageDescription' but there's a bit of other nattering--- about necessary.------ TODO: what exactly is the business with @flaggedTests@ and--- @flaggedBenchmarks@?-configureFinalizedPackage-    :: Verbosity-    -> ConfigFlags-    -> [Dependency]-    -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable.-                            -- Might say it's satisfiable even when not.-    -> Compiler-    -> Platform-    -> GenericPackageDescription-    -> IO (PackageDescription, FlagAssignment)-configureFinalizedPackage verbosity cfg-  allConstraints satisfies comp compPlatform pkg_descr0 = do-    let enableTest t = t { testEnabled = fromFlag (configTests cfg) }-        flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))-                           (condTestSuites pkg_descr0)-        enableBenchmark bm = bm { benchmarkEnabled =-                                     fromFlag (configBenchmarks cfg) }-        flaggedBenchmarks = map (\(n, bm) ->-                                  (n, mapTreeData enableBenchmark bm))-                           (condBenchmarks pkg_descr0)-        pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests-                                  , condBenchmarks = flaggedBenchmarks }--    (pkg_descr0', flags) <--            case finalizePackageDescription-                   (configConfigurationsFlags cfg)-                   satisfies-                   compPlatform-                   (compilerInfo comp)-                   allConstraints-                   pkg_descr0''-            of Right r -> return r-               Left missing ->-                   die $ "Encountered missing dependencies:\n"-                     ++ (render . nest 4 . sep . punctuate comma-                                . map (disp . simplifyDependency)-                                $ missing)--    -- add extra include/lib dirs as specified in cfg-    -- we do it here so that those get checked too-    let pkg_descr = addExtraIncludeLibDirs pkg_descr0'--    when (not (null flags)) $-      info verbosity $ "Flags chosen: "-                    ++ intercalate ", " [ name ++ "=" ++ display value-                                        | (FlagName name, value) <- flags ]--    return (pkg_descr, flags)-  where-    addExtraIncludeLibDirs pkg_descr =-        let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg-                             , extraFrameworkDirs = configExtraFrameworkDirs cfg-                             , PD.includeDirs = configExtraIncludeDirs cfg}-            modifyLib l        = l{ libBuildInfo = libBuildInfo l-                                                   `mappend` extraBi }-            modifyExecutable e = e{ buildInfo    = buildInfo e-                                                   `mappend` extraBi}-        in pkg_descr{ libraries   = modifyLib         `map` libraries pkg_descr-                    , executables = modifyExecutable  `map`-                                      executables pkg_descr}---- | Check for use of Cabal features which require compiler support-checkCompilerProblems :: Compiler -> PackageDescription -> IO ()-checkCompilerProblems comp pkg_descr = do-    unless (renamingPackageFlagsSupported comp ||-                and [ True-                    | bi <- allBuildInfo pkg_descr-                    , _ <- Map.elems (targetBuildRenaming bi)]) $-        die $ "Your compiler does not support thinning and renaming on "-           ++ "package flags.  To use this feature you probably must use "-           ++ "GHC 7.9 or later."--    when (any (not.null.PD.reexportedModules) (PD.libraries pkg_descr)-          && not (reexportedModulesSupported comp)) $ do-        die $ "Your compiler does not support module re-exports. To use "-           ++ "this feature you probably must use GHC 7.9 or later."---- | Select dependencies for the package.-configureDependencies-    :: Verbosity-    -> InstalledPackageIndex -- ^ internal packages-    -> InstalledPackageIndex -- ^ installed packages-    -> Map PackageName InstalledPackageInfo -- ^ required deps-    -> PackageDescription-    -> IO ([PackageId], [InstalledPackageInfo])-configureDependencies verbosity-  internalPackageSet installedPackageSet requiredDepsMap pkg_descr = do-    let selectDependencies :: [Dependency] ->-                              ([FailedDependency], [ResolvedDependency])-        selectDependencies =-            partitionEithers-          . map (selectDependency internalPackageSet installedPackageSet-                                  requiredDepsMap)--        (failedDeps, allPkgDeps) =-          selectDependencies (buildDepends pkg_descr)--        internalPkgDeps = [ pkgid-                          | InternalDependency _ pkgid <- allPkgDeps ]-        externalPkgDeps = [ pkg-                          | ExternalDependency _ pkg   <- allPkgDeps ]--    when (not (null internalPkgDeps)-          && not (newPackageDepsBehaviour pkg_descr)) $-        die $ "The field 'build-depends: "-           ++ intercalate ", " (map (display . packageName) internalPkgDeps)-           ++ "' refers to a library which is defined within the same "-           ++ "package. To use this feature the package must specify at "-           ++ "least 'cabal-version: >= 1.8'."--    reportFailedDependencies failedDeps-    reportSelectedDependencies verbosity allPkgDeps--    return (internalPkgDeps, externalPkgDeps)---- -------------------------------------------------------------------------------- Configuring package dependencies--reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO ()-reportProgram verbosity prog Nothing-    = info verbosity $ "No " ++ programName prog ++ " found"-reportProgram verbosity prog (Just configuredProg)-    = info verbosity $ "Using " ++ programName prog ++ version ++ location-    where location = case programLocation configuredProg of-            FoundOnSystem p -> " found on system at: " ++ p-            UserSpecified p -> " given by user at: " ++ p-          version = case programVersion configuredProg of-            Nothing -> ""-            Just v  -> " version " ++ display v--hackageUrl :: String-hackageUrl = "http://hackage.haskell.org/package/"--data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo-                        | InternalDependency Dependency PackageId -- should be a-                                                                      -- lib name--data FailedDependency = DependencyNotExists PackageName-                      | DependencyNoVersion Dependency---- | Test for a package dependency and record the version we have installed.-selectDependency :: InstalledPackageIndex  -- ^ Internally defined packages-                 -> InstalledPackageIndex  -- ^ Installed packages-                 -> Map PackageName InstalledPackageInfo-                    -- ^ Packages for which we have been given specific deps to-                    -- use-                 -> Dependency-                 -> Either FailedDependency ResolvedDependency-selectDependency internalIndex installedIndex requiredDepsMap-  dep@(Dependency pkgname vr) =-  -- If the dependency specification matches anything in the internal package-  -- index, then we prefer that match to anything in the second.-  -- For example:-  ---  -- Name: MyLibrary-  -- Version: 0.1-  -- Library-  --     ..-  -- Executable my-exec-  --     build-depends: MyLibrary-  ---  -- We want "build-depends: MyLibrary" always to match the internal library-  -- even if there is a newer installed library "MyLibrary-0.2".-  -- However, "build-depends: MyLibrary >= 0.2" should match the installed one.-  case PackageIndex.lookupPackageName internalIndex pkgname of-    [(_,[pkg])] | packageVersion pkg `withinRange` vr-           -> Right $ InternalDependency dep (packageId pkg)--    _      -> case Map.lookup pkgname requiredDepsMap of-      -- If we know the exact pkg to use, then use it.-      Just pkginstance -> Right (ExternalDependency dep pkginstance)-      -- Otherwise we just pick an arbitrary instance of the latest version.-      Nothing -> case PackageIndex.lookupDependency installedIndex dep of-        []   -> Left  $ DependencyNotExists pkgname-        pkgs -> Right $ ExternalDependency dep $-                case last pkgs of-                  (_ver, pkginstances) -> head pkginstances--reportSelectedDependencies :: Verbosity-                           -> [ResolvedDependency] -> IO ()-reportSelectedDependencies verbosity deps =-  info verbosity $ unlines-    [ "Dependency " ++ display (simplifyDependency dep)-                    ++ ": using " ++ display pkgid-    | resolved <- deps-    , let (dep, pkgid) = case resolved of-            ExternalDependency dep' pkg'   -> (dep', packageId pkg')-            InternalDependency dep' pkgid' -> (dep', pkgid') ]--reportFailedDependencies :: [FailedDependency] -> IO ()-reportFailedDependencies []     = return ()-reportFailedDependencies failed =-    die (intercalate "\n\n" (map reportFailedDependency failed))--  where-    reportFailedDependency (DependencyNotExists pkgname) =-         "there is no version of " ++ display pkgname ++ " installed.\n"-      ++ "Perhaps you need to download and install it from\n"-      ++ hackageUrl ++ display pkgname ++ "?"--    reportFailedDependency (DependencyNoVersion dep) =-        "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n"---- | List all installed packages in the given package databases.-getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -- ^ The stack of package databases.-                     -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packageDBs progconf = do-  when (null packageDBs) $-    die $ "No package databases have been specified. If you use "-       ++ "--package-db=clear, you must follow it with --package-db= "-       ++ "with 'global', 'user' or a specific file."--  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC   -> GHC.getInstalledPackages verbosity comp packageDBs progconf-    GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf-    JHC   -> JHC.getInstalledPackages verbosity packageDBs progconf-    LHC   -> LHC.getInstalledPackages verbosity packageDBs progconf-    UHC   -> UHC.getInstalledPackages verbosity comp packageDBs progconf-    HaskellSuite {} ->-      HaskellSuite.getInstalledPackages verbosity packageDBs progconf-    flv -> die $ "don't know how to find the installed packages for "-              ++ display flv---- | Like 'getInstalledPackages', but for a single package DB.------ NB: Why isn't this always a fall through to 'getInstalledPackages'?--- That is because 'getInstalledPackages' performs some sanity checks--- on the package database stack in question.  However, when sandboxes--- are involved these sanity checks are not desirable.-getPackageDBContents :: Verbosity -> Compiler-                     -> PackageDB -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getPackageDBContents verbosity comp packageDB progconf = do-  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC -> GHC.getPackageDBContents verbosity packageDB progconf-    GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf-    -- For other compilers, try to fall back on 'getInstalledPackages'.-    _   -> getInstalledPackages verbosity comp [packageDB] progconf----- | A set of files (or directories) that can be monitored to detect when--- there might have been a change in the installed packages.----getInstalledPackagesMonitorFiles :: Verbosity -> Compiler-                                 -> PackageDBStack-                                 -> ProgramConfiguration -> Platform-                                 -> IO [FilePath]-getInstalledPackagesMonitorFiles verbosity comp packageDBs progconf platform =-  case compilerFlavor comp of-    GHC   -> GHC.getInstalledPackagesMonitorFiles-               verbosity platform progconf packageDBs-    other -> do-      warn verbosity $ "don't know how to find change monitoring files for "-                    ++ "the installed package databases for " ++ display other-      return []---- | The user interface specifies the package dbs to use with a combination of--- @--global@, @--user@ and @--package-db=global|user|clear|$file@.--- This function combines the global/user flag and interprets the package-db--- flag into a single package db stack.----interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack-interpretPackageDbFlags userInstall specificDBs =-    extra initialStack specificDBs-  where-    initialStack | userInstall = [GlobalPackageDB, UserPackageDB]-                 | otherwise   = [GlobalPackageDB]--    extra dbs' []            = dbs'-    extra _    (Nothing:dbs) = extra []             dbs-    extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs--newPackageDepsBehaviourMinVersion :: Version-newPackageDepsBehaviourMinVersion = Version [1,7,1] []---- In older cabal versions, there was only one set of package dependencies for--- the whole package. In this version, we can have separate dependencies per--- target, but we only enable this behaviour if the minimum cabal version--- specified is >= a certain minimum. Otherwise, for compatibility we use the--- old behaviour.-newPackageDepsBehaviour :: PackageDescription -> Bool-newPackageDepsBehaviour pkg =-   specVersion pkg >= newPackageDepsBehaviourMinVersion---- We are given both --constraint="foo < 2.0" style constraints and also--- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".------ When finalising the package we have to take into account the specific--- installed deps we've been given, and the finalise function expects--- constraints, so we have to translate these deps into version constraints.------ But after finalising we then have to make sure we pick the right specific--- deps in the end. So we still need to remember which installed packages to--- pick.-combinedConstraints :: [Dependency] ->-                       [(PackageName, UnitId)] ->-                       InstalledPackageIndex ->-                       Either String ([Dependency],-                                      Map PackageName InstalledPackageInfo)-combinedConstraints constraints dependencies installedPackages = do--    when (not (null badUnitIds)) $-      Left $ render $ text "The following package dependencies were requested"-         $+$ nest 4 (dispDependencies badUnitIds)-         $+$ text "however the given installed package instance does not exist."--    when (not (null badNames)) $-      Left $ render $ text "The following package dependencies were requested"-         $+$ nest 4 (dispDependencies badNames)-         $+$ text ("however the installed package's name does not match "-                   ++ "the name given.")--    --TODO: we don't check that all dependencies are used!--    return (allConstraints, idConstraintMap)--  where-    allConstraints :: [Dependency]-    allConstraints = constraints-                  ++ [ thisPackageVersion (packageId pkg)-                     | (_, _, Just pkg) <- dependenciesPkgInfo ]--    idConstraintMap :: Map PackageName InstalledPackageInfo-    idConstraintMap = Map.fromList-                        [ (packageName pkg, pkg)-                        | (_, _, Just pkg) <- dependenciesPkgInfo ]--    -- The dependencies along with the installed package info, if it exists-    dependenciesPkgInfo :: [(PackageName, UnitId,-                             Maybe InstalledPackageInfo)]-    dependenciesPkgInfo =-      [ (pkgname, ipkgid, mpkg)-      | (pkgname, ipkgid) <- dependencies-      , let mpkg = PackageIndex.lookupUnitId-                     installedPackages ipkgid-      ]--    -- If we looked up a package specified by an installed package id-    -- (i.e. someone has written a hash) and didn't find it then it's-    -- an error.-    badUnitIds =-      [ (pkgname, ipkgid)-      | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ]--    -- If someone has written e.g.-    -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have-    -- probably made a mistake.-    badNames =-      [ (requestedPkgName, ipkgid)-      | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo-      , let foundPkgName = packageName pkg-      , requestedPkgName /= foundPkgName ]--    dispDependencies deps =-      hsep [    text "--dependency="-             <> quotes (disp pkgname <> char '=' <> disp ipkgid)-           | (pkgname, ipkgid) <- deps ]---- -------------------------------------------------------------------------------- Configuring program dependencies--configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration-                             -> IO ProgramConfiguration-configureRequiredPrograms verbosity deps conf =-  foldM (configureRequiredProgram verbosity) conf deps--configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency-                            -> IO ProgramConfiguration-configureRequiredProgram verbosity conf-  (Dependency (PackageName progName) verRange) =-  case lookupKnownProgram progName conf of-    Nothing -> die ("Unknown build tool " ++ progName)-    Just prog-      -- requireProgramVersion always requires the program have a version-      -- but if the user says "build-depends: foo" ie no version constraint-      -- then we should not fail if we cannot discover the program version.-      | verRange == anyVersion -> do-          (_, conf') <- requireProgram verbosity prog conf-          return conf'-      | otherwise -> do-          (_, _, conf') <- requireProgramVersion verbosity prog verRange conf-          return conf'---- -------------------------------------------------------------------------------- Configuring pkg-config package dependencies--configurePkgconfigPackages :: Verbosity -> PackageDescription-                           -> ProgramConfiguration-                           -> IO (PackageDescription, ProgramConfiguration)-configurePkgconfigPackages verbosity pkg_descr conf-  | null allpkgs = return (pkg_descr, conf)-  | otherwise    = do-    (_, _, conf') <- requireProgramVersion-                       (lessVerbose verbosity) pkgConfigProgram-                       (orLaterVersion $ Version [0,9,0] []) conf-    mapM_ requirePkg allpkgs-    libs' <- mapM addPkgConfigBILib (libraries pkg_descr)-    exes' <- mapM addPkgConfigBIExe (executables pkg_descr)-    tests' <- mapM addPkgConfigBITest (testSuites pkg_descr)-    benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr)-    let pkg_descr' = pkg_descr { libraries = libs', executables = exes',-                                 testSuites = tests', benchmarks = benches' }-    return (pkg_descr', conf')--  where-    allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr)-    pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity)-                  pkgConfigProgram conf--    requirePkg dep@(Dependency (PackageName pkg) range) = do-      version <- pkgconfig ["--modversion", pkg]-                 `catchIO`   (\_ -> die notFound)-                 `catchExit` (\_ -> die notFound)-      case simpleParse version of-        Nothing -> die "parsing output of pkg-config --modversion failed"-        Just v | not (withinRange v range) -> die (badVersion v)-               | otherwise                 -> info verbosity (depSatisfied v)-      where-        notFound     = "The pkg-config package '" ++ pkg ++ "'"-                    ++ versionRequirement-                    ++ " is required but it could not be found."-        badVersion v = "The pkg-config package '" ++ pkg ++ "'"-                    ++ versionRequirement-                    ++ " is required but the version installed on the"-                    ++ " system is version " ++ display v-        depSatisfied v = "Dependency " ++ display dep-                      ++ ": using version " ++ display v--        versionRequirement-          | isAnyVersion range = ""-          | otherwise          = " version " ++ display range--    -- Adds pkgconfig dependencies to the build info for a component-    addPkgConfigBI compBI setCompBI comp = do-      bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))-      return $ setCompBI comp (compBI comp `mappend` bi)--    -- Adds pkgconfig dependencies to the build info for a library-    addPkgConfigBILib = addPkgConfigBI libBuildInfo $-                          \lib bi -> lib { libBuildInfo = bi }--    -- Adds pkgconfig dependencies to the build info for an executable-    addPkgConfigBIExe = addPkgConfigBI buildInfo $-                          \exe bi -> exe { buildInfo = bi }--    -- Adds pkgconfig dependencies to the build info for a test suite-    addPkgConfigBITest = addPkgConfigBI testBuildInfo $-                          \test bi -> test { testBuildInfo = bi }--    -- Adds pkgconfig dependencies to the build info for a benchmark-    addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $-                          \bench bi -> bench { benchmarkBuildInfo = bi }--    pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo-    pkgconfigBuildInfo []      = return Mon.mempty-    pkgconfigBuildInfo pkgdeps = do-      let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ]-      ccflags <- pkgconfig ("--cflags" : pkgs)-      ldflags <- pkgconfig ("--libs"   : pkgs)-      return (ccLdOptionsBuildInfo (words ccflags) (words ldflags))---- | Makes a 'BuildInfo' from C compiler and linker flags.------ This can be used with the output from configuration programs like pkg-config--- and similar package-specific programs like mysql-config, freealut-config etc.--- For example:------ > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"]--- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"]--- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags))----ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo-ccLdOptionsBuildInfo cflags ldflags =-  let (includeDirs',  cflags')   = partition ("-I" `isPrefixOf`) cflags-      (extraLibs',    ldflags')  = partition ("-l" `isPrefixOf`) ldflags-      (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'-  in mempty {-       PD.includeDirs  = map (drop 2) includeDirs',-       PD.extraLibs    = map (drop 2) extraLibs',-       PD.extraLibDirs = map (drop 2) extraLibDirs',-       PD.ccOptions    = cflags',-       PD.ldOptions    = ldflags''-     }---- -------------------------------------------------------------------------------- Determining the compiler details--configCompilerAuxEx :: ConfigFlags-                    -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)-                                           (flagToMaybe $ configHcPath cfg)-                                           (flagToMaybe $ configHcPkg cfg)-                                           programsConfig-                                           (fromFlag (configVerbosity cfg))-  where-    programsConfig = mkProgramsConfig cfg defaultProgramConfiguration--configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-                 -> ProgramConfiguration -> Verbosity-                 -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"-configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do-  (comp, maybePlatform, programsConfig) <- case hcFlavor of-    GHC   -> GHC.configure  verbosity hcPath hcPkg conf-    GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf-    JHC   -> JHC.configure  verbosity hcPath hcPkg conf-    LHC   -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf-                LHC.configure  verbosity hcPath Nothing ghcConf-    UHC   -> UHC.configure  verbosity hcPath hcPkg conf-    HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf-    _    -> die "Unknown compiler"-  return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)---- Ideally we would like to not have separate configCompiler* and--- configCompiler*Ex sets of functions, but there are many custom setup scripts--- in the wild that are using them, so the versions with old types are kept for--- backwards compatibility. Platform was added to the return triple in 1.18.--{-# DEPRECATED configCompiler-    "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-}-configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-               -> ProgramConfiguration -> Verbosity-               -> IO (Compiler, ProgramConfiguration)-configCompiler mFlavor hcPath hcPkg conf verbosity =-  fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity--{-# DEPRECATED configCompilerAux-    "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}-configCompilerAux :: ConfigFlags-                  -> IO (Compiler, ProgramConfiguration)-configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx---- -------------------------------------------------------------------------------- Making the internal component graph---- | Given the package description and the set of package names which--- are considered internal (the current package name and any internal--- libraries are considered internal), create a graph of dependencies--- between the components.  This is NOT necessarily the build order--- (although it is in the absence of Backpack.)------ TODO: tighten up the type of 'internalPkgDeps'-mkComponentsGraph :: PackageDescription-                  -> [PackageId]-                  -> Either [ComponentName]-                            [(Component, [ComponentName])]-mkComponentsGraph pkg_descr internalPkgDeps =-    let graph = [ (c, componentName c, componentDeps c)-                | c <- pkgEnabledComponents pkg_descr ]-     in case checkComponentsCyclic graph of-          Just ccycle -> Left  [ cname | (_,cname,_) <- ccycle ]-          Nothing     -> Right [ (c, cdeps) | (c, _, cdeps) <- topSortFromEdges graph ]-  where-    -- The dependencies for the given component-    componentDeps component =-         [ CExeName toolname | Dependency (PackageName toolname) _-                               <- buildTools bi-                             , toolname `elem` map exeName-                               (executables pkg_descr) ]--      ++ [ CLibName toolname | Dependency pkgname@(PackageName toolname) _-                               <- targetBuildDepends bi-                             , pkgname `elem` map packageName internalPkgDeps ]-      where-        bi = componentBuildInfo component--reportComponentCycle :: [ComponentName] -> IO a-reportComponentCycle cnames =-    die $ "Components in the package depend on each other in a cyclic way:\n  "-       ++ intercalate " depends on "-            [ "'" ++ showComponentName cname ++ "'"-            | cname <- cnames ++ [head cnames] ]---- | This method computes a default, "good enough" 'ComponentId'--- for a package.  The intent is that cabal-install (or the user) will--- specify a more detailed IPID via the @--ipid@ flag if necessary.-computeComponentId-    :: Flag String-    -> PackageIdentifier-    -> ComponentName-    -- TODO: careful here!-    -> [ComponentId] -- IPIDs of the component dependencies-    -> FlagAssignment-    -> ComponentId-computeComponentId mb_explicit pid cname dep_ipids flagAssignment = do-    -- show is found to be faster than intercalate and then replacement of-    -- special character used in intercalating. We cannot simply hash by-    -- doubly concating list, as it just flatten out the nested list, so-    -- different sources can produce same hash-    let hash = hashToBase62 $-                -- For safety, include the package + version here-                -- for GHC 7.10, where just the hash is used as-                -- the package key-                         display pid-                      ++ show dep_ipids-                      ++ show flagAssignment-        generated_base = display pid ++ "-" ++ hash-        explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env-                                                    (toPathTemplate cid0))-            -- Hack to reuse install dirs machinery-            -- NB: no real IPID available at this point-          where env = packageTemplateEnv pid (mkUnitId "")-        actual_base = case mb_explicit of-                        Flag cid0 -> explicit_base cid0-                        NoFlag -> generated_base-    ComponentId $ actual_base-                    ++ (case componentNameString (pkgName pid) cname of-                            Nothing -> ""-                            Just s -> "-" ++ s)--hashToBase62 :: String -> String-hashToBase62 s = showFingerprint $ fingerprintString s-  where-    showIntAtBase62 x = showIntAtBase 62 representBase62 x ""-    representBase62 x-        | x < 10 = chr (48 + x)-        | x < 36 = chr (65 + x - 10)-        | x < 62 = chr (97 + x - 36)-        | otherwise = '@'-    showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b---- | Computes the package name for a library.  If this is the public--- library, it will just be the original package name; otherwise,--- it will be a munged package name recording the original package--- name as well as the name of the internal library.------ A lot of tooling in the Haskell ecosystem assumes that if something--- is installed to the package database with the package name 'foo',--- then it actually is an entry for the (only public) library in package--- 'foo'.  With internal packages, this is not necessarily true:--- a public library as well as arbitrarily many internal libraries may--- come from the same package.  To prevent tools from getting confused--- in this case, the package name of these internal libraries is munged--- so that they do not conflict the public library proper.------ We munge into a reserved namespace, "z-", and encode both the--- component name and the package name of an internal library using the--- following format:------      compat-pkg-name ::= "z-" package-name "-z-" library-name------ where package-name and library-name have "-" ( "z" + ) "-"--- segments encoded by adding an extra "z".------ When we have the public library, the compat-pkg-name is just the--- package-name, no surprises there!----computeCompatPackageName :: PackageName -> ComponentName -> PackageName-computeCompatPackageName pkg_name cname-    | Just cname_str <- componentNameString pkg_name cname-    = let zdashcode s = go s (Nothing :: Maybe Int) []-            where go [] _ r = reverse r-                  go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)-                  go ('-':z) _        r = go z (Just 0) ('-':r)-                  go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)-                  go (c:z)   _        r = go z Nothing (c:r)-      in PackageName $ "z-" ++ zdashcode (display pkg_name)-                   ++ "-z-" ++ zdashcode cname_str-    | otherwise-    = pkg_name---- | In GHC 8.0, the string we pass to GHC to use for symbol--- names for a package can be an arbitrary, IPID-compatible string.--- However, prior to GHC 8.0 there are some restrictions on what--- format this string can be (due to how ghc-pkg parsed the key):------      1. In GHC 7.10, the string had either be of the form---      foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated---      prefix and ABCD is two base-64 encoded 64-bit integers,---      or a GHC 7.8 style identifier.------      2. In GHC 7.8, the string had to be a valid package identifier---      like foo-0.1.------ So, the problem is that Cabal, in general, has a general IPID,--- but needs to figure out a package key / package ID that the--- old ghc-pkg will actually accept.  But there's an EVERY WORSE--- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx--- as if it were a package identifier, which means it will SILENTLY--- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)--- So we must CONNIVE to ensure that we don't pick something that--- looks like this.------ So this function attempts to define a mapping into the old formats.------ The mapping for GHC 7.8 and before:------      * We use the *compatibility* package name and version.  For---        public libraries this is just the package identifier; for---        internal libraries, it's something like "z-pkgname-z-libname-0.1".---        See 'computeCompatPackageName' for more details.------ The mapping for GHC 7.10:------      * For CLibName:---          If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would---          validly parse as a package key, we pass "ABCDEF".  (NB: not---          all hashes parse this way, because GHC 7.10 mandated that---          these hashes be two base-62 encoded 64 bit integers),---          but hashes that Cabal generated using 'computeComponentId'---          are guaranteed to have this form.------          If it is not of this form, we rehash the IPID into the---          correct form and pass that.------      * For sub-components, we rehash the IPID into the correct format---        and pass that.----computeCompatPackageKey-    :: Compiler-    -> PackageName-    -> Version-    -> UnitId-    -> String-computeCompatPackageKey comp pkg_name pkg_version (SimpleUnitId (ComponentId str))-    | not (packageKeySupported comp) =-        display pkg_name ++ "-" ++ display pkg_version-    | not (unifiedIPIDRequired comp) =-        let mb_verbatim_key-                = case simpleParse str :: Maybe PackageId of-                    -- Something like 'foo-0.1', use it verbatim.-                    -- (NB: hash tags look like tags, so they are parsed,-                    -- so the extra equality check tests if a tag was dropped.)-                    Just pid0 | display pid0 == str -> Just str-                    _ -> Nothing-            mb_truncated_key-                = let cand = reverse (takeWhile isAlphaNum (reverse str))-                  in if length cand == 22 && all isAlphaNum cand-                        then Just cand-                        else Nothing-            rehashed_key = hashToBase62 str-        in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)-    | otherwise = str---topSortFromEdges :: Ord key => [(node, key, [key])]-                            -> [(node, key, [key])]-topSortFromEdges es =-    let (graph, vertexToNode, _) = graphFromEdges es-    in reverse (map vertexToNode (topSort graph))--mkComponentsLocalBuildInfo :: ConfigFlags-                           -> Compiler-                           -> InstalledPackageIndex-                           -> PackageDescription-                           -> [PackageId] -- internal package deps-                           -> [InstalledPackageInfo] -- external package deps-                           -> [(Component, [ComponentName])]-                           -> FlagAssignment-                           -> IO [(ComponentLocalBuildInfo,-                                   [UnitId])]-mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr-                           internalPkgDeps externalPkgDeps-                           graph flagAssignment =-    foldM go [] graph-  where-    go z (component, dep_cnames) = do-        clbi <- componentLocalBuildInfo z component-        -- NB: We want to preserve cdeps because it contains extra-        -- information like build-tools ordering-        let dep_uids = [ componentUnitId dep_clbi-                       | cname <- dep_cnames-                       -- Being in z relies on topsort!-                       , (dep_clbi, _) <- z-                       , componentLocalName dep_clbi == cname ]-        return ((clbi, dep_uids):z)--    -- The allPkgDeps contains all the package deps for the whole package-    -- but we need to select the subset for this specific component.-    -- we just take the subset for the package names this component-    -- needs. Note, this only works because we cannot yet depend on two-    -- versions of the same package.-    componentLocalBuildInfo :: [(ComponentLocalBuildInfo, [UnitId])]-                            -> Component -> IO ComponentLocalBuildInfo-    componentLocalBuildInfo internalComps component =-      case component of-      CLib lib -> do-        let exports = map (\n -> Installed.ExposedModule n Nothing)-                          (PD.exposedModules lib)-            mb_reexports = resolveModuleReexports installedPackages-                                                  (packageId pkg_descr)-                                                  uid-                                                  externalPkgDeps lib-        reexports <- case mb_reexports of-            Left problems -> reportModuleReexportProblems problems-            Right r -> return r--        return LibComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentUnitId = uid,-          componentLocalName = componentName component,-          componentIsPublic = libName lib == display (packageName (package pkg_descr)),-          componentCompatPackageKey = compat_key,-          componentCompatPackageName = compat_name,-          componentIncludes = includes,-          componentExposedModules = exports ++ reexports-        }-      CExe _ ->-        return ExeComponentLocalBuildInfo {-          componentUnitId = uid,-          componentLocalName = componentName component,-          componentPackageDeps = cpds,-          componentIncludes = includes-        }-      CTest _ ->-        return TestComponentLocalBuildInfo {-          componentUnitId = uid,-          componentLocalName = componentName component,-          componentPackageDeps = cpds,-          componentIncludes = includes-        }-      CBench _ ->-        return BenchComponentLocalBuildInfo {-          componentUnitId = uid,-          componentLocalName = componentName component,-          componentPackageDeps = cpds,-          componentIncludes = includes-        }-      where--        -- TODO configIPID should have name changed-        cid = computeComponentId (configIPID cfg) (package pkg_descr)-                (componentName component)-                (getDeps (componentName component))-                flagAssignment-        uid = SimpleUnitId cid-        PackageIdentifier pkg_name pkg_ver = package pkg_descr-        compat_name = computeCompatPackageName pkg_name (componentName component)-        compat_key = computeCompatPackageKey comp compat_name pkg_ver uid--        bi = componentBuildInfo component--        lookupInternalPkg :: PackageId -> UnitId-        lookupInternalPkg pkgid = do-            let matcher (clbi, _)-                    | CLibName str <- componentLocalName clbi-                    , str == display (pkgName pkgid)-                    = Just (componentUnitId clbi)-                matcher _ = Nothing-            case catMaybes (map matcher internalComps) of-                [x] -> x-                _ -> error "lookupInternalPkg"--        cpds = if newPackageDepsBehaviour pkg_descr-               then dedup $-                    [ (Installed.installedUnitId pkg, packageId pkg)-                    | pkg <- selectSubset bi externalPkgDeps ]-                 ++ [ (lookupInternalPkg pkgid, pkgid)-                    | pkgid <- selectSubset bi internalPkgDeps ]-               else [ (Installed.installedUnitId pkg, packageId pkg)-                    | pkg <- externalPkgDeps ]-        includes = map (\(i,p) -> (i,lookupRenaming p cprns)) cpds-        cprns = if newPackageDepsBehaviour pkg_descr-                then targetBuildRenaming bi-                else Map.empty--    dedup = Map.toList . Map.fromList--    -- TODO: this should include internal deps too-    getDeps :: ComponentName -> [ComponentId]-    getDeps cname =-      let externalPkgs-            = maybe [] (\lib -> selectSubset (componentBuildInfo lib)-                                             externalPkgDeps)-                       (lookupComponent pkg_descr cname)-      in map Installed.installedComponentId externalPkgs--    selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]-    selectSubset bi pkgs =-        [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ]--    names :: BuildInfo -> [PackageName]-    names bi = [ name | Dependency name _ <- targetBuildDepends bi ]---- | Given the author-specified re-export declarations from the .cabal file,--- resolve them to the form that we need for the package database.------ An invariant of the package database is that we always link the re-export--- directly to its original defining location (rather than indirectly via a--- chain of re-exporting packages).----resolveModuleReexports :: InstalledPackageIndex-                       -> PackageId-                       -> UnitId-                       -> [InstalledPackageInfo]-                       -> Library-                       -> Either [(ModuleReexport, String)] -- errors-                                 [Installed.ExposedModule] -- ok-resolveModuleReexports installedPackages srcpkgid key externalPkgDeps lib =-    case partitionEithers-         (map resolveModuleReexport (PD.reexportedModules lib)) of-      ([],  ok) -> Right ok-      (errs, _) -> Left  errs-  where-    -- A mapping from visible module names to their original defining-    -- module name.  We also record the package name of the package which-    -- *immediately* provided the module (not the original) to handle if the-    -- user explicitly says which build-depends they want to reexport from.-    visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)]-    visibleModules =-      Map.fromListWith (++) $-        [ (Installed.exposedName exposedModule, [(exportingPackageName,-                                                  exposedModule)])-          -- The package index here contains all the indirect deps of the-          -- package we're configuring, but we want just the direct deps-        | let directDeps = Set.fromList-                           (map Installed.installedUnitId externalPkgDeps)-        , pkg <- PackageIndex.allPackages installedPackages-        , Installed.installedUnitId pkg `Set.member` directDeps-        , let exportingPackageName = packageName pkg-        , exposedModule <- visibleModuleDetails pkg-        ]-     ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)])-        | visibleModuleName <- PD.exposedModules lib-                            ++ otherModules (libBuildInfo lib)-        , let exportingPackageName = packageName srcpkgid-              definingModuleName   = visibleModuleName-              definingPackageId    = key-              originalModule = Module definingPackageId-                                      definingModuleName-              exposedModule  = Installed.ExposedModule visibleModuleName-                                                       (Just originalModule)-        ]--    -- All the modules exported from this package and their defining name and-    -- package (either defined here in this package or re-exported from some-    -- other package).  Return an ExposedModule because we want to hold onto-    -- signature information.-    visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule]-    visibleModuleDetails pkg = do-        exposedModule <- Installed.exposedModules pkg-        case Installed.exposedReexport exposedModule of-        -- The first case is the modules actually defined in this package.-        -- In this case the reexport will point to this package.-            Nothing -> return exposedModule {-              Installed.exposedReexport =-                 Just (Module-                       (Installed.installedUnitId pkg)-                       (Installed.exposedName exposedModule)) }-        -- On the other hand, a visible module might actually be itself-        -- a re-export! In this case, the re-export info for the package-        -- doing the re-export will point us to the original defining-        -- module name and package, so we can reuse the entry.-            Just _ -> return exposedModule--    resolveModuleReexport reexport@ModuleReexport {-         moduleReexportOriginalPackage = moriginalPackageName,-         moduleReexportOriginalName    = originalName,-         moduleReexportName            = newName-      } =--      let filterForSpecificPackage =-            case moriginalPackageName of-              Nothing                  -> id-              Just originalPackageName ->-                filter (\(pkgname, _) -> pkgname == originalPackageName)--          matches = filterForSpecificPackage-                      (Map.findWithDefault [] originalName visibleModules)-      in-      case (matches, moriginalPackageName) of-        ((_, exposedModule):rest, _)-          -- TODO: Refine this check for signatures-          | all (\(_, exposedModule') ->-                  Installed.exposedReexport exposedModule-                  == Installed.exposedReexport exposedModule') rest-           -> Right exposedModule { Installed.exposedName = newName }--        ([], Just originalPackageName)-           -> Left $ (,) reexport-                   $ "The package " ++ display originalPackageName-                  ++ " does not export a module " ++ display originalName--        ([], Nothing)-           -> Left $ (,) reexport-                   $ "The module " ++ display originalName-                  ++ " is not exported by any suitable package (this package "-                  ++ "itself nor any of its 'build-depends' dependencies)."--        (ms, _)-           -> Left $ (,) reexport-                   $ "The module " ++ display originalName ++ " is exported "-                  ++ "by more than one package ("-                  ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ]-                  ++ ") and so the re-export is ambiguous. The ambiguity can "-                  ++ "be resolved by qualifying by the package name. The "-                  ++ "syntax is 'packagename:moduleName [as newname]'."--        -- Note: if in future Cabal allows directly depending on multiple-        -- instances of the same package (e.g. backpack) then an additional-        -- ambiguity case is possible here: (_, Just originalPackageName)-        -- with the module being ambiguous despite being qualified by a-        -- package name. Presumably by that time we'll have a mechanism to-        -- qualify the instance we're referring to.--reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a-reportModuleReexportProblems reexportProblems =-  die $ unlines-    [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg-    | (reexport, msg) <- reexportProblems ]---- -------------------------------------------------------------------------------- Testing C lib and header dependencies---- Try to build a test C program which includes every header and links every--- lib. If that fails, try to narrow it down by preprocessing (only) and linking--- with individual headers and libs.  If none is the obvious culprit then give a--- generic error message.--- TODO: produce a log file from the compiler errors, if any.-checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()-checkForeignDeps pkg lbi verbosity = do-  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling-                                                               -- lucky-           (return ())-           (do missingLibs <- findMissingLibs-               missingHdr  <- findOffendingHdr-               explainErrors missingHdr missingLibs)-      where-        allHeaders = collectField PD.includes-        allLibs    = collectField PD.extraLibs--        ifBuildsWith headers args success failure = do-            ok <- builds (makeProgram headers) args-            if ok then success else failure--        findOffendingHdr =-            ifBuildsWith allHeaders ccArgs-                         (return Nothing)-                         (go . tail . inits $ allHeaders)-            where-              go [] = return Nothing       -- cannot happen-              go (hdrs:hdrsInits) =-                    -- Try just preprocessing first-                    ifBuildsWith hdrs cppArgs-                      -- If that works, try compiling too-                      (ifBuildsWith hdrs ccArgs-                        (go hdrsInits)-                        (return . Just . Right . last $ hdrs))-                      (return . Just . Left . last $ hdrs)--              cppArgs = "-E":commonCppArgs -- preprocess only-              ccArgs  = "-c":commonCcArgs  -- don't try to link--        findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs)-                                       (return [])-                                       (filterM (fmap not . libExists) allLibs)--        libExists lib = builds (makeProgram []) (makeLdArgs [lib])--        commonCppArgs = platformDefines lbi-                     -- TODO: This is a massive hack, to work around the-                     -- fact that the test performed here should be-                     -- PER-component (c.f. the "I'm Feeling Lucky"; we-                     -- should NOT be glomming everything together.)-                     ++ [ "-I" ++ buildDir lbi </> "autogen" ]-                     ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]-                     ++ ["-I."]-                     ++ collectField PD.cppOptions-                     ++ collectField PD.ccOptions-                     ++ [ "-I" ++ dir-                        | dep <- deps-                        , dir <- Installed.includeDirs dep ]-                     ++ [ opt-                        | dep <- deps-                        , opt <- Installed.ccOptions dep ]--        commonCcArgs  = commonCppArgs-                     ++ collectField PD.ccOptions-                     ++ [ opt-                        | dep <- deps-                        , opt <- Installed.ccOptions dep ]--        commonLdArgs  = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ]-                     ++ collectField PD.ldOptions-                     ++ [ "-L" ++ dir-                        | dep <- deps-                        , dir <- Installed.libraryDirs dep ]-                     --TODO: do we also need dependent packages' ld options?-        makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs--        makeProgram hdrs = unlines $-                           [ "#include \""  ++ hdr ++ "\"" | hdr <- hdrs ] ++-                           ["int main(int argc, char** argv) { return 0; }"]--        collectField f = concatMap f allBi-        allBi = allBuildInfo pkg-        deps = PackageIndex.topologicalOrder (installedPkgs lbi)--        builds program args = do-            tempDir <- getTemporaryDirectory-            withTempFile tempDir ".c" $ \cName cHnd ->-              withTempFile tempDir "" $ \oNname oHnd -> do-                hPutStrLn cHnd program-                hClose cHnd-                hClose oHnd-                _ <- rawSystemProgramStdoutConf verbosity-                  gccProgram (withPrograms lbi) (cName:"-o":oNname:args)-                return True-           `catchIO`   (\_ -> return False)-           `catchExit` (\_ -> return False)--        explainErrors Nothing [] = return () -- should be impossible!-        explainErrors _ _-           | isNothing . lookupProgram gccProgram . withPrograms $ lbi--                              = die $ unlines $-              [ "No working gcc",-                  "This package depends on foreign library but we cannot "-               ++ "find a working C compiler. If you have it in a "-               ++ "non-standard location you can use the --with-gcc "-               ++ "flag to specify it." ]--        explainErrors hdr libs = die $ unlines $-             [ if plural-                 then "Missing dependencies on foreign libraries:"-                 else "Missing dependency on a foreign library:"-             | missing ]-          ++ case hdr of-               Just (Left h) -> ["* Missing (or bad) header file: " ++ h ]-               _             -> []-          ++ case libs of-               []    -> []-               [lib] -> ["* Missing C library: " ++ lib]-               _     -> ["* Missing C libraries: " ++ intercalate ", " libs]-          ++ [if plural then messagePlural else messageSingular | missing]-          ++ case hdr of-               Just (Left  _) -> [ headerCppMessage ]-               Just (Right h) -> [ (if missing then "* " else "")-                                   ++ "Bad header file: " ++ h-                                 , headerCcMessage ]-               _              -> []--          where-            plural  = length libs >= 2-            -- Is there something missing? (as opposed to broken)-            missing = not (null libs)-                   || case hdr of Just (Left _) -> True; _ -> False--        messageSingular =-             "This problem can usually be solved by installing the system "-          ++ "package that provides this library (you may need the "-          ++ "\"-dev\" version). If the library is already installed "-          ++ "but in a non-standard location then you can use the flags "-          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-          ++ "where it is."-        messagePlural =-             "This problem can usually be solved by installing the system "-          ++ "packages that provide these libraries (you may need the "-          ++ "\"-dev\" versions). If the libraries are already installed "-          ++ "but in a non-standard location then you can use the flags "-          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-          ++ "where they are."-        headerCppMessage =-             "If the header file does exist, it may contain errors that "-          ++ "are caught by the C compiler at the preprocessing stage. "-          ++ "In this case you can re-run configure with the verbosity "-          ++ "flag -v3 to see the error messages."-        headerCcMessage =-             "The header file contains a compile error. "-          ++ "You can re-run configure with the verbosity flag "-          ++ "-v3 to see the error messages from the C compiler."---- | Output package check warnings and errors. Exit if any errors.-checkPackageProblems :: Verbosity-                     -> GenericPackageDescription-                     -> PackageDescription-                     -> IO ()-checkPackageProblems verbosity gpkg pkg = do-  ioChecks      <- checkPackageFiles pkg "."-  let pureChecks = checkPackage gpkg (Just pkg)-      errors   = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]-      warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]-  if null errors-    then mapM_ (warn verbosity) warnings-    else die (intercalate "\n\n" errors)---- | Preform checks if a relocatable build is allowed-checkRelocatable :: Verbosity-                 -> PackageDescription-                 -> LocalBuildInfo-                 -> IO ()-checkRelocatable verbosity pkg lbi-    = sequence_ [ checkOS-                , checkCompiler-                , packagePrefixRelative-                , depsPrefixRelative-                ]-  where-    -- Check if the OS support relocatable builds.-    ---    -- If you add new OS' to this list, and your OS supports dynamic libraries-    -- and RPATH, make sure you add your OS to RPATH-support list of:-    -- Distribution.Simple.GHC.getRPaths-    checkOS-        = unless (os `elem` [ OSX, Linux ])-        $ die $ "Operating system: " ++ display os ++-                ", does not support relocatable builds"-      where-        (Platform _ os) = hostPlatform lbi--    -- Check if the Compiler support relocatable builds-    checkCompiler-        = unless (compilerFlavor comp `elem` [ GHC ])-        $ die $ "Compiler: " ++ show comp ++-                ", does not support relocatable builds"-      where-        comp = compiler lbi--    -- Check if all the install dirs are relative to same prefix-    packagePrefixRelative-        = unless (relativeInstallDirs installDirs)-        $ die $ "Installation directories are not prefix_relative:\n" ++-                show installDirs-      where-        -- NB: should be good enough to check this against the default-        -- component ID, but if we wanted to be strictly correct we'd-        -- check for each ComponentId.-        installDirs = absoluteInstallDirs pkg lbi NoCopyDest-        p           = prefix installDirs-        relativeInstallDirs (InstallDirs {..}) =-          all isJust-              (fmap (stripPrefix p)-                    [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir-                    , docdir, mandir, htmldir, haddockdir, sysconfdir] )--    -- Check if the library dirs of the dependencies that are in the package-    -- database to which the package is installed are relative to the-    -- prefix of the package-    depsPrefixRelative = do-        pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))-        mapM_ (doCheck pkgr) ipkgs-      where-        doCheck pkgr ipkg-          | maybe False (== pkgr) (Installed.pkgRoot ipkg)-          = mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))-                  (Installed.libraryDirs ipkg)-          | otherwise-          = return ()-        -- NB: should be good enough to check this against the default-        -- component ID, but if we wanted to be strictly correct we'd-        -- check for each ComponentId.-        installDirs   = absoluteInstallDirs pkg lbi NoCopyDest-        p             = prefix installDirs-        ipkgs         = PackageIndex.allPackages (installedPkgs lbi)-        msg l         = "Library directory of a dependency: " ++ show l ++-                        "\nis not relative to the installation prefix:\n" ++-                        show p+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonoLocalBinds #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Configure+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This deals with the /configure/ phase. It provides the 'configure' action+-- which is given the package description and configure flags. It then tries+-- to: configure the compiler; resolves any conditionals in the package+-- description; resolve the package dependencies; check if all the extensions+-- used by this package are supported by the compiler; check that all the build+-- tools are available (including version checks if appropriate); checks for+-- any required @pkg-config@ packages (updating the 'BuildInfo' with the+-- results)+--+-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes+-- it out to the @dist\/setup-config@ file. It also displays various details to+-- the user, the amount of information displayed depending on the verbosity+-- level.++module Distribution.Simple.Configure (configure,+                                      writePersistBuildConfig,+                                      getConfigStateFile,+                                      getPersistBuildConfig,+                                      checkPersistBuildConfigOutdated,+                                      tryGetPersistBuildConfig,+                                      maybeGetPersistBuildConfig,+                                      findDistPref, findDistPrefOrDefault,+                                      getInternalPackages,+                                      computeComponentId,+                                      computeCompatPackageKey,+                                      computeCompatPackageName,+                                      localBuildInfoFile,+                                      getInstalledPackages,+                                      getInstalledPackagesMonitorFiles,+                                      getPackageDBContents,+                                      configCompiler, configCompilerAux,+                                      configCompilerEx, configCompilerAuxEx,+                                      computeEffectiveProfiling,+                                      ccLdOptionsBuildInfo,+                                      checkForeignDeps,+                                      interpretPackageDbFlags,+                                      ConfigStateFileError(..),+                                      tryGetConfigStateFile,+                                      platformDefines,+                                      relaxPackageDeps,+                                     )+    where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Compiler+import Distribution.Types.IncludeRenaming+import Distribution.Utils.NubList+import Distribution.Simple.Compiler hiding (Flag)+import Distribution.Simple.PreProcess+import Distribution.Package+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.Types.PackageDescription as PD+import Distribution.PackageDescription.PrettyPrint+import Distribution.PackageDescription.Configuration+import Distribution.PackageDescription.Check hiding (doesFileExist)+import Distribution.Simple.Program+import Distribution.Simple.Setup as Setup+import Distribution.Simple.BuildTarget+import Distribution.Simple.LocalBuildInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.ForeignLib+import Distribution.Types.ForeignLibType+import Distribution.Types.ForeignLibOption+import Distribution.Types.Mixin+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Version+import Distribution.Verbosity+import qualified Distribution.Compat.Graph as Graph+import Distribution.Compat.Stack+import Distribution.Backpack.Configure+import Distribution.Backpack.PreExistingComponent+import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour)+import Distribution.Backpack.Id+import Distribution.Utils.LogProgress++import qualified Distribution.Simple.GHC   as GHC+import qualified Distribution.Simple.GHCJS as GHCJS+import qualified Distribution.Simple.JHC   as JHC+import qualified Distribution.Simple.LHC   as LHC+import qualified Distribution.Simple.UHC   as UHC+import qualified Distribution.Simple.HaskellSuite as HaskellSuite++import Control.Exception+    ( ErrorCall, Exception, evaluate, throw, throwIO, try )+import Distribution.Utils.BinaryWithFingerprint+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Lazy.Char8 as BLC8+import Data.List+    ( (\\), partition, inits, stripPrefix )+import Data.Either+    ( partitionEithers )+import qualified Data.Map as Map+import System.Directory+    ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )+import System.FilePath+    ( (</>), isAbsolute )+import qualified System.Info+    ( compilerName, compilerVersion )+import System.IO+    ( hPutStrLn, hClose )+import Distribution.Text+    ( Text(disp), defaultStyle, display, simpleParse )+import Text.PrettyPrint+    ( Doc, (<+>), ($+$), char, comma, hsep, nest+    , punctuate, quotes, render, renderStyle, sep, text )+import Distribution.Compat.Environment ( lookupEnv )+import Distribution.Compat.Exception ( catchExit, catchIO )++type UseExternalInternalDeps = Bool++-- | The errors that can be thrown when reading the @setup-config@ file.+data ConfigStateFileError+    = ConfigStateFileNoHeader -- ^ No header found.+    | ConfigStateFileBadHeader -- ^ Incorrect header.+    | ConfigStateFileNoParse -- ^ Cannot parse file contents.+    | ConfigStateFileMissing -- ^ No file!+    | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier+      (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version.+  deriving (Typeable)++-- | Format a 'ConfigStateFileError' as a user-facing error message.+dispConfigStateFileError :: ConfigStateFileError -> Doc+dispConfigStateFileError ConfigStateFileNoHeader =+    text "Saved package config file header is missing."+    <+> text "Re-run the 'configure' command."+dispConfigStateFileError ConfigStateFileBadHeader =+    text "Saved package config file header is corrupt."+    <+> text "Re-run the 'configure' command."+dispConfigStateFileError ConfigStateFileNoParse =+    text "Saved package config file is corrupt."+    <+> text "Re-run the 'configure' command."+dispConfigStateFileError ConfigStateFileMissing =+    text "Run the 'configure' command first."+dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) =+    text "Saved package config file is outdated:"+    $+$ badCabal $+$ badCompiler+    $+$ text "Re-run the 'configure' command."+    where+      badCabal =+          text "• the Cabal version changed from"+          <+> disp oldCabal <+> "to" <+> disp currentCabalId+      badCompiler+        | oldCompiler == currentCompilerId = mempty+        | otherwise =+            text "• the compiler changed from"+            <+> disp oldCompiler <+> "to" <+> disp currentCompilerId++instance Show ConfigStateFileError where+    show = renderStyle defaultStyle . dispConfigStateFileError++instance Exception ConfigStateFileError++-- | Read the 'localBuildInfoFile'.  Throw an exception if the file is+-- missing, if the file cannot be read, or if the file was created by an older+-- version of Cabal.+getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.+                   -> IO LocalBuildInfo+getConfigStateFile filename = do+    exists <- doesFileExist filename+    unless exists $ throwIO ConfigStateFileMissing+    -- Read the config file into a strict ByteString to avoid problems with+    -- lazy I/O, then convert to lazy because the binary package needs that.+    contents <- BS.readFile filename+    let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])++    headerParseResult <- try $ evaluate $ parseHeader header+    let (cabalId, compId) =+            case headerParseResult of+              Left (_ :: ErrorCall) -> throw ConfigStateFileBadHeader+              Right x -> x++    let getStoredValue = do+          result <- decodeWithFingerprintOrFailIO (BLC8.tail body)+          case result of+            Left _ -> throw ConfigStateFileNoParse+            Right x -> return x+        deferErrorIfBadVersion act+          | cabalId /= currentCabalId = do+              eResult <- try act+              throw $ ConfigStateFileBadVersion cabalId compId eResult+          | otherwise = act+    deferErrorIfBadVersion getStoredValue+  where+    _ = callStack -- TODO: attach call stack to exception++-- | Read the 'localBuildInfoFile', returning either an error or the local build+-- info.+tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.+                      -> IO (Either ConfigStateFileError LocalBuildInfo)+tryGetConfigStateFile = try . getConfigStateFile++-- | Try to read the 'localBuildInfoFile'.+tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                         -> IO (Either ConfigStateFileError LocalBuildInfo)+tryGetPersistBuildConfig = try . getPersistBuildConfig++-- | Read the 'localBuildInfoFile'. Throw an exception if the file is+-- missing, if the file cannot be read, or if the file was created by an older+-- version of Cabal.+getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                      -> IO LocalBuildInfo+getPersistBuildConfig = getConfigStateFile . localBuildInfoFile++-- | Try to read the 'localBuildInfoFile'.+maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                           -> IO (Maybe LocalBuildInfo)+maybeGetPersistBuildConfig =+    liftM (either (const Nothing) Just) . tryGetPersistBuildConfig++-- | After running configure, output the 'LocalBuildInfo' to the+-- 'localBuildInfoFile'.+writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                        -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.+                        -> NoCallStackIO ()+writePersistBuildConfig distPref lbi = do+    createDirectoryIfMissing False distPref+    writeFileAtomic (localBuildInfoFile distPref) $+      BLC8.unlines [showHeader pkgId, encodeWithFingerprint lbi]+  where+    pkgId = localPackage lbi++-- | Identifier of the current Cabal package.+currentCabalId :: PackageIdentifier+currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion++-- | Identifier of the current compiler package.+currentCompilerId :: PackageIdentifier+currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName)+                                      (mkVersion' System.Info.compilerVersion)++-- | Parse the @setup-config@ file header, returning the package identifiers+-- for Cabal and the compiler.+parseHeader :: ByteString -- ^ The file contents.+            -> (PackageIdentifier, PackageIdentifier)+parseHeader header = case BLC8.words header of+  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId,+   "using", compId] ->+      fromMaybe (throw ConfigStateFileBadHeader) $ do+          _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier+          cabalId' <- simpleParse (BLC8.unpack cabalId)+          compId' <- simpleParse (BLC8.unpack compId)+          return (cabalId', compId')+  _ -> throw ConfigStateFileNoHeader++-- | Generate the @setup-config@ file header.+showHeader :: PackageIdentifier -- ^ The processed package.+            -> ByteString+showHeader pkgId = BLC8.unwords+    [ "Saved", "package", "config", "for"+    , BLC8.pack $ display pkgId+    , "written", "by"+    , BLC8.pack $ display currentCabalId+    , "using"+    , BLC8.pack $ display currentCompilerId+    ]++-- | Check that localBuildInfoFile is up-to-date with respect to the+-- .cabal file.+checkPersistBuildConfigOutdated :: FilePath -> FilePath -> NoCallStackIO Bool+checkPersistBuildConfigOutdated distPref pkg_descr_file = do+  pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)++-- | Get the path of @dist\/setup-config@.+localBuildInfoFile :: FilePath -- ^ The @dist@ directory path.+                    -> FilePath+localBuildInfoFile distPref = distPref </> "setup-config"++-- -----------------------------------------------------------------------------+-- * Configuration+-- -----------------------------------------------------------------------------++-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken+-- from (in order of highest to lowest preference) the override prefix, the+-- \"CABAL_BUILDDIR\" environment variable, or the default prefix.+findDistPref :: FilePath  -- ^ default \"dist\" prefix+             -> Setup.Flag FilePath  -- ^ override \"dist\" prefix+             -> NoCallStackIO FilePath+findDistPref defDistPref overrideDistPref = do+    envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")+    return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)+  where+    parseEnvDistPref env =+      case env of+        Just distPref | not (null distPref) -> toFlag distPref+        _ -> NoFlag++-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken+-- from (in order of highest to lowest preference) the override prefix, the+-- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call+-- this function to resolve a @*DistPref@ flag whenever it is not known to be+-- set. (The @*DistPref@ flags are always set to a definite value before+-- invoking 'UserHooks'.)+findDistPrefOrDefault :: Setup.Flag FilePath  -- ^ override \"dist\" prefix+                      -> NoCallStackIO FilePath+findDistPrefOrDefault = findDistPref defaultDistPref++-- |Perform the \"@.\/setup configure@\" action.+-- Returns the @.setup-config@ file.+configure :: (GenericPackageDescription, HookedBuildInfo)+          -> ConfigFlags -> IO LocalBuildInfo+configure (pkg_descr0', pbi) cfg = do+    let pkg_descr0 =+          -- Ignore '--allow-{older,newer}' when we're given+          -- '--exact-configuration'.+          if fromFlagOrDefault False (configExactConfiguration cfg)+          then pkg_descr0'+          else relaxPackageDeps removeLowerBound+               (maybe RelaxDepsNone unAllowOlder $ configAllowOlder cfg) $+               relaxPackageDeps removeUpperBound+               (maybe RelaxDepsNone unAllowNewer $ configAllowNewer cfg)+               pkg_descr0'++    -- Determine the component we are configuring, if a user specified+    -- one on the command line.  We use a fake, flattened version of+    -- the package since at this point, we're not really sure what+    -- components we *can* configure.  @Nothing@ means that we should+    -- configure everything (the old behavior).+    (mb_cname :: Maybe ComponentName) <- do+        let flat_pkg_descr = flattenPackageDescription pkg_descr0+        targets <- readBuildTargets flat_pkg_descr (configArgs cfg)+        -- TODO: bleat if you use the module/file syntax+        let targets' = [ cname | BuildTargetComponent cname <- targets ]+        case targets' of+            _ | null (configArgs cfg) -> return Nothing+            [cname] -> return (Just cname)+            [] -> die "No valid component targets found"+            _ -> die "Can only configure either single component or all of them"++    let use_external_internal_deps = isJust mb_cname+    case mb_cname of+        Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0)+        Just cname -> notice verbosity+            ("Configuring component " ++ display cname +++             " from " ++ display (packageId pkg_descr0))++    -- configCID is only valid for per-component configure+    when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $+        die "--cid is only supported for per-component configure"++    checkDeprecatedFlags verbosity cfg+    checkExactConfiguration pkg_descr0 cfg++    -- Where to build the package+    let buildDir :: FilePath -- e.g. dist/build+        -- fromFlag OK due to Distribution.Simple calling+        -- findDistPrefOrDefault to fill it in+        buildDir = fromFlag (configDistPref cfg) </> "build"+    createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir++    -- What package database(s) to use+    let packageDbs :: PackageDBStack+        packageDbs+         = interpretPackageDbFlags+            (fromFlag (configUserInstall cfg))+            (configPackageDBs cfg)++    -- comp:            the compiler we're building with+    -- compPlatform:    the platform we're building for+    -- programDb:  location and args of all programs we're+    --                  building with+    (comp         :: Compiler,+     compPlatform :: Platform,+     programDb    :: ProgramDb)+        <- configCompilerEx+            (flagToMaybe (configHcFlavor cfg))+            (flagToMaybe (configHcPath cfg))+            (flagToMaybe (configHcPkg cfg))+            (mkProgramDb cfg (configPrograms cfg))+            (lessVerbose verbosity)++    -- The InstalledPackageIndex of all installed packages+    installedPackageSet :: InstalledPackageIndex+        <- getInstalledPackages (lessVerbose verbosity) comp+                                  packageDbs programDb++    -- The set of package names which are "shadowed" by internal+    -- packages, and which component they map to+    let internalPackageSet :: Map PackageName ComponentName+        internalPackageSet = getInternalPackages pkg_descr0++    -- Make a data structure describing what components are enabled.+    let enabled :: ComponentRequestedSpec+        enabled = case mb_cname of+                    Just cname -> OneComponentRequestedSpec cname+                    Nothing -> ComponentRequestedSpec+                                -- The flag name (@--enable-tests@) is a+                                -- little bit of a misnomer, because+                                -- just passing this flag won't+                                -- "enable", in our internal+                                -- nomenclature; it's just a request; a+                                -- @buildable: False@ might make it+                                -- not possible to enable.+                                { testsRequested = fromFlag (configTests cfg)+                                , benchmarksRequested =+                                  fromFlag (configBenchmarks cfg) }+    -- Some sanity checks related to enabling components.+    when (isJust mb_cname+          && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $+        die $ "--enable-tests/--enable-benchmarks are incompatible with" +++              " explicitly specifying a component to configure."++    -- allConstraints:  The set of all 'Dependency's we have.  Used ONLY+    --                  to 'configureFinalizedPackage'.+    -- requiredDepsMap: A map from 'PackageName' to the specifically+    --                  required 'InstalledPackageInfo', due to --dependency+    --+    -- NB: These constraints are to be applied to ALL components of+    -- a package.  Thus, it's not an error if allConstraints contains+    -- more constraints than is necessary for a component (another+    -- component might need it.)+    --+    -- NB: The fact that we bundle all the constraints together means+    -- that is not possible to configure a test-suite to use one+    -- version of a dependency, and the executable to use another.+    (allConstraints  :: [Dependency],+     requiredDepsMap :: Map PackageName InstalledPackageInfo)+        <- either die return $+              combinedConstraints (configConstraints cfg)+                                  (configDependencies cfg)+                                  installedPackageSet++    -- pkg_descr:   The resolved package description, that does not contain any+    --              conditionals, because we have have an assignment for+    --              every flag, either picking them ourselves using a+    --              simple naive algorithm, or having them be passed to+    --              us by 'configConfigurationsFlags')+    -- flags:       The 'FlagAssignment' that the conditionals were+    --              resolved with.+    --+    -- NB: Why doesn't finalizing a package also tell us what the+    -- dependencies are (e.g. when we run the naive algorithm,+    -- we are checking if dependencies are satisfiable)?  The+    -- primary reason is that we may NOT have done any solving:+    -- if the flags are all chosen for us, this step is a simple+    -- matter of flattening according to that assignment.  It's+    -- cleaner to then configure the dependencies afterwards.+    (pkg_descr :: PackageDescription,+     flags     :: FlagAssignment)+        <- configureFinalizedPackage verbosity cfg enabled+                allConstraints+                (dependencySatisfiable+                    (fromFlagOrDefault False (configExactConfiguration cfg))+                    (packageVersion pkg_descr0)+                    installedPackageSet+                    internalPackageSet+                    requiredDepsMap)+                comp+                compPlatform+                pkg_descr0++    debug verbosity $ "Finalized package description:\n"+                  ++ showPackageDescription pkg_descr+    -- NB: showPackageDescription does not display the AWFUL HACK GLOBAL+    -- buildDepends, so we have to display it separately.  See #2066+    -- Some day, we should eliminate this, so that+    -- configureFinalizedPackage returns the set of overall dependencies+    -- separately.  Then 'configureDependencies' and+    -- 'Distribution.PackageDescription.Check' need to be adjusted+    -- accordingly.+    debug verbosity $ "Finalized build-depends: "+                  ++ intercalate ", " (map display (buildDepends pkg_descr))++    checkCompilerProblems comp pkg_descr enabled+    checkPackageProblems verbosity pkg_descr0+        (updatePackageDescription pbi pkg_descr)++    -- The list of 'InstalledPackageInfo' recording the selected+    -- dependencies on external packages.+    --+    -- Invariant: For any package name, there is at most one package+    -- in externalPackageDeps which has that name.+    --+    -- NB: The dependency selection is global over ALL components+    -- in the package (similar to how allConstraints and+    -- requiredDepsMap are global over all components).  In particular,+    -- if *any* component (post-flag resolution) has an unsatisfiable+    -- dependency, we will fail.  This can sometimes be undesirable+    -- for users, see #1786 (benchmark conflicts with executable),+    --+    -- In the presence of Backpack, these package dependencies are+    -- NOT complete: they only ever include the INDEFINITE+    -- dependencies.  After we apply an instantiation, we'll get+    -- definite references which constitute extra dependencies.+    -- (Why not have cabal-install pass these in explicitly?+    -- For one it's deterministic; for two, we need to associate+    -- them with renamings which would require a far more complicated+    -- input scheme than what we have today.)+    externalPkgDeps :: [(PackageName, InstalledPackageInfo)]+        <- configureDependencies+                verbosity+                use_external_internal_deps+                internalPackageSet+                installedPackageSet+                requiredDepsMap+                pkg_descr++    -- Compute installation directory templates, based on user+    -- configuration.+    --+    -- TODO: Move this into a helper function.+    defaultDirs :: InstallDirTemplates+        <- defaultInstallDirs' use_external_internal_deps+                              (compilerFlavor comp)+                              (fromFlag (configUserInstall cfg))+                              (hasLibs pkg_descr)+    let installDirs :: InstallDirTemplates+        installDirs = combineInstallDirs fromFlagOrDefault+                        defaultDirs (configInstallDirs cfg)++    -- Check languages and extensions+    -- TODO: Move this into a helper function.+    let langlist = nub $ catMaybes $ map defaultLanguage+                   (enabledBuildInfos pkg_descr enabled)+    let langs = unsupportedLanguages comp langlist+    when (not (null langs)) $+      die $ "The package " ++ display (packageId pkg_descr0)+         ++ " requires the following languages which are not "+         ++ "supported by " ++ display (compilerId comp) ++ ": "+         ++ intercalate ", " (map display langs)+    let extlist = nub $ concatMap allExtensions (enabledBuildInfos pkg_descr enabled)+    let exts = unsupportedExtensions comp extlist+    when (not (null exts)) $+      die $ "The package " ++ display (packageId pkg_descr0)+         ++ " requires the following language extensions which are not "+         ++ "supported by " ++ display (compilerId comp) ++ ": "+         ++ intercalate ", " (map display exts)++    -- Check foreign library build requirements+    let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled]+    let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs+    when (not (null unsupportedFLibs)) $+      die $ "Cannot build some foreign libraries: "+         ++ intercalate "," unsupportedFLibs++    -- Configure known/required programs & external build tools.+    -- Exclude build-tool deps on "internal" exes in the same package+    --+    -- TODO: Factor this into a helper package.+    let requiredBuildTools =+          [ buildTool+          | let exeNames = map (unUnqualComponentName . exeName) (executables pkg_descr)+          , bi <- enabledBuildInfos pkg_descr enabled+          , buildTool@(LegacyExeDependency toolPName reqVer)+            <- buildTools bi+          , let isInternal =+                    toolPName `elem` exeNames+                    -- we assume all internal build-tools are+                    -- versioned with the package:+                 && packageVersion pkg_descr `withinRange` reqVer+          , not isInternal ]++    programDb' <-+          configureAllKnownPrograms (lessVerbose verbosity) programDb+      >>= configureRequiredPrograms verbosity requiredBuildTools++    (pkg_descr', programDb'') <-+      configurePkgconfigPackages verbosity pkg_descr programDb' enabled++    -- Compute internal component graph+    --+    -- The general idea is that we take a look at all the source level+    -- components (which may build-depends on each other) and form a graph.+    -- From there, we build a ComponentLocalBuildInfo for each of the+    -- components, which lets us actually build each component.+    -- internalPackageSet+    -- use_external_internal_deps+    (buildComponents :: [ComponentLocalBuildInfo],+     packageDependsIndex :: InstalledPackageIndex) <-+      let prePkgDeps = map ipiToPreExistingComponent externalPkgDeps+      in runLogProgress verbosity $ configureComponentLocalBuildInfos+            verbosity+            use_external_internal_deps+            enabled+            (configIPID cfg)+            (configCID cfg)+            pkg_descr+            prePkgDeps+            (configConfigurationsFlags cfg)+            (configInstantiateWith cfg)+            installedPackageSet+            comp++    -- Decide if we're going to compile with split objects.+    split_objs :: Bool <-+       if not (fromFlag $ configSplitObjs cfg)+            then return False+            else case compilerFlavor comp of+                        GHC | compilerVersion comp >= mkVersion [6,5]+                          -> return True+                        GHCJS+                          -> return True+                        _ -> do warn verbosity+                                     ("this compiler does not support " +++                                      "--enable-split-objs; ignoring")+                                return False++    let ghciLibByDefault =+          case compilerId comp of+            CompilerId GHC _ ->+              -- If ghc is non-dynamic, then ghci needs object files,+              -- so we build one by default.+              --+              -- Technically, archive files should be sufficient for ghci,+              -- but because of GHC bug #8942, it has never been safe to+              -- rely on them. By the time that bug was fixed, ghci had+              -- been changed to read shared libraries instead of archive+              -- files (see next code block).+              not (GHC.isDynamic comp)+            CompilerId GHCJS _ ->+              not (GHCJS.isDynamic comp)+            _ -> False++    let sharedLibsByDefault+          | fromFlag (configDynExe cfg) =+              -- build a shared library if dynamically-linked+              -- executables are requested+              True+          | otherwise = case compilerId comp of+            CompilerId GHC _ ->+              -- if ghc is dynamic, then ghci needs a shared+              -- library, so we build one by default.+              GHC.isDynamic comp+            CompilerId GHCJS _ ->+              GHCJS.isDynamic comp+            _ -> False+        withSharedLib_ =+            -- build shared libraries if required by GHC or by the+            -- executable linking mode, but allow the user to force+            -- building only static library archives with+            -- --disable-shared.+            fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg+        withDynExe_ = fromFlag $ configDynExe cfg+    when (withDynExe_ && not withSharedLib_) $ warn verbosity $+           "Executables will use dynamic linking, but a shared library "+        ++ "is not being built. Linking will fail if any executables "+        ++ "depend on the library."++    setProfLBI <- configureProfiling verbosity cfg comp++    setCoverageLBI <- configureCoverage verbosity cfg comp++    reloc <-+       if not (fromFlag $ configRelocatable cfg)+            then return False+            else return True++    let buildComponentsMap =+            foldl' (\m clbi -> Map.insertWith (++)+                               (componentLocalName clbi) [clbi] m)+                   Map.empty buildComponents++    let lbi = (setCoverageLBI . setProfLBI)+              LocalBuildInfo {+                configFlags         = cfg,+                flagAssignment      = flags,+                componentEnabledSpec = enabled,+                extraConfigArgs     = [],  -- Currently configure does not+                                           -- take extra args, but if it+                                           -- did they would go here.+                installDirTemplates = installDirs,+                compiler            = comp,+                hostPlatform        = compPlatform,+                buildDir            = buildDir,+                componentGraph      = Graph.fromList buildComponents,+                componentNameMap    = buildComponentsMap,+                installedPkgs       = packageDependsIndex,+                pkgDescrFile        = Nothing,+                localPkgDescr       = pkg_descr',+                withPrograms        = programDb'',+                withVanillaLib      = fromFlag $ configVanillaLib cfg,+                withSharedLib       = withSharedLib_,+                withDynExe          = withDynExe_,+                withProfLib         = False,+                withProfLibDetail   = ProfDetailNone,+                withProfExe         = False,+                withProfExeDetail   = ProfDetailNone,+                withOptimization    = fromFlag $ configOptimization cfg,+                withDebugInfo       = fromFlag $ configDebugInfo cfg,+                withGHCiLib         = fromFlagOrDefault ghciLibByDefault $+                                      configGHCiLib cfg,+                splitObjs           = split_objs,+                stripExes           = fromFlag $ configStripExes cfg,+                stripLibs           = fromFlag $ configStripLibs cfg,+                exeCoverage         = False,+                libCoverage         = False,+                withPackageDB       = packageDbs,+                progPrefix          = fromFlag $ configProgPrefix cfg,+                progSuffix          = fromFlag $ configProgSuffix cfg,+                relocatable         = reloc+              }++    when reloc (checkRelocatable verbosity pkg_descr lbi)++    -- TODO: This is not entirely correct, because the dirs may vary+    -- across libraries/executables+    let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest+        relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi++    unless (isAbsolute (prefix dirs)) $ die $+        "expected an absolute directory name for --prefix: " ++ prefix dirs++    info verbosity $ "Using " ++ display currentCabalId+                  ++ " compiled by " ++ display currentCompilerId+    info verbosity $ "Using compiler: " ++ showCompilerId comp+    info verbosity $ "Using install prefix: " ++ prefix dirs++    let dirinfo name dir isPrefixRelative =+          info verbosity $ name ++ " installed in: " ++ dir ++ relNote+          where relNote = case buildOS of+                  Windows | not (hasLibs pkg_descr)+                         && isNothing isPrefixRelative+                         -> "  (fixed location)"+                  _      -> ""++    dirinfo "Binaries"         (bindir dirs)     (bindir relative)+    dirinfo "Libraries"        (libdir dirs)     (libdir relative)+    dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative)+    dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)+    dirinfo "Data files"       (datadir dirs)    (datadir relative)+    dirinfo "Documentation"    (docdir dirs)     (docdir relative)+    dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)++    sequence_ [ reportProgram verbosity prog configuredProg+              | (prog, configuredProg) <- knownPrograms programDb'' ]++    return lbi++    where+      verbosity = fromFlag (configVerbosity cfg)++mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb+mkProgramDb cfg initialProgramDb = programDb+  where+    programDb  = userSpecifyArgss (configProgramArgs cfg)+                 . userSpecifyPaths (configProgramPaths cfg)+                 . setProgramSearchPath searchpath+                 $ initialProgramDb+    searchpath = getProgramSearchPath (initialProgramDb)+                 ++ map ProgramSearchPathDir+                 (fromNubList $ configProgramPathExtra cfg)++-- -----------------------------------------------------------------------------+-- Helper functions for configure++-- | Check if the user used any deprecated flags.+checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO ()+checkDeprecatedFlags verbosity cfg = do+    unless (configProfExe cfg == NoFlag) $ do+      let enable | fromFlag (configProfExe cfg) = "enable"+                 | otherwise = "disable"+      warn verbosity+        ("The flag --" ++ enable ++ "-executable-profiling is deprecated. "+         ++ "Please use --" ++ enable ++ "-profiling instead.")++    unless (configLibCoverage cfg == NoFlag) $ do+      let enable | fromFlag (configLibCoverage cfg) = "enable"+                 | otherwise = "disable"+      warn verbosity+        ("The flag --" ++ enable ++ "-library-coverage is deprecated. "+         ++ "Please use --" ++ enable ++ "-coverage instead.")++-- | Sanity check: if '--exact-configuration' was given, ensure that the+-- complete flag assignment was specified on the command line.+checkExactConfiguration :: GenericPackageDescription -> ConfigFlags -> IO ()+checkExactConfiguration pkg_descr0 cfg = do+    when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do+      let cmdlineFlags = map fst (configConfigurationsFlags cfg)+          allFlags     = map flagName . genPackageFlags $ pkg_descr0+          diffFlags    = allFlags \\ cmdlineFlags+      when (not . null $ diffFlags) $+        die $ "'--exact-configuration' was given, "+        ++ "but the following flags were not specified: "+        ++ intercalate ", " (map show diffFlags)++-- | Create a PackageIndex that makes *any libraries that might be*+-- defined internally to this package look like installed packages, in+-- case an executable should refer to any of them as dependencies.+--+-- It must be *any libraries that might be* defined rather than the+-- actual definitions, because these depend on conditionals in the .cabal+-- file, and we haven't resolved them yet.  finalizePD+-- does the resolution of conditionals, and it takes internalPackageSet+-- as part of its input.+getInternalPackages :: GenericPackageDescription+                    -> Map PackageName ComponentName+getInternalPackages pkg_descr0 =+    -- TODO: some day, executables will be fair game here too!+    let pkg_descr = flattenPackageDescription pkg_descr0+        f lib = case libName lib of+                    Nothing -> (packageName pkg_descr, CLibName)+                    Just n' -> (unqualComponentNameToPackageName n', CSubLibName n')+    in Map.fromList (map f (allLibraries pkg_descr))++-- | Returns true if a dependency is satisfiable.  This function+-- may report a dependency satisfiable even when it is not,+-- but not vice versa. This is to be passed+-- to finalizePD.+dependencySatisfiable+    :: Bool+    -> Version+    -> InstalledPackageIndex -- ^ installed set+    -> Map PackageName ComponentName -- ^ internal set+    -> Map PackageName InstalledPackageInfo -- ^ required dependencies+    -> (Dependency -> Bool)+dependencySatisfiable+    exact_config _ installedPackageSet internalPackageSet requiredDepsMap+    d@(Dependency depName _)+      | exact_config =+        -- When we're given '--exact-configuration', we assume that all+        -- dependencies and flags are exactly specified on the command+        -- line. Thus we only consult the 'requiredDepsMap'. Note that+        -- we're not doing the version range check, so if there's some+        -- dependency that wasn't specified on the command line,+        -- 'finalizePD' will fail.+        --+        -- TODO: mention '--exact-configuration' in the error message+        -- when this fails?+        --+        -- (However, note that internal deps don't have to be+        -- specified!)+        --+        -- NB: Just like the case below, we might incorrectly+        -- determine an external internal dep is satisfiable+        -- when it actually isn't.+        (depName `Map.member` requiredDepsMap) || isInternalDep++      | isInternalDep =+        -- If a 'PackageName' is defined by an internal component, the+        -- dep is satisfiable (and we are going to use the internal+        -- dependency.)  Note that this doesn't mean we are actually+        -- going to SUCCEED when we configure the package, if+        -- UseExternalInternalDeps is True.+        True++      | otherwise =+        -- Normal operation: just look up dependency in the+        -- package index.+        not . null . PackageIndex.lookupDependency installedPackageSet $ d+      where+        isInternalDep = Map.member depName internalPackageSet++-- | Relax the dependencies of this package if needed.+relaxPackageDeps :: (VersionRange -> VersionRange)+                 -> RelaxDeps+                 -> GenericPackageDescription -> GenericPackageDescription+relaxPackageDeps _ RelaxDepsNone gpd = gpd+relaxPackageDeps vrtrans RelaxDepsAll  gpd = transformAllBuildDepends relaxAll gpd+  where+    relaxAll = \(Dependency pkgName verRange) ->+      Dependency pkgName (vrtrans verRange)+relaxPackageDeps vrtrans (RelaxDepsSome allowNewerDeps') gpd =+  transformAllBuildDepends relaxSome gpd+  where+    thisPkgName    = packageName gpd+    allowNewerDeps = mapMaybe f allowNewerDeps'++    f (Setup.RelaxedDep p) = Just p+    f (Setup.RelaxedDepScoped scope p) | scope == thisPkgName = Just p+                                       | otherwise            = Nothing++    relaxSome = \d@(Dependency depName verRange) ->+      if depName `elem` allowNewerDeps+      then Dependency depName (vrtrans verRange)+      else d++-- | Finalize a generic package description.  The workhorse is+-- 'finalizePD' but there's a bit of other nattering+-- about necessary.+--+-- TODO: what exactly is the business with @flaggedTests@ and+-- @flaggedBenchmarks@?+configureFinalizedPackage+    :: Verbosity+    -> ConfigFlags+    -> ComponentRequestedSpec+    -> [Dependency]+    -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable.+                            -- Might say it's satisfiable even when not.+    -> Compiler+    -> Platform+    -> GenericPackageDescription+    -> IO (PackageDescription, FlagAssignment)+configureFinalizedPackage verbosity cfg enabled+  allConstraints satisfies comp compPlatform pkg_descr0 = do++    (pkg_descr0', flags) <-+            case finalizePD+                   (configConfigurationsFlags cfg)+                   enabled+                   satisfies+                   compPlatform+                   (compilerInfo comp)+                   allConstraints+                   pkg_descr0+            of Right r -> return r+               Left missing ->+                   die $ "Encountered missing dependencies:\n"+                     ++ (render . nest 4 . sep . punctuate comma+                                . map (disp . simplifyDependency)+                                $ missing)++    -- add extra include/lib dirs as specified in cfg+    -- we do it here so that those get checked too+    let pkg_descr = addExtraIncludeLibDirs pkg_descr0'++    when (not (null flags)) $+      info verbosity $ "Flags chosen: "+                    ++ intercalate ", " [ unFlagName fn ++ "=" ++ display value+                                        | (fn, value) <- flags ]++    return (pkg_descr, flags)+  where+    addExtraIncludeLibDirs pkg_descr =+        let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg+                             , extraFrameworkDirs = configExtraFrameworkDirs cfg+                             , PD.includeDirs = configExtraIncludeDirs cfg}+            modifyLib l        = l{ libBuildInfo = libBuildInfo l+                                                   `mappend` extraBi }+            modifyExecutable e = e{ buildInfo    = buildInfo e+                                                   `mappend` extraBi}+        in pkg_descr{ library = modifyLib `fmap` library pkg_descr+                    , subLibraries = modifyLib `map` subLibraries pkg_descr+                    , executables = modifyExecutable  `map`+                                      executables pkg_descr}++-- | Check for use of Cabal features which require compiler support+checkCompilerProblems :: Compiler -> PackageDescription -> ComponentRequestedSpec -> IO ()+checkCompilerProblems comp pkg_descr enabled = do+    unless (renamingPackageFlagsSupported comp ||+                all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins)+                         (enabledBuildInfos pkg_descr enabled)) $+        die $ "Your compiler does not support thinning and renaming on "+           ++ "package flags.  To use this feature you must use "+           ++ "GHC 7.9 or later."++    when (any (not.null.PD.reexportedModules) (PD.allLibraries pkg_descr)+          && not (reexportedModulesSupported comp)) $ do+        die $ "Your compiler does not support module re-exports. To use "+           ++ "this feature you must use GHC 7.9 or later."++    when (any (not.null.PD.signatures) (PD.allLibraries pkg_descr)+          && not (backpackSupported comp)) $ do+        die $ "Your compiler does not support Backpack. To use "+           ++ "this feature you must use GHC 8.1 or later."++-- | Select dependencies for the package.+configureDependencies+    :: Verbosity+    -> UseExternalInternalDeps+    -> Map PackageName ComponentName -- ^ internal packages+    -> InstalledPackageIndex -- ^ installed packages+    -> Map PackageName InstalledPackageInfo -- ^ required deps+    -> PackageDescription+    -> IO [(PackageName, InstalledPackageInfo)]+configureDependencies verbosity use_external_internal_deps+  internalPackageSet installedPackageSet requiredDepsMap pkg_descr = do+    let selectDependencies :: [Dependency] ->+                              ([FailedDependency], [ResolvedDependency])+        selectDependencies =+            partitionEithers+          . map (selectDependency (package pkg_descr)+                                  internalPackageSet installedPackageSet+                                  requiredDepsMap use_external_internal_deps)++        (failedDeps, allPkgDeps) =+          selectDependencies (buildDepends pkg_descr)++        internalPkgDeps = [ pkgid+                          | InternalDependency _ pkgid <- allPkgDeps ]+        -- NB: we have to SAVE the package name, because this is the only+        -- way we can be able to resolve package names in the package+        -- description.+        externalPkgDeps = [ (pn, pkg)+                          | ExternalDependency (Dependency pn _) pkg   <- allPkgDeps ]++    when (not (null internalPkgDeps)+          && not (newPackageDepsBehaviour pkg_descr)) $+        die $ "The field 'build-depends: "+           ++ intercalate ", " (map (display . packageName) internalPkgDeps)+           ++ "' refers to a library which is defined within the same "+           ++ "package. To use this feature the package must specify at "+           ++ "least 'cabal-version: >= 1.8'."++    reportFailedDependencies failedDeps+    reportSelectedDependencies verbosity allPkgDeps++    return externalPkgDeps++-- | Select and apply coverage settings for the build based on the+-- 'ConfigFlags' and 'Compiler'.+configureCoverage :: Verbosity -> ConfigFlags -> Compiler+                  -> IO (LocalBuildInfo -> LocalBuildInfo)+configureCoverage verbosity cfg comp = do+    let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg)+        tryLibCoverage = fromFlagOrDefault tryExeCoverage+                         (mappend (configCoverage cfg) (configLibCoverage cfg))+    if coverageSupported comp+      then do+        let apply lbi = lbi { libCoverage = tryLibCoverage+                            , exeCoverage = tryExeCoverage+                            }+        return apply+      else do+        let apply lbi = lbi { libCoverage = False+                            , exeCoverage = False+                            }+        when (tryExeCoverage || tryLibCoverage) $ warn verbosity+          ("The compiler " ++ showCompilerId comp ++ " does not support "+           ++ "program coverage. Program coverage has been disabled.")+        return apply++-- | Compute the effective value of the profiling flags+-- @--enable-library-profiling@ and @--enable-executable-profiling@+-- from the specified 'ConfigFlags'.  This may be useful for+-- external Cabal tools which need to interact with Setup in+-- a backwards-compatible way: the most predictable mechanism+-- for enabling profiling across many legacy versions is to+-- NOT use @--enable-profiling@ and use those two flags instead.+--+-- Note that @--enable-executable-profiling@ also affects profiling+-- of benchmarks and (non-detailed) test suites.+computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib -}, Bool {- exe -})+computeEffectiveProfiling cfg =+  -- The --profiling flag sets the default for both libs and exes,+  -- but can be overidden by --library-profiling, or the old deprecated+  -- --executable-profiling flag.+  --+  -- The --profiling-detail and --library-profiling-detail flags behave+  -- similarly+  let tryExeProfiling = fromFlagOrDefault False+                        (mappend (configProf cfg) (configProfExe cfg))+      tryLibProfiling = fromFlagOrDefault tryExeProfiling+                        (mappend (configProf cfg) (configProfLib cfg))+  in (tryLibProfiling, tryExeProfiling)++-- | Select and apply profiling settings for the build based on the+-- 'ConfigFlags' and 'Compiler'.+configureProfiling :: Verbosity -> ConfigFlags -> Compiler+                   -> IO (LocalBuildInfo -> LocalBuildInfo)+configureProfiling verbosity cfg comp = do+  let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling cfg++      tryExeProfileLevel = fromFlagOrDefault ProfDetailDefault+                           (configProfDetail cfg)+      tryLibProfileLevel = fromFlagOrDefault ProfDetailDefault+                           (mappend+                            (configProfDetail cfg)+                            (configProfLibDetail cfg))++      checkProfileLevel (ProfDetailOther other) = do+        warn verbosity+          ("Unknown profiling detail level '" ++ other+           ++ "', using default.\nThe profiling detail levels are: "+           ++ intercalate ", "+           [ name | (name, _, _) <- knownProfDetailLevels ])+        return ProfDetailDefault+      checkProfileLevel other = return other++  (exeProfWithoutLibProf, applyProfiling) <-+    if profilingSupported comp+    then do+      exeLevel <- checkProfileLevel tryExeProfileLevel+      libLevel <- checkProfileLevel tryLibProfileLevel+      let apply lbi = lbi { withProfLib       = tryLibProfiling+                          , withProfLibDetail = libLevel+                          , withProfExe       = tryExeProfiling+                          , withProfExeDetail = exeLevel+                          }+      return (tryExeProfiling && not tryLibProfiling, apply)+    else do+      let apply lbi = lbi { withProfLib = False+                          , withProfLibDetail = ProfDetailNone+                          , withProfExe = False+                          , withProfExeDetail = ProfDetailNone+                          }+      when (tryExeProfiling || tryLibProfiling) $ warn verbosity+        ("The compiler " ++ showCompilerId comp ++ " does not support "+         ++ "profiling. Profiling has been disabled.")+      return (False, apply)++  when exeProfWithoutLibProf $ warn verbosity+    ("Executables will be built with profiling, but library "+     ++ "profiling is disabled. Linking will fail if any executables "+     ++ "depend on the library.")++  return applyProfiling++-- -----------------------------------------------------------------------------+-- Configuring package dependencies++reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO ()+reportProgram verbosity prog Nothing+    = info verbosity $ "No " ++ programName prog ++ " found"+reportProgram verbosity prog (Just configuredProg)+    = info verbosity $ "Using " ++ programName prog ++ version ++ location+    where location = case programLocation configuredProg of+            FoundOnSystem p -> " found on system at: " ++ p+            UserSpecified p -> " given by user at: " ++ p+          version = case programVersion configuredProg of+            Nothing -> ""+            Just v  -> " version " ++ display v++hackageUrl :: String+hackageUrl = "http://hackage.haskell.org/package/"++data ResolvedDependency+    -- | An external dependency from the package database, OR an+    -- internal dependency which we are getting from the package+    -- database.+    = ExternalDependency Dependency InstalledPackageInfo+    -- | An internal dependency ('PackageId' should be a library name)+    -- which we are going to have to build.  (The+    -- 'PackageId' here is a hack to get a modest amount of+    -- polymorphism out of the 'Package' typeclass.)+    | InternalDependency Dependency PackageId++data FailedDependency = DependencyNotExists PackageName+                      | DependencyMissingInternal PackageName PackageName+                      | DependencyNoVersion Dependency++-- | Test for a package dependency and record the version we have installed.+selectDependency :: PackageId -- ^ Package id of current package+                 -> Map PackageName ComponentName+                 -> InstalledPackageIndex  -- ^ Installed packages+                 -> Map PackageName InstalledPackageInfo+                    -- ^ Packages for which we have been given specific deps to+                    -- use+                 -> UseExternalInternalDeps -- ^ Are we configuring a+                                            -- single component?+                 -> Dependency+                 -> Either FailedDependency ResolvedDependency+selectDependency pkgid internalIndex installedIndex requiredDepsMap+  use_external_internal_deps+  dep@(Dependency dep_pkgname vr) =+  -- If the dependency specification matches anything in the internal package+  -- index, then we prefer that match to anything in the second.+  -- For example:+  --+  -- Name: MyLibrary+  -- Version: 0.1+  -- Library+  --     ..+  -- Executable my-exec+  --     build-depends: MyLibrary+  --+  -- We want "build-depends: MyLibrary" always to match the internal library+  -- even if there is a newer installed library "MyLibrary-0.2".+  case Map.lookup dep_pkgname internalIndex of+    Just cname -> if use_external_internal_deps+                    then do_external (Just cname)+                    else do_internal+    _          -> do_external Nothing+  where+    do_internal = Right (InternalDependency dep+                    (PackageIdentifier dep_pkgname (packageVersion pkgid)))+    do_external is_internal = case Map.lookup dep_pkgname requiredDepsMap of+      -- If we know the exact pkg to use, then use it.+      Just pkginstance -> Right (ExternalDependency dep pkginstance)+      -- Otherwise we just pick an arbitrary instance of the latest version.+      Nothing -> case PackageIndex.lookupDependency installedIndex dep' of+        []   -> Left  $+                  case is_internal of+                    Just cname -> DependencyMissingInternal dep_pkgname+                                    (computeCompatPackageName (packageName pkgid) cname)+                    Nothing -> DependencyNotExists dep_pkgname+        pkgs -> Right $ ExternalDependency dep $+                case last pkgs of+                  (_ver, pkginstances) -> head pkginstances+     where+      dep' | Just cname <- is_internal+           = Dependency (computeCompatPackageName (packageName pkgid) cname) vr+           | otherwise = dep+    -- NB: here computeCompatPackageName we want to pick up the INDEFINITE ones+    -- which is why we pass 'Nothing' as 'UnitId'++reportSelectedDependencies :: Verbosity+                           -> [ResolvedDependency] -> IO ()+reportSelectedDependencies verbosity deps =+  info verbosity $ unlines+    [ "Dependency " ++ display (simplifyDependency dep)+                    ++ ": using " ++ display pkgid+    | resolved <- deps+    , let (dep, pkgid) = case resolved of+            ExternalDependency dep' pkg'   -> (dep', packageId pkg')+            InternalDependency dep' pkgid' -> (dep', pkgid') ]++reportFailedDependencies :: [FailedDependency] -> IO ()+reportFailedDependencies []     = return ()+reportFailedDependencies failed =+    die (intercalate "\n\n" (map reportFailedDependency failed))++  where+    reportFailedDependency (DependencyNotExists pkgname) =+         "there is no version of " ++ display pkgname ++ " installed.\n"+      ++ "Perhaps you need to download and install it from\n"+      ++ hackageUrl ++ display pkgname ++ "?"++    reportFailedDependency (DependencyMissingInternal pkgname real_pkgname) =+         "internal dependency " ++ display pkgname ++ " not installed.\n"+      ++ "Perhaps you need to configure and install it first?\n"+      ++ "(Munged package name we searched for was "+      ++ display real_pkgname ++ ")"++    reportFailedDependency (DependencyNoVersion dep) =+        "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n"++-- | List all installed packages in the given package databases.+getInstalledPackages :: Verbosity -> Compiler+                     -> PackageDBStack -- ^ The stack of package databases.+                     -> ProgramDb+                     -> IO InstalledPackageIndex+getInstalledPackages verbosity comp packageDBs progdb = do+  when (null packageDBs) $+    die $ "No package databases have been specified. If you use "+       ++ "--package-db=clear, you must follow it with --package-db= "+       ++ "with 'global', 'user' or a specific file."++  info verbosity "Reading installed packages..."+  case compilerFlavor comp of+    GHC   -> GHC.getInstalledPackages verbosity comp packageDBs progdb+    GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progdb+    JHC   -> JHC.getInstalledPackages verbosity packageDBs progdb+    LHC   -> LHC.getInstalledPackages verbosity packageDBs progdb+    UHC   -> UHC.getInstalledPackages verbosity comp packageDBs progdb+    HaskellSuite {} ->+      HaskellSuite.getInstalledPackages verbosity packageDBs progdb+    flv -> die $ "don't know how to find the installed packages for "+              ++ display flv++-- | Like 'getInstalledPackages', but for a single package DB.+--+-- NB: Why isn't this always a fall through to 'getInstalledPackages'?+-- That is because 'getInstalledPackages' performs some sanity checks+-- on the package database stack in question.  However, when sandboxes+-- are involved these sanity checks are not desirable.+getPackageDBContents :: Verbosity -> Compiler+                     -> PackageDB -> ProgramDb+                     -> IO InstalledPackageIndex+getPackageDBContents verbosity comp packageDB progdb = do+  info verbosity "Reading installed packages..."+  case compilerFlavor comp of+    GHC -> GHC.getPackageDBContents verbosity packageDB progdb+    GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb+    -- For other compilers, try to fall back on 'getInstalledPackages'.+    _   -> getInstalledPackages verbosity comp [packageDB] progdb+++-- | A set of files (or directories) that can be monitored to detect when+-- there might have been a change in the installed packages.+--+getInstalledPackagesMonitorFiles :: Verbosity -> Compiler+                                 -> PackageDBStack+                                 -> ProgramDb -> Platform+                                 -> IO [FilePath]+getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform =+  case compilerFlavor comp of+    GHC   -> GHC.getInstalledPackagesMonitorFiles+               verbosity platform progdb packageDBs+    other -> do+      warn verbosity $ "don't know how to find change monitoring files for "+                    ++ "the installed package databases for " ++ display other+      return []++-- | The user interface specifies the package dbs to use with a combination of+-- @--global@, @--user@ and @--package-db=global|user|clear|$file@.+-- This function combines the global/user flag and interprets the package-db+-- flag into a single package db stack.+--+interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack+interpretPackageDbFlags userInstall specificDBs =+    extra initialStack specificDBs+  where+    initialStack | userInstall = [GlobalPackageDB, UserPackageDB]+                 | otherwise   = [GlobalPackageDB]++    extra dbs' []            = dbs'+    extra _    (Nothing:dbs) = extra []             dbs+    extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs++-- We are given both --constraint="foo < 2.0" style constraints and also+-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".+--+-- When finalising the package we have to take into account the specific+-- installed deps we've been given, and the finalise function expects+-- constraints, so we have to translate these deps into version constraints.+--+-- But after finalising we then have to make sure we pick the right specific+-- deps in the end. So we still need to remember which installed packages to+-- pick.+combinedConstraints :: [Dependency] ->+                       [(PackageName, ComponentId)] ->+                       InstalledPackageIndex ->+                       Either String ([Dependency],+                                      Map PackageName InstalledPackageInfo)+combinedConstraints constraints dependencies installedPackages = do++    when (not (null badComponentIds)) $+      Left $ render $ text "The following package dependencies were requested"+         $+$ nest 4 (dispDependencies badComponentIds)+         $+$ text "however the given installed package instance does not exist."++    --TODO: we don't check that all dependencies are used!++    return (allConstraints, idConstraintMap)++  where+    allConstraints :: [Dependency]+    allConstraints = constraints+                  ++ [ thisPackageVersion (packageId pkg)+                     | (_, _, Just pkg) <- dependenciesPkgInfo ]++    idConstraintMap :: Map PackageName InstalledPackageInfo+    idConstraintMap = Map.fromList+                        [ (packageName pkg, pkg)+                        | (_, _, Just pkg) <- dependenciesPkgInfo ]++    -- The dependencies along with the installed package info, if it exists+    dependenciesPkgInfo :: [(PackageName, ComponentId,+                             Maybe InstalledPackageInfo)]+    dependenciesPkgInfo =+      [ (pkgname, cid, mpkg)+      | (pkgname, cid) <- dependencies+      , let mpkg = PackageIndex.lookupComponentId+                     installedPackages cid+      ]++    -- If we looked up a package specified by an installed package id+    -- (i.e. someone has written a hash) and didn't find it then it's+    -- an error.+    badComponentIds =+      [ (pkgname, cid)+      | (pkgname, cid, Nothing) <- dependenciesPkgInfo ]++    dispDependencies deps =+      hsep [    text "--dependency="+             <<>> quotes (disp pkgname <<>> char '=' <<>> disp cid)+           | (pkgname, cid) <- deps ]++-- -----------------------------------------------------------------------------+-- Configuring program dependencies++configureRequiredPrograms :: Verbosity -> [LegacyExeDependency] -> ProgramDb+                             -> IO ProgramDb+configureRequiredPrograms verbosity deps progdb =+  foldM (configureRequiredProgram verbosity) progdb deps++-- | Configure a required program, ensuring that it exists in the PATH+-- (or where the user has specified the program must live) and making it+-- available for use via the 'ProgramDb' interface.  If the program is+-- known (exists in the input 'ProgramDb'), we will make sure that the+-- program matches the required version; otherwise we will accept+-- any version of the program and assume that it is a simpleProgram.+configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency+                            -> IO ProgramDb+configureRequiredProgram verbosity progdb+  (LegacyExeDependency progName verRange) =+  case lookupKnownProgram progName progdb of+    Nothing ->+      -- Try to configure it as a 'simpleProgram' automatically+      --+      -- There's a bit of a story behind this line.  In old versions+      -- of Cabal, there were only internal build-tools dependencies.  So the+      -- behavior in this case was:+      --+      --    - If a build-tool dependency was internal, don't do+      --      any checking.+      --+      --    - If it was external, call 'configureRequiredProgram' to+      --      "configure" the executable.  In particular, if+      --      the program was not "known" (present in 'ProgramDb'),+      --      then we would just error.  This was fine, because+      --      the only way a program could be executed from 'ProgramDb'+      --      is if some library code from Cabal actually called it,+      --      and the pre-existing Cabal code only calls known+      --      programs from 'defaultProgramDb', and so if it+      --      is calling something else, you have a Custom setup+      --      script, and in that case you are expected to register+      --      the program you want to call in the ProgramDb.+      --+      -- OK, so that was fine, until I (ezyang, in 2016) refactored+      -- Cabal to support per-component builds.  In this case, what+      -- was previously an internal build-tool dependency now became+      -- an external one, and now previously "internal" dependencies+      -- are now external.  But these are permitted to exist even+      -- when they are not previously configured (something that+      -- can only occur by a Custom script.)+      --+      -- So, I decided, "Fine, let's just accept these in any+      -- case."  Thus this line.  The alternative would have been to+      -- somehow detect when a build-tools dependency was "internal" (by+      -- looking at the unflattened package description) but this+      -- would also be incompatible with future work to support+      -- external executable dependencies: we definitely cannot+      -- assume they will be preinitialized in the 'ProgramDb'.+      configureProgram verbosity (simpleProgram progName) progdb+    Just prog+      -- requireProgramVersion always requires the program have a version+      -- but if the user says "build-depends: foo" ie no version constraint+      -- then we should not fail if we cannot discover the program version.+      | verRange == anyVersion -> do+          (_, progdb') <- requireProgram verbosity prog progdb+          return progdb'+      | otherwise -> do+          (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb+          return progdb'++-- -----------------------------------------------------------------------------+-- Configuring pkg-config package dependencies++configurePkgconfigPackages :: Verbosity -> PackageDescription+                           -> ProgramDb -> ComponentRequestedSpec+                           -> IO (PackageDescription, ProgramDb)+configurePkgconfigPackages verbosity pkg_descr progdb enabled+  | null allpkgs = return (pkg_descr, progdb)+  | otherwise    = do+    (_, _, progdb') <- requireProgramVersion+                       (lessVerbose verbosity) pkgConfigProgram+                       (orLaterVersion $ mkVersion [0,9,0]) progdb+    traverse_ requirePkg allpkgs+    mlib' <- traverse addPkgConfigBILib (library pkg_descr)+    libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr)+    exes' <- traverse addPkgConfigBIExe (executables pkg_descr)+    tests' <- traverse addPkgConfigBITest (testSuites pkg_descr)+    benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr)+    let pkg_descr' = pkg_descr { library = mlib',+                                 subLibraries = libs', executables = exes',+                                 testSuites = tests', benchmarks = benches' }+    return (pkg_descr', progdb')++  where+    allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled)+    pkgconfig = getDbProgramOutput (lessVerbose verbosity)+                  pkgConfigProgram progdb++    requirePkg dep@(PkgconfigDependency pkgn range) = do+      version <- pkgconfig ["--modversion", pkg]+                 `catchIO`   (\_ -> die notFound)+                 `catchExit` (\_ -> die notFound)+      case simpleParse version of+        Nothing -> die "parsing output of pkg-config --modversion failed"+        Just v | not (withinRange v range) -> die (badVersion v)+               | otherwise                 -> info verbosity (depSatisfied v)+      where+        notFound     = "The pkg-config package '" ++ pkg ++ "'"+                    ++ versionRequirement+                    ++ " is required but it could not be found."+        badVersion v = "The pkg-config package '" ++ pkg ++ "'"+                    ++ versionRequirement+                    ++ " is required but the version installed on the"+                    ++ " system is version " ++ display v+        depSatisfied v = "Dependency " ++ display dep+                      ++ ": using version " ++ display v++        versionRequirement+          | isAnyVersion range = ""+          | otherwise          = " version " ++ display range++        pkg = unPkgconfigName pkgn++    -- Adds pkgconfig dependencies to the build info for a component+    addPkgConfigBI compBI setCompBI comp = do+      bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))+      return $ setCompBI comp (compBI comp `mappend` bi)++    -- Adds pkgconfig dependencies to the build info for a library+    addPkgConfigBILib = addPkgConfigBI libBuildInfo $+                          \lib bi -> lib { libBuildInfo = bi }++    -- Adds pkgconfig dependencies to the build info for an executable+    addPkgConfigBIExe = addPkgConfigBI buildInfo $+                          \exe bi -> exe { buildInfo = bi }++    -- Adds pkgconfig dependencies to the build info for a test suite+    addPkgConfigBITest = addPkgConfigBI testBuildInfo $+                          \test bi -> test { testBuildInfo = bi }++    -- Adds pkgconfig dependencies to the build info for a benchmark+    addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $+                          \bench bi -> bench { benchmarkBuildInfo = bi }++    pkgconfigBuildInfo :: [PkgconfigDependency] -> NoCallStackIO BuildInfo+    pkgconfigBuildInfo []      = return mempty+    pkgconfigBuildInfo pkgdeps = do+      let pkgs = nub [ display pkg | PkgconfigDependency pkg _ <- pkgdeps ]+      ccflags <- pkgconfig ("--cflags" : pkgs)+      ldflags <- pkgconfig ("--libs"   : pkgs)+      return (ccLdOptionsBuildInfo (words ccflags) (words ldflags))++-- | Makes a 'BuildInfo' from C compiler and linker flags.+--+-- This can be used with the output from configuration programs like pkg-config+-- and similar package-specific programs like mysql-config, freealut-config etc.+-- For example:+--+-- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"]+-- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"]+-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags))+--+ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo+ccLdOptionsBuildInfo cflags ldflags =+  let (includeDirs',  cflags')   = partition ("-I" `isPrefixOf`) cflags+      (extraLibs',    ldflags')  = partition ("-l" `isPrefixOf`) ldflags+      (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'+  in mempty {+       PD.includeDirs  = map (drop 2) includeDirs',+       PD.extraLibs    = map (drop 2) extraLibs',+       PD.extraLibDirs = map (drop 2) extraLibDirs',+       PD.ccOptions    = cflags',+       PD.ldOptions    = ldflags''+     }++-- -----------------------------------------------------------------------------+-- Determining the compiler details++configCompilerAuxEx :: ConfigFlags+                    -> IO (Compiler, Platform, ProgramDb)+configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)+                                           (flagToMaybe $ configHcPath cfg)+                                           (flagToMaybe $ configHcPkg cfg)+                                           programDb+                                           (fromFlag (configVerbosity cfg))+  where+    programDb = mkProgramDb cfg defaultProgramDb++configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath+                 -> ProgramDb -> Verbosity+                 -> IO (Compiler, Platform, ProgramDb)+configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"+configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do+  (comp, maybePlatform, programDb) <- case hcFlavor of+    GHC   -> GHC.configure  verbosity hcPath hcPkg progdb+    GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb+    JHC   -> JHC.configure  verbosity hcPath hcPkg progdb+    LHC   -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg progdb+                LHC.configure  verbosity hcPath Nothing ghcConf+    UHC   -> UHC.configure  verbosity hcPath hcPkg progdb+    HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb+    _    -> die "Unknown compiler"+  return (comp, fromMaybe buildPlatform maybePlatform, programDb)++-- Ideally we would like to not have separate configCompiler* and+-- configCompiler*Ex sets of functions, but there are many custom setup scripts+-- in the wild that are using them, so the versions with old types are kept for+-- backwards compatibility. Platform was added to the return triple in 1.18.++{-# DEPRECATED configCompiler+    "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-}+configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath+               -> ProgramDb -> Verbosity+               -> IO (Compiler, ProgramDb)+configCompiler mFlavor hcPath hcPkg progdb verbosity =+  fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg progdb verbosity++{-# DEPRECATED configCompilerAux+    "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}+configCompilerAux :: ConfigFlags+                  -> IO (Compiler, ProgramDb)+configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx++-- -----------------------------------------------------------------------------+-- Testing C lib and header dependencies++-- Try to build a test C program which includes every header and links every+-- lib. If that fails, try to narrow it down by preprocessing (only) and linking+-- with individual headers and libs.  If none is the obvious culprit then give a+-- generic error message.+-- TODO: produce a log file from the compiler errors, if any.+checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()+checkForeignDeps pkg lbi verbosity = do+  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling+                                                               -- lucky+           (return ())+           (do missingLibs <- findMissingLibs+               missingHdr  <- findOffendingHdr+               explainErrors missingHdr missingLibs)+      where+        allHeaders = collectField PD.includes+        allLibs    = collectField PD.extraLibs++        ifBuildsWith headers args success failure = do+            ok <- builds (makeProgram headers) args+            if ok then success else failure++        findOffendingHdr =+            ifBuildsWith allHeaders ccArgs+                         (return Nothing)+                         (go . tail . inits $ allHeaders)+            where+              go [] = return Nothing       -- cannot happen+              go (hdrs:hdrsInits) =+                    -- Try just preprocessing first+                    ifBuildsWith hdrs cppArgs+                      -- If that works, try compiling too+                      (ifBuildsWith hdrs ccArgs+                        (go hdrsInits)+                        (return . Just . Right . last $ hdrs))+                      (return . Just . Left . last $ hdrs)++              cppArgs = "-E":commonCppArgs -- preprocess only+              ccArgs  = "-c":commonCcArgs  -- don't try to link++        findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs)+                                       (return [])+                                       (filterM (fmap not . libExists) allLibs)++        libExists lib = builds (makeProgram []) (makeLdArgs [lib])++        commonCppArgs = platformDefines lbi+                     -- TODO: This is a massive hack, to work around the+                     -- fact that the test performed here should be+                     -- PER-component (c.f. the "I'm Feeling Lucky"; we+                     -- should NOT be glomming everything together.)+                     ++ [ "-I" ++ buildDir lbi </> "autogen" ]+                     ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]+                     ++ ["-I."]+                     ++ collectField PD.cppOptions+                     ++ collectField PD.ccOptions+                     ++ [ "-I" ++ dir+                        | dir <- ordNub [ dir+                                        | dep <- deps+                                        , dir <- Installed.includeDirs dep ]+                                 -- dedupe include dirs of dependencies+                                 -- to prevent quadratic blow-up+                        ]+                     ++ [ opt+                        | dep <- deps+                        , opt <- Installed.ccOptions dep ]++        commonCcArgs  = commonCppArgs+                     ++ collectField PD.ccOptions+                     ++ [ opt+                        | dep <- deps+                        , opt <- Installed.ccOptions dep ]++        commonLdArgs  = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ]+                     ++ collectField PD.ldOptions+                     ++ [ "-L" ++ dir+                        | dep <- deps+                        , dir <- Installed.libraryDirs dep ]+                     --TODO: do we also need dependent packages' ld options?+        makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs++        makeProgram hdrs = unlines $+                           [ "#include \""  ++ hdr ++ "\"" | hdr <- hdrs ] +++                           ["int main(int argc, char** argv) { return 0; }"]++        collectField f = concatMap f allBi+        allBi = enabledBuildInfos pkg (componentEnabledSpec lbi)+        deps = PackageIndex.topologicalOrder (installedPkgs lbi)++        builds program args = do+            tempDir <- getTemporaryDirectory+            withTempFile tempDir ".c" $ \cName cHnd ->+              withTempFile tempDir "" $ \oNname oHnd -> do+                hPutStrLn cHnd program+                hClose cHnd+                hClose oHnd+                _ <- getDbProgramOutput verbosity+                  gccProgram (withPrograms lbi) (cName:"-o":oNname:args)+                return True+           `catchIO`   (\_ -> return False)+           `catchExit` (\_ -> return False)++        explainErrors Nothing [] = return () -- should be impossible!+        explainErrors _ _+           | isNothing . lookupProgram gccProgram . withPrograms $ lbi++                              = die $ unlines $+              [ "No working gcc",+                  "This package depends on foreign library but we cannot "+               ++ "find a working C compiler. If you have it in a "+               ++ "non-standard location you can use the --with-gcc "+               ++ "flag to specify it." ]++        explainErrors hdr libs = die $ unlines $+             [ if plural+                 then "Missing dependencies on foreign libraries:"+                 else "Missing dependency on a foreign library:"+             | missing ]+          ++ case hdr of+               Just (Left h) -> ["* Missing (or bad) header file: " ++ h ]+               _             -> []+          ++ case libs of+               []    -> []+               [lib] -> ["* Missing C library: " ++ lib]+               _     -> ["* Missing C libraries: " ++ intercalate ", " libs]+          ++ [if plural then messagePlural else messageSingular | missing]+          ++ case hdr of+               Just (Left  _) -> [ headerCppMessage ]+               Just (Right h) -> [ (if missing then "* " else "")+                                   ++ "Bad header file: " ++ h+                                 , headerCcMessage ]+               _              -> []++          where+            plural  = length libs >= 2+            -- Is there something missing? (as opposed to broken)+            missing = not (null libs)+                   || case hdr of Just (Left _) -> True; _ -> False++        messageSingular =+             "This problem can usually be solved by installing the system "+          ++ "package that provides this library (you may need the "+          ++ "\"-dev\" version). If the library is already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where it is."+        messagePlural =+             "This problem can usually be solved by installing the system "+          ++ "packages that provide these libraries (you may need the "+          ++ "\"-dev\" versions). If the libraries are already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where they are."+        headerCppMessage =+             "If the header file does exist, it may contain errors that "+          ++ "are caught by the C compiler at the preprocessing stage. "+          ++ "In this case you can re-run configure with the verbosity "+          ++ "flag -v3 to see the error messages."+        headerCcMessage =+             "The header file contains a compile error. "+          ++ "You can re-run configure with the verbosity flag "+          ++ "-v3 to see the error messages from the C compiler."++-- | Output package check warnings and errors. Exit if any errors.+checkPackageProblems :: Verbosity+                     -> GenericPackageDescription+                     -> PackageDescription+                     -> IO ()+checkPackageProblems verbosity gpkg pkg = do+  ioChecks      <- checkPackageFiles pkg "."+  let pureChecks = checkPackage gpkg (Just pkg)+      errors   = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]+      warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]+  if null errors+    then traverse_ (warn verbosity) warnings+    else die (intercalate "\n\n" errors)++-- | Preform checks if a relocatable build is allowed+checkRelocatable :: Verbosity+                 -> PackageDescription+                 -> LocalBuildInfo+                 -> IO ()+checkRelocatable verbosity pkg lbi+    = sequence_ [ checkOS+                , checkCompiler+                , packagePrefixRelative+                , depsPrefixRelative+                ]+  where+    -- Check if the OS support relocatable builds.+    --+    -- If you add new OS' to this list, and your OS supports dynamic libraries+    -- and RPATH, make sure you add your OS to RPATH-support list of:+    -- Distribution.Simple.GHC.getRPaths+    checkOS+        = unless (os `elem` [ OSX, Linux ])+        $ die $ "Operating system: " ++ display os +++                ", does not support relocatable builds"+      where+        (Platform _ os) = hostPlatform lbi++    -- Check if the Compiler support relocatable builds+    checkCompiler+        = unless (compilerFlavor comp `elem` [ GHC ])+        $ die $ "Compiler: " ++ show comp +++                ", does not support relocatable builds"+      where+        comp = compiler lbi++    -- Check if all the install dirs are relative to same prefix+    packagePrefixRelative+        = unless (relativeInstallDirs installDirs)+        $ die $ "Installation directories are not prefix_relative:\n" +++                show installDirs+      where+        -- NB: should be good enough to check this against the default+        -- component ID, but if we wanted to be strictly correct we'd+        -- check for each ComponentId.+        installDirs = absoluteInstallDirs pkg lbi NoCopyDest+        p           = prefix installDirs+        relativeInstallDirs (InstallDirs {..}) =+          all isJust+              (fmap (stripPrefix p)+                    [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir+                    , docdir, mandir, htmldir, haddockdir, sysconfdir] )++    -- Check if the library dirs of the dependencies that are in the package+    -- database to which the package is installed are relative to the+    -- prefix of the package+    depsPrefixRelative = do+        pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))+        traverse_ (doCheck pkgr) ipkgs+      where+        doCheck pkgr ipkg+          | maybe False (== pkgr) (Installed.pkgRoot ipkg)+          = traverse_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))+                  (Installed.libraryDirs ipkg)+          | otherwise+          = return ()+        -- NB: should be good enough to check this against the default+        -- component ID, but if we wanted to be strictly correct we'd+        -- check for each ComponentId.+        installDirs   = absoluteInstallDirs pkg lbi NoCopyDest+        p             = prefix installDirs+        ipkgs         = PackageIndex.allPackages (installedPkgs lbi)+        msg l         = "Library directory of a dependency: " ++ show l +++                        "\nis not relative to the installation prefix:\n" +++                        show p++-- -----------------------------------------------------------------------------+-- Testing foreign library requirements++unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String]+unsupportedForeignLibs comp platform =+    mapMaybe (checkForeignLibSupported comp platform)++checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String+checkForeignLibSupported comp platform flib = go (compilerFlavor comp)+  where+    go :: CompilerFlavor -> Maybe String+    go GHC+      | compilerVersion comp < mkVersion [7,8] = unsupported [+        "Building foreign libraires is only supported with GHC >= 7.8"+      ]+      | otherwise = goGhcPlatform platform+    go _   = unsupported [+        "Building foreign libraries is currently only supported with ghc"+      ]++    goGhcPlatform :: Platform -> Maybe String+    goGhcPlatform (Platform X86_64 OSX    ) = goGhcOsx     (foreignLibType flib)+    goGhcPlatform (Platform I386   Linux  ) = goGhcLinux   (foreignLibType flib)+    goGhcPlatform (Platform X86_64 Linux  ) = goGhcLinux   (foreignLibType flib)+    goGhcPlatform (Platform I386   Windows) = goGhcWindows (foreignLibType flib)+    goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib)+    goGhcPlatform _ = unsupported [+        "Building foreign libraries is currently only supported on OSX, "+      , "Linux and Windows"+      ]++    goGhcOsx :: ForeignLibType -> Maybe String+    goGhcOsx ForeignLibNativeShared+      | standalone = unsupported [+            "We cannot build standalone libraries on OSX"+          ]+      | not (null (foreignLibModDefFile flib)) = unsupported [+            "Module definition file not supported on OSX"+          ]+      | otherwise =+          Nothing+    goGhcOsx _ = unsupported [+        "We can currently only build shared foreign libraries on OSX"+      ]++    goGhcLinux :: ForeignLibType -> Maybe String+    goGhcLinux ForeignLibNativeShared+      | standalone = unsupported [+            "We cannot build standalone libraries on OSX"+          ]+      | not (null (foreignLibModDefFile flib)) = unsupported [+            "Module definition file not supported on OSX"+          ]+      | otherwise =+          Nothing+    goGhcLinux _ = unsupported [+        "We can currently only build shared foreign libraries on Linux"+      ]++    goGhcWindows :: ForeignLibType -> Maybe String+    goGhcWindows ForeignLibNativeShared+      | not standalone = unsupported [+            "We can currently only build standalone libraries on Windows. Use\n"+          , "  if os(Windows)\n"+          , "    options: standalone\n"+          , "in your foreign-library stanza."+          ]+      | otherwise =+         Nothing+    goGhcWindows _ = unsupported [+        "We can currently only build shared foreign libraries on Windows"+      ]++    standalone :: Bool+    standalone = ForeignLibStandalone `elem` foreignLibOptions flib++    unsupported :: [String] -> Maybe String+    unsupported = Just . concat
cabal/Cabal/Distribution/Simple/GHC.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}  ----------------------------------------------------------------------------- -- |@@ -38,10 +39,10 @@         getInstalledPackages,         getInstalledPackagesMonitorFiles,         getPackageDBContents,-        buildLib, buildExe,-        replLib, replExe,+        buildLib, buildFLib, buildExe,+        replLib, replFLib, replExe,         startInterpreter,-        installLib, installExe,+        installLib, installFLib, installExe,         libAbiHash,         hcPkgInfo,         registerPackage,@@ -50,26 +51,36 @@         getLibDir,         isDynamic,         getGlobalPackageDB,-        pkgRoot+        pkgRoot,+        -- * Constructing GHC environment files+        Internal.GhcEnvironmentFileEntry(..),+        Internal.simpleGhcEnvironmentFile,+        Internal.writeGhcEnvironmentFile,+        -- * Version-specific implementation quirks+        getImplInfo,+        GhcImplInfo(..)  ) where -import Control.Applicative -- 7.10 -Werror workaround-import Prelude             -- https://ghc.haskell.org/trac/ghc/wiki/Migration/7.10#GHCsaysTheimportof...isredundant+import Prelude ()+import Distribution.Compat.Prelude  import qualified Distribution.Simple.GHC.IPI642 as IPI642 import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.GHC.ImplInfo+import Distribution.PackageDescription.Utils (cabalBug) import Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo+import Distribution.Types.ComponentLocalBuildInfo import qualified Distribution.Simple.Hpc as Hpc import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package import qualified Distribution.ModuleName as ModuleName+import Distribution.ModuleName (ModuleName) import Distribution.Simple.Program import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar    as Ar@@ -83,46 +94,43 @@ import Distribution.System import Distribution.Verbosity import Distribution.Text+import Distribution.Types.ForeignLib+import Distribution.Types.ForeignLibType+import Distribution.Types.ForeignLibOption import Distribution.Utils.NubList import Language.Haskell.Extension -import Control.Monad            ( unless, when )-import Data.Char                ( isDigit, isSpace )-import Data.List-import qualified Data.Map as M  ( fromList, lookup )-import Data.Maybe               ( catMaybes )-import Data.Monoid as Mon       ( Monoid(..) )-import Data.Version             ( showVersion )+import qualified Data.Map as Map import System.Directory          ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing-         , canonicalizePath )+         , canonicalizePath, removeFile ) import System.FilePath          ( (</>), (<.>), takeExtension                                 , takeDirectory, replaceExtension-                                , isRelative )+                                ,isRelative ) import qualified System.Info  -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration-          -> IO (Compiler, Maybe Platform, ProgramConfiguration)+          -> ProgramDb+          -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do -  (ghcProg, ghcVersion, conf1) <-+  (ghcProg, ghcVersion, progdb1) <-     requireProgramVersion verbosity ghcProgram-      (orLaterVersion (Version [6,11] []))+      (orLaterVersion (mkVersion [6,11]))       (userMaybeSpecifyPath "ghc" hcPath conf0)   let implInfo = ghcVersionImplInfo ghcVersion    -- This is slightly tricky, we have to configure ghc first, then we use the   -- location of ghc to help find ghc-pkg in the case that the user did not   -- specify the location of ghc-pkg directly:-  (ghcPkgProg, ghcPkgVersion, conf2) <-+  (ghcPkgProg, ghcPkgVersion, progdb2) <-     requireProgramVersion verbosity ghcPkgProgram {       programFindLocation = guessGhcPkgFromGhcPath ghcProg     }-    anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1)+    anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1)    when (ghcVersion /= ghcPkgVersion) $ die $        "Version mismatch between ghc and ghc-pkg: "@@ -139,26 +147,31 @@       hpcProgram' = hpcProgram {                         programFindLocation = guessHpcFromGhcPath ghcProg                     }-      conf3 = addKnownProgram haddockProgram' $+      progdb3 = addKnownProgram haddockProgram' $               addKnownProgram hsc2hsProgram' $-              addKnownProgram hpcProgram' conf2+              addKnownProgram hpcProgram' progdb2    languages  <- Internal.getLanguages verbosity implInfo ghcProg   extensions0 <- Internal.getExtensions verbosity implInfo ghcProg    ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg-  let ghcInfoMap = M.fromList ghcInfo+  let ghcInfoMap = Map.fromList ghcInfo+      extensions = -- workaround https://ghc.haskell.org/ticket/11214+                   filterExt JavaScriptFFI $+                   -- see 'filterExtTH' comment below+                   filterExtTH $ extensions0        -- starting with GHC 8.0, `TemplateHaskell` will be omitted from       -- `--supported-extensions` when it's not available.       -- for older GHCs we can use the "Have interpreter" property to       -- filter out `TemplateHaskell`-      extensions | ghcVersion < Version [8] []-                 , Just "NO" <- M.lookup "Have interpreter" ghcInfoMap-                   = filter ((/= EnableExtension TemplateHaskell) . fst)-                     extensions0-                 | otherwise = extensions0+      filterExtTH | ghcVersion < mkVersion [8]+                   , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap+                   = filterExt TemplateHaskell+                  | otherwise = id +      filterExt ext = filter ((/= EnableExtension ext) . fst)+   let comp = Compiler {         compilerId         = CompilerId GHC ghcVersion,         compilerAbiTag     = NoAbiTag,@@ -169,8 +182,8 @@       }       compPlatform = Internal.targetPlatform ghcInfo       -- configure gcc and ld-      conf4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap conf3-  return (comp, compPlatform, conf4)+      progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3+  return (comp, compPlatform, progdb4)  -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking@@ -208,7 +221,7 @@        info verbosity $ "looking for tool " ++ toolname          ++ " near compiler in " ++ given_dir        debug verbosity $ "candidate locations: " ++ show guesses-       exists <- mapM doesFileExist guesses+       exists <- traverse doesFileExist guesses        case [ file | (file, True) <- zip guesses exists ] of                    -- If we can't find it near ghc, fall back to the usual                    -- method.@@ -277,26 +290,26 @@     implInfo = ghcVersionImplInfo version  -- | Given a single package DB, return all installed packages.-getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration+getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb                         -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb conf = do-  pkgss <- getInstalledPackages' verbosity [packagedb] conf-  toPackageIndex verbosity pkgss conf+getPackageDBContents verbosity packagedb progdb = do+  pkgss <- getInstalledPackages' verbosity [packagedb] progdb+  toPackageIndex verbosity pkgss progdb  -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack-                     -> ProgramConfiguration+                     -> ProgramDb                      -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packagedbs conf = do+getInstalledPackages verbosity comp packagedbs progdb = do   checkPackageDbEnvVar   checkPackageDbStack comp packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs conf-  index <- toPackageIndex verbosity pkgss conf+  pkgss <- getInstalledPackages' verbosity packagedbs progdb+  index <- toPackageIndex verbosity pkgss progdb   return $! hackRtsPackage index    where     hackRtsPackage index =-      case PackageIndex.lookupPackageName index (PackageName "rts") of+      case PackageIndex.lookupPackageName index (mkPackageName "rts") of         [(_,[rts])]            -> PackageIndex.insert (removeMingwIncludeDir rts) index         _  -> index -- No (or multiple) ghc rts package is registered!!@@ -307,9 +320,9 @@ -- 'getInstalledPackages'. toPackageIndex :: Verbosity                -> [(PackageDB, [InstalledPackageInfo])]-               -> ProgramConfiguration+               -> ProgramDb                -> IO InstalledPackageIndex-toPackageIndex verbosity pkgss conf = do+toPackageIndex verbosity pkgss progdb = do   -- On Windows, various fields have $topdir/foo rather than full   -- paths. We need to substitute the right value in so that when   -- we, for example, call gcc, we have proper paths to give it.@@ -319,40 +332,39 @@   return $! mconcat indices    where-    Just ghcProg = lookupProgram ghcProgram conf+    Just ghcProg = lookupProgram ghcProgram progdb  getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi =     dropWhileEndLE isSpace `fmap`-     rawSystemProgramStdoutConf verbosity ghcProgram+     getDbProgramOutput verbosity ghcProgram      (withPrograms lbi) ["--print-libdir"]  getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath getLibDir' verbosity ghcProg =     dropWhileEndLE isSpace `fmap`-     rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]+     getProgramOutput verbosity ghcProg ["--print-libdir"]   -- | Return the 'FilePath' to the global GHC package database. getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath getGlobalPackageDB verbosity ghcProg =     dropWhileEndLE isSpace `fmap`-     rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"]+     getProgramOutput verbosity ghcProg ["--print-global-package-db"]  -- | Return the 'FilePath' to the per-user GHC package database.-getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath-getUserPackageDB _verbosity ghcProg (Platform arch os) = do+getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> NoCallStackIO FilePath+getUserPackageDB _verbosity ghcProg platform = do     -- It's rather annoying that we have to reconstruct this, because ghc     -- hides this information from us otherwise. But for certain use cases     -- like change monitoring it really can't remain hidden.     appdir <- getAppUserDataDirectory "ghc"     return (appdir </> platformAndVersion </> packageConfFileName)   where-    platformAndVersion = intercalate "-" [ Internal.showArchString arch-                                         , Internal.showOsString os-                                         , display ghcVersion ]+    platformAndVersion = Internal.ghcPlatformAndVersionString+                           platform ghcVersion     packageConfFileName-      | ghcVersion >= Version [6,12] []  = "package.conf.d"+      | ghcVersion >= mkVersion [6,12]   = "package.conf.d"       | otherwise                        = "package.conf"     Just ghcVersion = programVersion ghcProg @@ -398,21 +410,21 @@  -- | Get the packages from specific PackageDBs, not cumulative. ---getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration+getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb                      -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf-  | ghcVersion >= Version [6,9] [] =-  sequence-    [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb+getInstalledPackages' verbosity packagedbs progdb+  | ghcVersion >= mkVersion [6,9] =+  sequenceA+    [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb          return (packagedb, pkgs)     | packagedb <- packagedbs ]    where-    Just ghcProg    = lookupProgram ghcProgram conf+    Just ghcProg    = lookupProgram ghcProgram progdb     Just ghcVersion = programVersion ghcProg -getInstalledPackages' verbosity packagedbs conf = do-    str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]+getInstalledPackages' verbosity packagedbs progdb = do+    str <- getDbProgramOutput verbosity ghcPkgProgram progdb ["list"]     let pkgFiles = [ init line | line <- lines str, last line == ':' ]         dbFile packagedb = case (packagedb, pkgFiles) of           (GlobalPackageDB, global:_)      -> return $ Just global@@ -420,33 +432,33 @@           (UserPackageDB,  _global:_)      -> return $ Nothing           (SpecificPackageDB specific, _)  -> return $ Just specific           _ -> die "cannot read ghc-pkg package listing"-    pkgFiles' <- mapM dbFile packagedbs-    sequence [ withFileContents file $ \content -> do+    pkgFiles' <- traverse dbFile packagedbs+    sequenceA [ withFileContents file $ \content -> do                   pkgs <- readPackages file content                   return (db, pkgs)-             | (db , Just file) <- zip packagedbs pkgFiles' ]+              | (db , Just file) <- zip packagedbs pkgFiles' ]   where     -- Depending on the version of ghc we use a different type's Read     -- instance to parse the package file and then convert.     -- It's a bit yuck. But that's what we get for using Read/Show.     readPackages-      | ghcVersion >= Version [6,4,2] []+      | ghcVersion >= mkVersion [6,4,2]       = \file content -> case reads content of           [(pkgs, _)] -> return (map IPI642.toCurrent pkgs)           _           -> failToRead file       -- We dropped support for 6.4.2 and earlier.       | otherwise       = \file _ -> failToRead file-    Just ghcProg = lookupProgram ghcProgram conf+    Just ghcProg = lookupProgram ghcProgram progdb     Just ghcVersion = programVersion ghcProg     failToRead file = die $ "cannot read ghc package database " ++ file  getInstalledPackagesMonitorFiles :: Verbosity -> Platform-                                 -> ProgramConfiguration+                                 -> ProgramDb                                  -> [PackageDB]                                  -> IO [FilePath] getInstalledPackagesMonitorFiles verbosity platform progdb =-    mapM getPackageDBPath+    traverse getPackageDBPath   where     getPackageDBPath :: PackageDB -> IO FilePath     getPackageDBPath GlobalPackageDB =@@ -470,10 +482,8 @@   -- -------------------------------------------------------------------------------- Building+-- Building a library --- | Build a library with GHC.--- buildLib, replLib :: Verbosity          -> Cabal.Flag (Maybe Int)                   -> PackageDescription -> LocalBuildInfo                   -> Library            -> ComponentLocalBuildInfo -> IO ()@@ -497,6 +507,7 @@       ghcVersion = compilerVersion comp       implInfo  = getImplInfo comp       platform@(Platform _hostArch hostOS) = hostPlatform lbi+      has_code = not (componentIsIndefinite clbi)    (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)   let runGhcProg = runGHC verbosity ghcProg comp platform@@ -513,15 +524,15 @@    -- Determine if program coverage should be enabled and if so, what   -- '-hpcdir' should be.-  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi+  let isCoverageEnabled = libCoverage lbi       -- TODO: Historically HPC files have been put into a directory which       -- has the package name.  I'm going to avoid changing this for       -- now, but it would probably be better for this to be the       -- component ID instead...-      pkg_name = display $ PD.package $ localPkgDescr lbi+      pkg_name = display (PD.package pkg_descr)       distPref = fromFlag $ configDistPref $ configFlags lbi       hpcdir way-        | forRepl = Mon.mempty  -- HPC is not supported in ghci+        | forRepl = mempty  -- HPC is not supported in ghci         | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name         | otherwise = mempty @@ -533,7 +544,7 @@       vanillaOpts = baseOpts `mappend` mempty {                       ghcOptMode         = toFlag GhcModeMake,                       ghcOptNumJobs      = numJobs,-                      ghcOptInputModules = toNubListR $ libModules lib,+                      ghcOptInputModules = toNubListR $ allLibModules lib clbi,                       ghcOptHPCDir       = hpcdir Hpc.Vanilla                     } @@ -585,14 +596,17 @@                       ghcOptHPCDir       = hpcdir Hpc.Dyn                     } -  unless (forRepl || null (libModules lib)) $+  unless (forRepl || null (allLibModules lib clbi)) $     do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)            shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)            useDynToo = dynamicTooSupported &&                        (forceVanillaLib || withVanillaLib lbi) &&                        (forceSharedLib  || withSharedLib  lbi) &&                        null (hcSharedOptions GHC libBi)-       if useDynToo+       if not has_code+        then vanilla+        else+         if useDynToo           then do               runGhcProg vanillaSharedOpts               case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of@@ -608,10 +622,10 @@           else if isGhcDynamic             then do shared;  vanilla             else do vanilla; shared-       whenProfLib (runGhcProg profOpts)+       when has_code $ whenProfLib (runGhcProg profOpts)    -- build any C sources-  unless (null (cSources libBi)) $ do+  unless (not has_code || null (cSources libBi)) $ do     info verbosity "Building C Sources..."     sequence_       [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo@@ -645,12 +659,12 @@   -- with ghci, but .c files can depend on .h files generated by ghc by ffi   -- exports. -  ifReplLib $ do-    when (null (libModules lib)) $ warn verbosity "No exposed modules"+  when has_code . ifReplLib $ do+    when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"     ifReplLib (runGhcProg replOpts)    -- link:-  unless forRepl $ do+  when has_code . unless forRepl $ do     info verbosity "Linking..."     let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))                       (cSources libBi)@@ -664,32 +678,32 @@         libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest         sharedLibInstallPath = libInstallPath </> mkSharedLibName compiler_id uid -    stubObjs <- catMaybes <$> sequence+    stubObjs <- catMaybes <$> sequenceA       [ findFileWithExtension [objExtension] [libTargetDir]           (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-      , x <- libModules lib ]-    stubProfObjs <- catMaybes <$> sequence+      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files+      , x <- allLibModules lib clbi ]+    stubProfObjs <- catMaybes <$> sequenceA       [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]           (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-      , x <- libModules lib ]-    stubSharedObjs <- catMaybes <$> sequence+      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files+      , x <- allLibModules lib clbi ]+    stubSharedObjs <- catMaybes <$> sequenceA       [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]           (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-      , x <- libModules lib ]+      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files+      , x <- allLibModules lib clbi ] -    hObjs     <- Internal.getHaskellObjects implInfo lib lbi+    hObjs     <- Internal.getHaskellObjects implInfo lib lbi clbi                       libTargetDir objExtension True     hProfObjs <-       if withProfLib lbi-              then Internal.getHaskellObjects implInfo lib lbi+              then Internal.getHaskellObjects implInfo lib lbi clbi                       libTargetDir ("p_" ++ objExtension) True               else return []     hSharedObjs <-       if withSharedLib lbi-              then Internal.getHaskellObjects implInfo lib lbi+              then Internal.getHaskellObjects implInfo lib lbi clbi                       libTargetDir ("dyn_" ++ objExtension) False               else return [] @@ -727,11 +741,26 @@                 -- at build time. This only applies to GHC < 7.8 - see the                 -- discussion in #1660.                 ghcOptDylibName          = if hostOS == OSX-                                              && ghcVersion < Version [7,8] []+                                              && ghcVersion < mkVersion [7,8]                                             then toFlag sharedLibInstallPath                                             else mempty,+                ghcOptHideAllPackages    = toFlag True,                 ghcOptNoAutoLinkPackages = toFlag True,                 ghcOptPackageDBs         = withPackageDB lbi,+                ghcOptThisUnitId = case clbi of+                    LibComponentLocalBuildInfo { componentCompatPackageKey = pk }+                      -> toFlag pk+                    _ -> mempty,+                ghcOptThisComponentId = case clbi of+                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->+                        if null insts+                            then mempty+                            else toFlag (componentComponentId clbi)+                    _ -> mempty,+                ghcOptInstantiatedWith = case clbi of+                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts }+                      -> insts+                    _ -> [],                 ghcOptPackages           = toNubListR $                                            Internal.mkGhcOptPackages clbi ,                 ghcOptLinkLibs           = toNubListR $ extraLibs libBi,@@ -759,79 +788,193 @@         runGhcProg ghcSharedLinkArgs  -- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> Platform+startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform                  -> PackageDBStack -> IO ()-startInterpreter verbosity conf comp platform packageDBs = do+startInterpreter verbosity progdb comp platform packageDBs = do   let replOpts = mempty {         ghcOptMode       = toFlag GhcModeInteractive,         ghcOptPackageDBs = packageDBs         }   checkPackageDbStack comp packageDBs-  (ghcProg, _) <- requireProgram verbosity ghcProgram conf+  (ghcProg, _) <- requireProgram verbosity ghcProgram progdb   runGHC verbosity ghcProg comp platform replOpts +-- -----------------------------------------------------------------------------+-- Building an executable or foreign library++-- | Build a foreign library+buildFLib, replFLib+  :: Verbosity          -> Cabal.Flag (Maybe Int)+  -> PackageDescription -> LocalBuildInfo+  -> ForeignLib         -> ComponentLocalBuildInfo -> IO ()+buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib+replFLib  v njobs pkg lbi = gbuild v njobs pkg lbi . GReplFLib+ -- | Build an executable with GHC. ---buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)-                  -> PackageDescription -> LocalBuildInfo-                  -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe = buildOrReplExe False-replExe  = buildOrReplExe True+buildExe, replExe+  :: Verbosity          -> Cabal.Flag (Maybe Int)+  -> PackageDescription -> LocalBuildInfo+  -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe+replExe  v njobs pkg lbi = gbuild v njobs pkg lbi . GReplExe -buildOrReplExe :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi-  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do+-- | Building an executable, starting the REPL, and building foreign+-- libraries are all very similar and implemented in 'gbuild'. The+-- 'GBuildMode' distinguishes between the various kinds of operation.+data GBuildMode =+    GBuildExe  Executable+  | GReplExe   Executable+  | GBuildFLib ForeignLib+  | GReplFLib  ForeignLib +gbuildInfo :: GBuildMode -> BuildInfo+gbuildInfo (GBuildExe  exe)  = buildInfo exe+gbuildInfo (GReplExe   exe)  = buildInfo exe+gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib+gbuildInfo (GReplFLib  flib) = foreignLibBuildInfo flib++gbuildName :: GBuildMode -> String+gbuildName (GBuildExe  exe)  = unUnqualComponentName $ exeName exe+gbuildName (GReplExe   exe)  = unUnqualComponentName $ exeName exe+gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib+gbuildName (GReplFLib  flib) = unUnqualComponentName $ foreignLibName flib++gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String+gbuildTargetName _lbi (GBuildExe  exe)  = exeTargetName exe+gbuildTargetName _lbi (GReplExe   exe)  = exeTargetName exe+gbuildTargetName  lbi (GBuildFLib flib) = flibTargetName lbi flib+gbuildTargetName  lbi (GReplFLib  flib) = flibTargetName lbi flib++exeTargetName :: Executable -> String+exeTargetName exe = unUnqualComponentName (exeName exe) `withExt` exeExtension++-- | Target name for a foreign library (the actual file name)+--+-- We do not use mkLibName and co here because the naming for foreign libraries+-- is slightly different (we don't use "_p" or compiler version suffices, and we+-- don't want the "lib" prefix on Windows).+--+-- TODO: We do use `dllExtension` and co here, but really that's wrong: they+-- use the OS used to build cabal to determine which extension to use, rather+-- than the target OS (but this is wrong elsewhere in Cabal as well).+flibTargetName :: LocalBuildInfo -> ForeignLib -> String+flibTargetName lbi flib =+    case (platformOS (hostPlatform lbi), foreignLibType flib) of+      (Windows, ForeignLibNativeShared) -> nm <.> "dll"+      (Windows, ForeignLibNativeStatic) -> nm <.> "lib"+      (_other,  ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension+      (_other,  ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension+      (_any,    ForeignLibTypeUnknown)  -> cabalBug "unknown foreign lib type"+  where+    nm :: String+    nm = unUnqualComponentName $ foreignLibName flib++    platformOS :: Platform -> OS+    platformOS (Platform _arch os) = os++gbuildIsRepl :: GBuildMode -> Bool+gbuildIsRepl (GBuildExe  _) = False+gbuildIsRepl (GReplExe   _) = True+gbuildIsRepl (GBuildFLib _) = False+gbuildIsRepl (GReplFLib  _) = True++gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool+gbuildNeedDynamic lbi bm =+    case bm of+      GBuildExe  _    -> withDynExe lbi+      GReplExe   _    -> withDynExe lbi+      GBuildFLib flib -> withDynFLib flib+      GReplFLib  flib -> withDynFLib flib+  where+    withDynFLib flib =+      case foreignLibType flib of+        ForeignLibNativeShared ->+          ForeignLibStandalone `notElem` foreignLibOptions flib+        ForeignLibNativeStatic ->+          False+        ForeignLibTypeUnknown  ->+          cabalBug "unknown foreign lib type"++gbuildModDefFiles :: GBuildMode -> [FilePath]+gbuildModDefFiles (GBuildExe _)     = []+gbuildModDefFiles (GReplExe  _)     = []+gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib+gbuildModDefFiles (GReplFLib  flib) = foreignLibModDefFile flib++-- | Return C sources, GHC input files and GHC input modules+gbuildSources :: FilePath+              -> GBuildMode+              -> IO ([FilePath], [FilePath], [ModuleName])+gbuildSources tmpDir bm =+    case bm of+      GBuildExe  exe  -> exeSources exe+      GReplExe   exe  -> exeSources exe+      GBuildFLib flib -> return $ flibSources flib+      GReplFLib  flib -> return $ flibSources flib+  where+    exeSources :: Executable -> IO ([FilePath], [FilePath], [ModuleName])+    exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do+      main <- findFile (tmpDir : hsSourceDirs bnfo) modPath+      return $ if isHaskell main+                 then (cSources bnfo        , [main] , []            )+                 else (main : cSources bnfo , []     , exeModules exe)++    flibSources :: ForeignLib -> ([FilePath], [FilePath], [ModuleName])+    flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} =+      (cSources bnfo, [], foreignLibModules flib)++    isHaskell :: FilePath -> Bool+    isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]++-- | Generic build function. See comment for 'GBuildMode'.+gbuild :: Verbosity          -> Cabal.Flag (Maybe Int)+       -> PackageDescription -> LocalBuildInfo+       -> GBuildMode         -> ComponentLocalBuildInfo -> IO ()+gbuild verbosity numJobs _pkg_descr lbi bm clbi = do   (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)   let comp       = compiler lbi       platform   = hostPlatform lbi       implInfo   = getImplInfo comp       runGhcProg = runGHC verbosity ghcProg comp platform -  exeBi <- hackThreadedFlag verbosity-             comp (withProfExe lbi) (buildInfo exe)--  -- exeNameReal, the name that GHC really uses (with .exe on Windows)-  let exeNameReal = exeName' <.>-                    (if takeExtension exeName' /= ('.':exeExtension)-                       then exeExtension-                       else "")+  bnfo <- hackThreadedFlag verbosity+            comp (withProfExe lbi) (gbuildInfo bm) -  let targetDir = componentBuildDir lbi clbi-      exeDir    = targetDir </> (exeName' ++ "-tmp")+  -- the name that GHC really uses (e.g., with .exe on Windows for executables)+  let targetName = gbuildTargetName lbi bm+  let targetDir  = buildDir lbi </> (gbuildName bm)+  let tmpDir     = targetDir    </> (gbuildName bm ++ "-tmp")   createDirectoryIfMissingVerbose verbosity True targetDir-  createDirectoryIfMissingVerbose verbosity True exeDir+  createDirectoryIfMissingVerbose verbosity True tmpDir+   -- TODO: do we need to put hs-boot files into place for mutually recursive   -- modules?  FIX: what about exeName.hi-boot?    -- Determine if program coverage should be enabled and if so, what   -- '-hpcdir' should be.-  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi+  let isCoverageEnabled = exeCoverage lbi       distPref = fromFlag $ configDistPref $ configFlags lbi       hpcdir way-        | forRepl = mempty  -- HPC is not supported in ghci-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'-        | otherwise = mempty--  -- build executables+        | gbuildIsRepl bm   = mempty  -- HPC is not supported in ghci+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm)+        | otherwise         = mempty -  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath-  rpaths              <- getRPaths lbi clbi+  rpaths <- getRPaths lbi clbi+  (cSrcs, inputFiles, inputModules) <- gbuildSources tmpDir bm    let isGhcDynamic        = isDynamic comp       dynamicTooSupported = supportsDynamicToo comp-      isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]-      cSrcs         = cSources exeBi ++ [srcMainFile | not isHaskellMain]-      cObjs         = map (`replaceExtension` objExtension) cSrcs-      baseOpts   = (componentGhcOptions verbosity lbi exeBi clbi exeDir)+      cObjs               = map (`replaceExtension` objExtension) cSrcs+      needDynamic         = gbuildNeedDynamic lbi bm+      needProfiling       = withProfExe lbi++  -- build executables+      baseOpts   = (componentGhcOptions verbosity lbi bnfo clbi tmpDir)                     `mappend` mempty {                       ghcOptMode         = toFlag GhcModeMake,-                      ghcOptInputFiles   = toNubListR-                        [ srcMainFile | isHaskellMain],-                      ghcOptInputModules = toNubListR-                        [ m | not isHaskellMain, m <- exeModules exe]+                      ghcOptInputFiles   = toNubListR inputFiles,+                      ghcOptInputModules = toNubListR inputModules                     }       staticOpts = baseOpts `mappend` mempty {                       ghcOptDynLinkMode    = toFlag GhcStaticOnly,@@ -844,15 +987,17 @@                       ghcOptHiSuffix       = toFlag "p_hi",                       ghcOptObjSuffix      = toFlag "p_o",                       ghcOptExtra          = toNubListR-                                             (hcProfOptions GHC exeBi),+                                             (hcProfOptions GHC bnfo),                       ghcOptHPCDir         = hpcdir Hpc.Prof                     }       dynOpts    = baseOpts `mappend` mempty {                       ghcOptDynLinkMode    = toFlag GhcDynamicOnly,+                      -- TODO: Does it hurt to set -fPIC for executables?+                      ghcOptFPic           = toFlag True,                       ghcOptHiSuffix       = toFlag "dyn_hi",                       ghcOptObjSuffix      = toFlag "dyn_o",                       ghcOptExtra          = toNubListR $-                                             hcSharedOptions GHC exeBi,+                                             hcSharedOptions GHC bnfo,                       ghcOptHPCDir         = hpcdir Hpc.Dyn                     }       dynTooOpts = staticOpts `mappend` mempty {@@ -862,21 +1007,21 @@                       ghcOptHPCDir         = hpcdir Hpc.Dyn                     }       linkerOpts = mempty {-                      ghcOptLinkOptions       = toNubListR $ PD.ldOptions exeBi,-                      ghcOptLinkLibs          = toNubListR $ extraLibs exeBi,-                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs exeBi,+                      ghcOptLinkOptions       = toNubListR $ PD.ldOptions bnfo,+                      ghcOptLinkLibs          = toNubListR $ extraLibs bnfo,+                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs bnfo,                       ghcOptLinkFrameworks    = toNubListR $-                                                PD.frameworks exeBi,+                                                PD.frameworks bnfo,                       ghcOptLinkFrameworkDirs = toNubListR $-                                                PD.extraFrameworkDirs exeBi,+                                                PD.extraFrameworkDirs bnfo,                       ghcOptInputFiles     = toNubListR-                                             [exeDir </> x | x <- cObjs]+                                             [tmpDir </> x | x <- cObjs]                     }       dynLinkerOpts = mempty {                       ghcOptRPaths         = rpaths                    }       replOpts   = baseOpts {-                      ghcOptExtra          = overNubListR+                    ghcOptExtra            = overNubListR                                              Internal.filterGhciFlags                                              (ghcOptExtra baseOpts)                    }@@ -887,15 +1032,15 @@                    -- files etc.                    `mappend` linkerOpts                    `mappend` mempty {-                      ghcOptMode           = toFlag GhcModeInteractive,-                      ghcOptOptimisation   = toFlag GhcNoOptimisation-                   }-      commonOpts  | withProfExe lbi = profOpts-                  | withDynExe  lbi = dynOpts-                  | otherwise       = staticOpts+                      ghcOptMode         = toFlag GhcModeInteractive,+                      ghcOptOptimisation = toFlag GhcNoOptimisation+                     }+      commonOpts  | needProfiling = profOpts+                  | needDynamic   = dynOpts+                  | otherwise     = staticOpts       compileOpts | useDynToo = dynTooOpts                   | otherwise = commonOpts-      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)+      withStaticExe = not needProfiling && not needDynamic        -- For building exe's that use TH with -prof or -dynamic we actually have       -- to build twice, once without -prof/-dynamic and then again with@@ -904,31 +1049,25 @@       -- by the compiler.       -- With dynamic-by-default GHC the TH object files loaded at compile-time       -- need to be .dyn_o instead of .o.-      doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi+      doingTH = EnableExtension TemplateHaskell `elem` allExtensions bnfo       -- Should we use -dynamic-too instead of compiling twice?       useDynToo = dynamicTooSupported && isGhcDynamic                   && doingTH && withStaticExe-                  && null (hcSharedOptions GHC exeBi)+                  && null (hcSharedOptions GHC bnfo)       compileTHOpts | isGhcDynamic = dynOpts                     | otherwise    = staticOpts       compileForTH-        | forRepl      = False-        | useDynToo    = False-        | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe)-        | otherwise    = doingTH && (withProfExe lbi || withDynExe lbi)--      linkOpts =-        commonOpts `mappend`-        linkerOpts `mappend`-        mempty { ghcOptLinkNoHsMain   = toFlag (not isHaskellMain) } `mappend`-        (if withDynExe lbi then dynLinkerOpts else mempty)+        | gbuildIsRepl bm = False+        | useDynToo       = False+        | isGhcDynamic    = doingTH && (needProfiling || withStaticExe)+        | otherwise       = doingTH && (needProfiling || needDynamic) -  -- Build static/dynamic object files for TH, if needed.+   -- Build static/dynamic object files for TH, if needed.   when compileForTH $     runGhcProg compileTHOpts { ghcOptNoLink  = toFlag True                              , ghcOptNumJobs = numJobs } -  unless forRepl $+  unless (gbuildIsRepl bm) $     runGhcProg compileOpts { ghcOptNoLink  = toFlag True                            , ghcOptNumJobs = numJobs } @@ -936,14 +1075,24 @@   unless (null cSrcs) $ do    info verbosity "Building C Sources..."    sequence_-     [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi-                         clbi exeDir filename) `mappend` mempty {-                       ghcOptDynLinkMode   = toFlag (if withDynExe lbi-                                                       then GhcDynamicOnly-                                                       else GhcStaticOnly),-                       ghcOptProfilingMode = toFlag (withProfExe lbi)-                     }-              odir  = fromFlag (ghcOptObjDir opts)+     [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo+                              lbi bnfo clbi tmpDir filename+              vanillaCcOpts = if isGhcDynamic+                              -- Dynamic GHC requires C sources to be built+                              -- with -fPIC for REPL to work. See #2207.+                              then baseCcOpts { ghcOptFPic = toFlag True }+                              else baseCcOpts+              profCcOpts    = vanillaCcOpts `mappend` mempty {+                                ghcOptProfilingMode = toFlag True+                              }+              sharedCcOpts  = vanillaCcOpts `mappend` mempty {+                                ghcOptFPic        = toFlag True,+                                ghcOptDynLinkMode = toFlag GhcDynamicOnly+                              }+              opts | needProfiling = profCcOpts+                   | needDynamic   = sharedCcOpts+                   | otherwise     = vanillaCcOpts+              odir = fromFlag (ghcOptObjDir opts)           createDirectoryIfMissingVerbose verbosity True odir           needsRecomp <- checkNeedsRecompilation filename opts           when needsRecomp $@@ -953,16 +1102,165 @@   -- TODO: problem here is we need the .c files built first, so we can load them   -- with ghci, but .c files can depend on .h files generated by ghc by ffi   -- exports.-  when forRepl $ runGhcProg replOpts+  case bm of+    GReplExe  _ -> runGhcProg replOpts+    GReplFLib _ -> runGhcProg replOpts+    GBuildExe _ -> do+      let linkOpts = commonOpts+                   `mappend` linkerOpts+                   `mappend` mempty {+                      ghcOptLinkNoHsMain = toFlag (null inputFiles)+                     }+                   `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) -  -- link:-  unless forRepl $ do-    info verbosity "Linking..."-    runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }+      info verbosity "Linking..."+      -- Work around old GHCs not relinking in this+      -- situation, see #3294+      let target = targetDir </> targetName+      when (compilerVersion comp < mkVersion [7,7]) $ do+        e <- doesFileExist target+        when e (removeFile target)+      runGhcProg linkOpts { ghcOptOutputFile = toFlag target }+    GBuildFLib flib -> do+      let rtsInfo  = extractRtsInfo lbi+          linkOpts = case foreignLibType flib of+            ForeignLibNativeShared ->+                        commonOpts+              `mappend` linkerOpts+              `mappend` dynLinkerOpts+              `mappend` mempty {+                 ghcOptLinkNoHsMain    = toFlag True,+                 ghcOptShared          = toFlag True,+                 ghcOptLinkLibs        = toNubListR [+                                           if needDynamic+                                             then rtsDynamicLib rtsInfo+                                             else rtsStaticLib  rtsInfo+                                           ],+                 ghcOptLinkLibPath     = toNubListR $ rtsLibPaths rtsInfo,+                 ghcOptFPic            = toFlag True,+                 ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm+                }+              -- See Note [RPATH]+              `mappend` ifNeedsRPathWorkaround lbi mempty {+                  ghcOptLinkOptions = toNubListR ["-Wl,--no-as-needed"]+                , ghcOptLinkLibs    = toNubListR ["ffi"]+                }+            ForeignLibNativeStatic ->+              -- this should be caught by buildFLib+              -- (and if we do implement tihs, we probably don't even want to call+              -- ghc here, but rather Ar.createArLibArchive or something)+              cabalBug "static libraries not yet implemented"+            ForeignLibTypeUnknown ->+              cabalBug "unknown foreign lib type"+      info verbosity "Linking..."+      runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> targetName) } +{-+Note [RPATH]+~~~~~~~~~~~~++Suppose that the dynamic library depends on `base`, but not (directly) on+`integer-gmp` (which, however, is a dependency of `base`). We will link the+library as++    gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ...++However, on systems (like Ubuntu) where the linker gets called with `-as-needed`+by default, the linker will notice that `integer-gmp` isn't actually a direct+dependency and hence omit the link.++Then when we attempt to link a C program against this dynamic library, the+_static_ linker will attempt to verify that all symbols can be resolved.  The+dynamic library itself does not require any symbols from `integer-gmp`, but+`base` does. In order to verify that the symbols used by `base` can be+resolved, the static linker needs to be able to _find_ integer-gmp.++Finding the `base` dependency is simple, because the dynamic elf header+(`readelf -d`) for the library that we have created looks something like++    (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so]+    (RPATH)  Library rpath: [/path/to/base-4.7.0.2:...]++However, when it comes to resolving the dependency on `integer-gmp`, it needs+to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this+looks something like++    (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so]+    (RPATH)  Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...]++This specifies the location of `integer-gmp` _in terms of_ the location of base+(using the `$ORIGIN`) variable. But here's the crux: when the static linker+attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE+`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive).+As a consequence, it will not be able to resolve the symbols and report the+missing symbols as errors, _even though the dynamic linker **would** be able to+resolve these symbols_. We can tell the static linker not to report these+errors by using `--unresolved-symbols=ignore-all` and all will be fine when we+run the program ([(indeed, this is what the gold linker+does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes+the resulting library more difficult to use.++Instead what we can do is make sure that the generated dynamic library has+explicit top-level dependencies on these libraries. This means that the static+linker knows where to find them, and when we have transitive dependencies on+the same libraries the linker will only load them once, so we avoid needing to+look at the `RPATH` of our dependencies. We can do this by passing+`--no-as-needed` to the linker, so that it doesn't omit any libraries.++Note that on older ghc (7.6 and before) the Haskell libraries don't have an+RPATH set at all, which makes it even more important that we make these+top-level dependencies.++Finally, we have to explicitly link against `libffi` for the same reason. For+newer ghc this _happens_ to be unnecessary on many systems because `libffi` is+a library which is not specific to GHC, and when the static linker verifies+that all symbols can be resolved it will find the `libffi` that is globally+installed (completely independent from ghc). Of course, this may well be the+_wrong_ version of `libffi`, but it's quite possible that symbol resolution+happens to work. This is of course the wrong approach, which is why we link+explicitly against `libffi` so that we will find the _right_ version of+`libffi`.+-}++-- | Do we need the RPATH workaround?+--+-- See Note [RPATH].+ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a+ifNeedsRPathWorkaround lbi a =+  case hostPlatform lbi of+    Platform _ Linux -> a+    _otherwise       -> mempty++data RtsInfo = RtsInfo {+    rtsDynamicLib :: FilePath+  , rtsStaticLib  :: FilePath+  , rtsLibPaths   :: [FilePath]+  }++-- | Extract (and compute) information about the RTS library+--+-- TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can+-- find this information somewhere. We can lookup the 'hsLibraries' field of+-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which+-- doesn't really help.+extractRtsInfo :: LocalBuildInfo -> RtsInfo+extractRtsInfo lbi =+    case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of+      [(_, [rts])] -> aux rts+      _otherwise   -> error "No (or multiple) ghc rts package is registered"+  where+    aux :: InstalledPackageInfo -> RtsInfo+    aux rts = RtsInfo {+        rtsDynamicLib = "HSrts-ghc" ++ display ghcVersion+      , rtsStaticLib  = "HSrts"+      , rtsLibPaths   = InstalledPackageInfo.libraryDirs rts+      }+    ghcVersion :: Version+    ghcVersion = compilerVersion (compiler lbi)+ -- | Returns True if the modification date of the given source file is newer than -- the object file we last compiled for it, or if no object file exists yet.-checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool+checkNeedsRecompilation :: FilePath -> GhcOptions -> NoCallStackIO Bool checkNeedsRecompilation filename opts = filename `moreRecentFile` oname     where oname = getObjectFileName filename opts @@ -978,7 +1276,7 @@ -- Calculates relative RPATHs when 'relocatable' is set. getRPaths :: LocalBuildInfo           -> ComponentLocalBuildInfo -- ^ Component we are building-          -> IO (NubListR FilePath)+          -> NoCallStackIO (NubListR FilePath) getRPaths lbi clbi | supportRPaths hostOS = do     libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi     let hostPref = case hostOS of@@ -1029,7 +1327,7 @@                   ++ "profiling in ghc-6.8 and older. It will be disabled."     return bi { options = filterHcOptions (/= "-threaded") (options bi) }   where-    mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] []+    mustFilterThreaded = prof && compilerVersion comp < mkVersion [6, 10]                       && "-threaded" `elem` hcOptions GHC bi     filterHcOptions p hcoptss =       [ (hc, if hc == GHC then filter p opts else opts)@@ -1047,12 +1345,18 @@   let       comp        = compiler lbi       platform    = hostPlatform lbi-      vanillaArgs =+      vanillaArgs0 =         (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))         `mappend` mempty {           ghcOptMode         = toFlag GhcModeAbiHash,           ghcOptInputModules = toNubListR $ exposedModules lib         }+      vanillaArgs =+          -- Package DBs unnecessary, and break ghc-cabal. See #3633+          -- BUT, put at least the global database so that 7.4 doesn't+          -- break.+          vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB]+                       , ghcOptPackages = mempty }       sharedArgs = vanillaArgs `mappend` mempty {                        ghcOptDynLinkMode = toFlag GhcDynamicOnly,                        ghcOptFPic        = toFlag True,@@ -1110,17 +1414,41 @@   (progprefix, progsuffix) _pkg exe = do   let binDir = bindir installDirs   createDirectoryIfMissingVerbose verbosity True binDir-  let exeFileName = exeName exe <.> exeExtension-      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix+  let exeName' = unUnqualComponentName $ exeName exe+      exeFileName = exeTargetName exe+      fixedExeBaseName = progprefix ++ exeName' ++ progsuffix       installBinary dest = do           installExecutableFile verbosity-            (buildPref </> exeName exe </> exeFileName)+            (buildPref </> exeName' </> exeFileName)             (dest <.> exeExtension)           when (stripExes lbi) $             Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi)                            (dest <.> exeExtension)   installBinary (binDir </> fixedExeBaseName) +-- |Install foreign library for GHC.+installFLib :: Verbosity+            -> LocalBuildInfo+            -> FilePath  -- ^install location+            -> FilePath  -- ^Build location+            -> PackageDescription+            -> ForeignLib+            -> IO ()+installFLib verbosity lbi targetDir builtDir _pkg flib =+    install (foreignLibIsShared flib)+            builtDir+            targetDir+            (flibTargetName lbi flib)+  where+    install isShared srcDir dstDir name = do+      let src = srcDir </> name+          dst = dstDir </> name+      createDirectoryIfMissingVerbose verbosity True targetDir+      -- TODO: Should we strip? (stripLibs lbi)+      if isShared+        then do installExecutableFile verbosity src dst+        else do installOrdinaryFile   verbosity src dst+ -- |Install for ghc, .hi, .a and, if --with-ghci given, .o installLib    :: Verbosity               -> LocalBuildInfo@@ -1131,19 +1459,17 @@               -> Library               -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do+installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do   -- copy .hi files over:-  whenRegistered $ do-    whenVanilla $ copyModuleFiles "hi"-    whenProf    $ copyModuleFiles "p_hi"-    whenShared  $ copyModuleFiles "dyn_hi"+  whenVanilla $ copyModuleFiles "hi"+  whenProf    $ copyModuleFiles "p_hi"+  whenShared  $ copyModuleFiles "dyn_hi"    -- copy the built library files over:-  whenRegistered $ do+  whenHasCode $ do     whenVanilla $ installOrdinary builtDir targetDir       vanillaLibName     whenProf    $ installOrdinary builtDir targetDir       profileLibName     whenGHCi    $ installOrdinary builtDir targetDir       ghciLibName-  whenRegisteredOrDynExecutable $ do     whenShared  $ installShared   builtDir dynlibTargetDir sharedLibName    where@@ -1165,7 +1491,7 @@     installShared   = install True      copyModuleFiles ext =-      findModuleFiles [builtDir] [ext] (libModules lib)+      findModuleFiles [builtDir] [ext] (allLibModules lib clbi)       >>= installOrdinaryFiles verbosity targetDir      compiler_id = compilerId (compiler lbi)@@ -1175,45 +1501,36 @@     ghciLibName    = Internal.mkGHCiLibName uid     sharedLibName  = (mkSharedLibName compiler_id) uid -    hasLib    = not $ null (libModules lib)+    hasLib    = not $ null (allLibModules lib clbi)                    && null (cSources (libBuildInfo lib))+    has_code = not (componentIsIndefinite clbi)+    whenHasCode = when has_code     whenVanilla = when (hasLib && withVanillaLib lbi)-    whenProf    = when (hasLib && withProfLib    lbi)-    whenGHCi    = when (hasLib && withGHCiLib    lbi)-    whenShared  = when (hasLib && withSharedLib  lbi)--    -- Some files (e.g. interface files) are completely unnecessary when-    -- we are not actually going to register the library.  A library is-    -- not registered if there is no "public library", e.g. in the case-    -- that we have an internal library and executables, but no public-    -- library.-    whenRegistered = when (hasPublicLib pkg)--    -- However, we must always install dynamic libraries when linking-    -- dynamic executables, because we'll try to load them!-    whenRegisteredOrDynExecutable = when (hasPublicLib pkg || (hasExes pkg && withDynExe lbi))+    whenProf    = when (hasLib && withProfLib    lbi && has_code)+    whenGHCi    = when (hasLib && withGHCiLib    lbi && has_code)+    whenShared  = when (hasLib && withSharedLib  lbi && has_code)  -- ----------------------------------------------------------------------------- -- Registering -hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo-hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcPkgProg-                                 , HcPkg.noPkgDbStack    = v < [6,9]-                                 , HcPkg.noVerboseFlag   = v < [6,11]-                                 , HcPkg.flagPackageConf = v < [7,5]-                                 , HcPkg.supportsDirDbs  = v >= [6,8]-                                 , HcPkg.requiresDirDbs  = v >= [7,10]-                                 , HcPkg.nativeMultiInstance  = v >= [7,10]-                                 , HcPkg.recacheMultiInstance = v >= [6,12]-                                 }+hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo+hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcPkgProg+                                   , HcPkg.noPkgDbStack    = v < [6,9]+                                   , HcPkg.noVerboseFlag   = v < [6,11]+                                   , HcPkg.flagPackageConf = v < [7,5]+                                   , HcPkg.supportsDirDbs  = v >= [6,8]+                                   , HcPkg.requiresDirDbs  = v >= [7,10]+                                   , HcPkg.nativeMultiInstance  = v >= [7,10]+                                   , HcPkg.recacheMultiInstance = v >= [6,12]+                                   }   where-    v               = versionBranch ver-    Just ghcPkgProg = lookupProgram ghcPkgProgram conf+    v               = versionNumbers ver+    Just ghcPkgProg = lookupProgram ghcPkgProgram progdb     Just ver        = programVersion ghcPkgProg  registerPackage   :: Verbosity-  -> ProgramConfiguration+  -> ProgramDb   -> HcPkg.MultiInstance   -> PackageDBStack   -> InstalledPackageInfo@@ -1237,7 +1554,7 @@       appDir <- getAppUserDataDirectory "ghc"       let ver      = compilerVersion (compiler lbi)           subdir   = System.Info.arch ++ '-':System.Info.os-                     ++ '-':showVersion ver+                     ++ '-':display ver           rootDir  = appDir </> subdir       -- We must create the root directory for the user package database if it       -- does not yet exists. Otherwise '${pkgroot}' will resolve to a@@ -1255,3 +1572,6 @@  supportsDynamicToo :: Compiler -> Bool supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"++withExt :: FilePath -> String -> FilePath+withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else ""
cabal/Cabal/Distribution/Simple/GHC/IPI642.hs view
@@ -13,9 +13,13 @@     toCurrent,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import qualified Distribution.InstalledPackageInfo as Current import qualified Distribution.Package as Current hiding (installedUnitId) import Distribution.Simple.GHC.IPIConvert+import Distribution.Text  -- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. --@@ -66,8 +70,10 @@   in Current.InstalledPackageInfo {     Current.sourcePackageId    = pid,     Current.installedUnitId    = Current.mkLegacyUnitId pid,+    Current.installedComponentId_ = Current.mkComponentId (display pid),+    Current.instantiatedWith   = [],     Current.compatPackageKey   = "",-    Current.abiHash            = Current.AbiHash "", -- bogus but old GHCs don't care.+    Current.abiHash            = Current.mkAbiHash "", -- bogus but old GHCs don't care.     Current.license            = convertLicense (license ipi),     Current.copyright          = copyright ipi,     Current.maintainer         = maintainer ipi,@@ -78,12 +84,14 @@     Current.synopsis           = "",     Current.description        = description ipi,     Current.category           = category ipi,+    Current.indefinite         = False,     Current.exposed            = exposed ipi,     Current.exposedModules     = map (mkExposedModule . convertModuleName) (exposedModules ipi),     Current.hiddenModules      = map convertModuleName (hiddenModules ipi),     Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,     Current.importDirs         = importDirs ipi,     Current.libraryDirs        = libraryDirs ipi,+    Current.libraryDynDirs     = [],     Current.dataDir            = "",     Current.hsLibraries        = hsLibraries ipi,     Current.extraLibraries     = extraLibraries ipi,
cabal/Cabal/Distribution/Simple/GHC/IPIConvert.hs view
@@ -14,6 +14,9 @@     convertModuleName   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import qualified Distribution.Package as Current hiding (installedUnitId) import qualified Distribution.License as Current @@ -21,8 +24,6 @@ import Distribution.ModuleName import Distribution.Text -import Data.Maybe- data PackageIdentifier = PackageIdentifier {     pkgName    :: String,     pkgVersion :: Version@@ -31,14 +32,14 @@  convertPackageId :: PackageIdentifier -> Current.PackageIdentifier convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } =-  Current.PackageIdentifier (Current.PackageName n) v+  Current.PackageIdentifier (Current.mkPackageName n) v  data License = GPL | LGPL | BSD3 | BSD4              | PublicDomain | AllRightsReserved | OtherLicense   deriving Read  convertModuleName :: String -> ModuleName-convertModuleName s = fromJust $ simpleParse s+convertModuleName s = fromMaybe (error "convertModuleName") $ simpleParse s  convertLicense :: License -> Current.License convertLicense GPL  = Current.GPL  Nothing
cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs view
@@ -14,6 +14,9 @@         ghcVersionImplInfo, ghcjsVersionImplInfo, lhcVersionImplInfo         ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Compiler import Distribution.Version @@ -38,6 +41,7 @@   , flagProfAuto         :: Bool -- ^ new style -fprof-auto* flags   , flagPackageConf      :: Bool -- ^ use package-conf instead of package-db   , flagDebugInfo        :: Bool -- ^ -g flag supported+  , supportsPkgEnvFiles  :: Bool -- ^ picks up @.ghc.environment@ files   }  getImplInfo :: Compiler -> GhcImplInfo@@ -54,7 +58,7 @@                     ", but found " ++ show x)  ghcVersionImplInfo :: Version -> GhcImplInfo-ghcVersionImplInfo (Version v _) = GhcImplInfo+ghcVersionImplInfo ver = GhcImplInfo   { supportsHaskell2010  = v >= [7]   , reportsNoExt         = v >= [7]   , alwaysNondecIndent   = v <  [7,1]@@ -62,10 +66,15 @@   , flagProfAuto         = v >= [7,4]   , flagPackageConf      = v <  [7,5]   , flagDebugInfo        = v >= [7,10]+  , supportsPkgEnvFiles  = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2   }+  where+    v = versionNumbers ver -ghcjsVersionImplInfo :: Version -> Version -> GhcImplInfo-ghcjsVersionImplInfo _ghcjsVer _ghcVer = GhcImplInfo+ghcjsVersionImplInfo :: Version  -- ^ The GHCJS version+                     -> Version  -- ^ The GHC version+                     -> GhcImplInfo+ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo   { supportsHaskell2010  = True   , reportsNoExt         = True   , alwaysNondecIndent   = False@@ -73,7 +82,10 @@   , flagProfAuto         = True   , flagPackageConf      = False   , flagDebugInfo        = False+  , supportsPkgEnvFiles  = ghcv >= [8,0,2] --TODO: check this works in ghcjs   }+  where+    ghcv = versionNumbers ghcver  lhcVersionImplInfo :: Version -> GhcImplInfo lhcVersionImplInfo = ghcVersionImplInfo
cabal/Cabal/Distribution/Simple/GHC/Internal.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.GHC.Internal@@ -26,12 +28,26 @@         substTopDir,         checkPackageDbEnvVar,         profDetailLevelFlag,-        showArchString,-        showOsString,+        -- * GHC platform and version strings+        ghcArchString,+        ghcOsString,+        ghcPlatformAndVersionString,+        -- * Constructing GHC environment files+        GhcEnvironmentFileEntry(..),+        writeGhcEnvironmentFile,+        simpleGhcEnvironmentFile,+        ghcEnvironmentFileName,+        renderGhcEnvironmentFile,+        renderGhcEnvironmentFileEntry,  ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.GHC.ImplInfo import Distribution.Package+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Backpack import Distribution.InstalledPackageInfo import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.PackageDescription as PD hiding (Flag)@@ -43,19 +59,20 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program import Distribution.Simple.LocalBuildInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo import Distribution.Simple.Utils import Distribution.Simple.BuildPaths import Distribution.System import Distribution.Text ( display, simpleParse ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity+import Distribution.Compat.Stack+import Distribution.Version (Version) import Language.Haskell.Extension -import qualified Data.Map as M-import Data.Char                ( isSpace )-import Data.Maybe               ( fromMaybe, maybeToList, isJust )-import Control.Monad            ( unless, when )-import Data.Monoid as Mon       ( Monoid(..) )+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy.Char8 as BS import System.Directory         ( getDirectoryContents, getTemporaryDirectory ) import System.Environment       ( getEnv ) import System.FilePath          ( (</>), (<.>), takeExtension@@ -69,9 +86,9 @@ -- configureToolchain :: GhcImplInfo                    -> ConfiguredProgram-                   -> M.Map String String-                   -> ProgramConfiguration-                   -> ProgramConfiguration+                   -> Map String String+                   -> ProgramDb+                   -> ProgramDb configureToolchain _implInfo ghcProg ghcInfo =     addKnownProgram gccProgram {       programFindLocation = findProg gccProgramName extraGccPath,@@ -129,14 +146,16 @@      -- Read tool locations from the 'ghc --info' output. Useful when     -- cross-compiling.-    mbGccLocation   = M.lookup "C compiler command" ghcInfo-    mbLdLocation    = M.lookup "ld command" ghcInfo-    mbArLocation    = M.lookup "ar command" ghcInfo-    mbStripLocation = M.lookup "strip command" ghcInfo+    mbGccLocation   = Map.lookup "C compiler command" ghcInfo+    mbLdLocation    = Map.lookup "ld command" ghcInfo+    mbArLocation    = Map.lookup "ar command" ghcInfo+    mbStripLocation = Map.lookup "strip command" ghcInfo      ccFlags        = getFlags "C compiler flags"-    gccLinkerFlags = getFlags "Gcc Linker flags"-    ldLinkerFlags  = getFlags "Ld Linker flags"+    -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags"+    -- and "Ld Linker flags" to "ld flags" (GHC #4862).+    gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags"+    ldLinkerFlags  = getFlags "Ld Linker flags" ++ getFlags "ld flags"      -- It appears that GHC 7.6 and earlier encode the tokenized flags as a     -- [String] in these settings whereas later versions just encode the flags as@@ -146,13 +165,13 @@     -- flags ourself.     getFlags :: String -> [String]     getFlags key =-        case M.lookup key ghcInfo of+        case Map.lookup key ghcInfo of           Nothing -> []           Just flags             | (flags', ""):_ <- reads flags -> flags'             | otherwise -> tokenizeQuotedWords flags -    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureGcc :: Verbosity -> ConfiguredProgram -> NoCallStackIO ConfiguredProgram     configureGcc _v gccProg = do       return gccProg {         programDefaultArgs = programDefaultArgs gccProg@@ -174,12 +193,15 @@              withTempFile tempDir ".o" $ \testofile testohnd -> do                hPutStrLn testchnd "int foo() { return 0; }"                hClose testchnd; hClose testohnd-               rawSystemProgram verbosity ghcProg ["-c", testcfile,-                                                   "-o", testofile]+               runProgram verbosity ghcProg+                          [ "-hide-all-packages"+                          , "-c", testcfile+                          , "-o", testofile+                          ]                withTempFile tempDir ".o" $ \testofile' testohnd' ->                  do                    hClose testohnd'-                   _ <- rawSystemProgramStdout verbosity ldProg+                   _ <- getProgramOutput verbosity ldProg                      ["-x", "-r", testofile, "-o", testofile']                    return True                  `catchIO`   (\_ -> return False)@@ -189,7 +211,7 @@         else return ldProg  getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram-             -> IO [(Language, String)]+             -> NoCallStackIO [(Language, String)] getLanguages _ implInfo _   -- TODO: should be using --supported-languages rather than hard coding   | supportsHaskell2010 implInfo = return [(Haskell98,   "-XHaskell98")@@ -242,12 +264,17 @@                       -> GhcOptions componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename =     mempty {-      ghcOptVerbosity      = toFlag verbosity,+      -- Respect -v0, but don't crank up verbosity on GHC if+      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!+      ghcOptVerbosity      = toFlag (min verbosity normal),       ghcOptMode           = toFlag GhcModeCompile,       ghcOptInputFiles     = toNubListR [filename], -      ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi clbi, odir]+      ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi+                                          ,autogenPackageModulesDir lbi+                                          ,odir]                                           ++ PD.includeDirs bi,+      ghcOptHideAllPackages= toFlag True,       ghcOptPackageDBs     = withPackageDB lbi,       ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,       ghcOptCcOptions      = toNubListR $@@ -268,24 +295,41 @@                     -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir =     mempty {-      ghcOptVerbosity       = toFlag verbosity,-      ghcOptHideAllPackages = toFlag True,+      -- Respect -v0, but don't crank up verbosity on GHC if+      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!+      ghcOptVerbosity       = toFlag (min verbosity normal),       ghcOptCabal           = toFlag True,       ghcOptThisUnitId      = case clbi of         LibComponentLocalBuildInfo { componentCompatPackageKey = pk }           -> toFlag pk-        _ -> Mon.mempty,+        _ -> mempty,+      ghcOptThisComponentId = case clbi of+          LibComponentLocalBuildInfo { componentComponentId = cid+                                     , componentInstantiatedWith = insts } ->+              if null insts+                  then mempty+                  else toFlag cid+          _ -> mempty,+      ghcOptInstantiatedWith = case clbi of+        LibComponentLocalBuildInfo { componentInstantiatedWith = insts }+          -> insts+        _ -> [],+      ghcOptNoCode          = toFlag $ componentIsIndefinite clbi,+      ghcOptHideAllPackages = toFlag True,       ghcOptPackageDBs      = withPackageDB lbi,       ghcOptPackages        = toNubListR $ mkGhcOptPackages clbi,       ghcOptSplitObjs       = toFlag (splitObjs lbi),       ghcOptSourcePathClear = toFlag True,       ghcOptSourcePath      = toNubListR $ [odir] ++ (hsSourceDirs bi)-                                           ++ [autogenModulesDir lbi clbi],-      ghcOptCppIncludePath  = toNubListR $ [autogenModulesDir lbi clbi, odir]+                                           ++ [autogenComponentModulesDir lbi clbi]+                                           ++ [autogenPackageModulesDir lbi],+      ghcOptCppIncludePath  = toNubListR $ [autogenComponentModulesDir lbi clbi+                                           ,autogenPackageModulesDir lbi+                                           ,odir]                                            ++ PD.includeDirs bi,       ghcOptCppOptions      = toNubListR $ cppOptions bi,       ghcOptCppIncludes     = toNubListR $-                              [autogenModulesDir lbi clbi </> cppHeaderName],+                              [autogenComponentModulesDir lbi clbi </> cppHeaderName],       ghcOptFfiIncludes     = toNubListR $ PD.includes bi,       ghcOptObjDir          = toFlag odir,       ghcOptHiDir           = toFlag odir,@@ -294,10 +338,11 @@       ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),       ghcOptDebugInfo       = toGhcDebugInfo (withDebugInfo lbi),       ghcOptExtra           = toNubListR $ hcOptions GHC bi,+      ghcOptExtraPath       = toNubListR $ exe_paths,       ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),       -- Unsupported extensions have already been checked by configure       ghcOptExtensions      = toNubListR $ usedExtensions bi,-      ghcOptExtensionMap    = M.fromList . compilerExtensions $ (compiler lbi)+      ghcOptExtensionMap    = Map.fromList . compilerExtensions $ (compiler lbi)     }   where     toGhcOptimisation NoOptimisation      = mempty --TODO perhaps override?@@ -310,6 +355,11 @@     toGhcDebugInfo NormalDebugInfo  = toFlag True     toGhcDebugInfo MaximalDebugInfo = toFlag True +    exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt)+                | uid <- componentExeDeps clbi+                -- TODO: Ugh, localPkgDescr+                , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ]+ -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported@@ -328,20 +378,21 @@  ghcLookupProperty :: String -> Compiler -> Bool ghcLookupProperty prop comp =-  case M.lookup prop (compilerProperties comp) of+  case Map.lookup prop (compilerProperties comp) of     Just "YES" -> True     _          -> False  -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo-                  -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs+                  -> ComponentLocalBuildInfo+                  -> FilePath -> String -> Bool -> NoCallStackIO [FilePath]+getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs   | splitObjs lbi && allow_split_objs = do         let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"             dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)-                   | x <- libModules lib ]-        objss <- mapM getDirectoryContents dirs+                   | x <- allLibModules lib clbi ]+        objss <- traverse getDirectoryContents dirs         let objs = [ dir </> obj                    | (objs',dir) <- zip objss dirs, obj <- objs',                      let obj_ext = takeExtension obj,@@ -349,10 +400,10 @@         return objs   | otherwise  =         return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext-               | x <- libModules lib ]+               | x <- allLibModules lib clbi ]  mkGhcOptPackages :: ComponentLocalBuildInfo-                 -> [(UnitId, ModuleRenaming)]+                 -> [(OpenUnitId, ModuleRenaming)] mkGhcOptPackages = componentIncludes  substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo@@ -391,7 +442,7 @@         mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"         unless (mPP == mcsPP) abort     where-        lookupEnv :: String -> IO (Maybe String)+        lookupEnv :: String -> NoCallStackIO (Maybe String)         lookupEnv name = (Just `fmap` getEnv name)                          `catchIO` const (return Nothing)         abort =@@ -400,6 +451,8 @@                ++ "flag --package-db to specify a package database (it can be "                ++ "used multiple times)." +        _ = callStack -- TODO: output stack when erroring+ profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto profDetailLevelFlag forLib mpl =     case mpl of@@ -411,19 +464,100 @@       ProfDetailAllFunctions        -> toFlag GhcProfAutoAll       ProfDetailOther _             -> mempty ++-- -----------------------------------------------------------------------------+-- GHC platform and version strings+ -- | GHC's rendering of it's host or target 'Arch' as used in its platform -- strings and certain file locations (such as user package db location). ---showArchString :: Arch -> String-showArchString PPC   = "powerpc"-showArchString PPC64 = "powerpc64"-showArchString other = display other+ghcArchString :: Arch -> String+ghcArchString PPC   = "powerpc"+ghcArchString PPC64 = "powerpc64"+ghcArchString other = display other  -- | GHC's rendering of it's host or target 'OS' as used in its platform -- strings and certain file locations (such as user package db location). ---showOsString :: OS -> String-showOsString Windows = "mingw32"-showOsString OSX     = "darwin"-showOsString Solaris = "solaris2"-showOsString other   = display other+ghcOsString :: OS -> String+ghcOsString Windows = "mingw32"+ghcOsString OSX     = "darwin"+ghcOsString Solaris = "solaris2"+ghcOsString other   = display other++-- | GHC's rendering of it's platform and compiler version string as used in+-- certain file locations (such as user package db location).+-- For example @x86_64-linux-7.10.4@+--+ghcPlatformAndVersionString :: Platform -> Version -> String+ghcPlatformAndVersionString (Platform arch os) version =+    intercalate "-" [ ghcArchString arch, ghcOsString os, display version ]+++-- -----------------------------------------------------------------------------+-- Constructing GHC environment files++-- | The kinds of entries we can stick in a @.ghc.environment@ file.+--+data GhcEnvironmentFileEntry =+       GhcEnvFileComment   String     -- ^ @-- a comment@+     | GhcEnvFilePackageId UnitId     -- ^ @package-id foo-1.0-4fe301a...@+     | GhcEnvFilePackageDb PackageDB  -- ^ @global-package-db@,+                                      --   @user-package-db@ or+                                      --   @package-db blah/package.conf.d/@+     | GhcEnvFileClearPackageDbStack  -- ^ @clear-package-db@++-- | Make entries for a GHC environment file based on a 'PackageDBStack' and+-- a bunch of package (unit) ids.+--+-- If you need to do anything more complicated then either use this as a basis+-- and add more entries, or just make all the entries directly.+--+simpleGhcEnvironmentFile :: PackageDBStack+                         -> [UnitId]+                         -> [GhcEnvironmentFileEntry]+simpleGhcEnvironmentFile packageDBs pkgids =+    GhcEnvFileClearPackageDbStack+  : map GhcEnvFilePackageDb packageDBs+ ++ map GhcEnvFilePackageId pkgids++-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory.+--+-- The 'Platform' and GHC 'Version' are needed as part of the file name.+--+writeGhcEnvironmentFile :: FilePath  -- ^ directory in which to put it+                        -> Platform  -- ^ the GHC target platform+                        -> Version   -- ^ the GHC version+                        -> [GhcEnvironmentFileEntry] -- ^ the content+                        -> NoCallStackIO ()+writeGhcEnvironmentFile directory platform ghcversion =+    writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile+  where+    envfile = directory </> ghcEnvironmentFileName platform ghcversion++-- | The @.ghc.environment-$arch-$os-$ver@ file name+--+ghcEnvironmentFileName :: Platform -> Version -> FilePath+ghcEnvironmentFileName platform ghcversion =+    ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion++-- | Render a bunch of GHC environment file entries+--+renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String+renderGhcEnvironmentFile =+    unlines . map renderGhcEnvironmentFileEntry++-- | Render an individual GHC environment file entry+--+renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String+renderGhcEnvironmentFileEntry entry = case entry of+    GhcEnvFileComment   comment   -> format comment+      where format = intercalate "\n" . map ("-- " ++) . lines+    GhcEnvFilePackageId pkgid     -> "package-id " ++ display pkgid+    GhcEnvFilePackageDb pkgdb     ->+      case pkgdb of+        GlobalPackageDB           -> "global-package-db"+        UserPackageDB             -> "user-package-db"+        SpecificPackageDB dbfile  -> "package-db " ++ dbfile+    GhcEnvFileClearPackageDbStack -> "clear-package-db"+
cabal/Cabal/Distribution/Simple/GHCJS.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ module Distribution.Simple.GHCJS (         configure, getInstalledPackages, getPackageDBContents,         buildLib, buildExe,@@ -15,6 +17,9 @@         runCmd   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.PackageDescription as PD@@ -42,33 +47,30 @@ import Distribution.Text import Language.Haskell.Extension -import Control.Monad            ( unless, when )-import Data.Char                ( isSpace )-import qualified Data.Map as M  ( fromList  )-import Data.Monoid as Mon       ( Monoid(..) )+import qualified Data.Map as Map import System.Directory         ( doesFileExist ) import System.FilePath          ( (</>), (<.>), takeExtension                                 , takeDirectory, replaceExtension )  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration-          -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath hcPkgPath conf0 = do-  (ghcjsProg, ghcjsVersion, conf1) <-+          -> ProgramDb+          -> IO (Compiler, Maybe Platform, ProgramDb)+configure verbosity hcPath hcPkgPath progdb0 = do+  (ghcjsProg, ghcjsVersion, progdb1) <-     requireProgramVersion verbosity ghcjsProgram-      (orLaterVersion (Version [0,1] []))-      (userMaybeSpecifyPath "ghcjs" hcPath conf0)+      (orLaterVersion (mkVersion [0,1]))+      (userMaybeSpecifyPath "ghcjs" hcPath progdb0)   Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)   let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion    -- This is slightly tricky, we have to configure ghcjs first, then we use the   -- location of ghcjs to help find ghcjs-pkg in the case that the user did not   -- specify the location of ghc-pkg directly:-  (ghcjsPkgProg, ghcjsPkgVersion, conf2) <-+  (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <-     requireProgramVersion verbosity ghcjsPkgProgram {       programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg     }-    anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath conf1)+    anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)    Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion                                   verbosity (programPath ghcjsPkgProg)@@ -96,18 +98,18 @@       haddockProgram' =         haddockProgram { programFindLocation =                           guessHaddockFromGhcjsPath ghcjsProg }-      conf3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] conf2+      progdb3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] progdb2    languages  <- Internal.getLanguages  verbosity implInfo ghcjsProg   extensions <- Internal.getExtensions verbosity implInfo ghcjsProg    ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg-  let ghcInfoMap = M.fromList ghcInfo+  let ghcInfoMap = Map.fromList ghcInfo    let comp = Compiler {         compilerId         = CompilerId GHCJS ghcjsVersion,         compilerAbiTag     = AbiTag $-          "ghc" ++ intercalate "_" (map show . versionBranch $ ghcjsGhcVersion),+          "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion),         compilerCompat     = [CompilerId GHC ghcjsGhcVersion],         compilerLanguages  = languages,         compilerExtensions = extensions,@@ -115,11 +117,11 @@       }       compPlatform = Internal.targetPlatform ghcInfo   -- configure gcc and ld-  let conf4 = if ghcjsNativeToo comp+  let progdb4 = if ghcjsNativeToo comp                      then Internal.configureToolchain implInfo-                            ghcjsProg ghcInfoMap conf3-                     else conf3-  return (comp, compPlatform, conf4)+                            ghcjsProg ghcInfoMap progdb3+                     else progdb3+  return (comp, compPlatform, progdb4)  ghcjsNativeToo :: Compiler -> Bool ghcjsNativeToo = Internal.ghcLookupProperty "Native Too"@@ -161,7 +163,7 @@                                            guessNormal]        info verbosity $ "looking for tool " ++ toolname          ++ " near compiler in " ++ dir-       exists <- mapM doesFileExist guesses+       exists <- traverse doesFileExist guesses        case [ file | (file, True) <- zip guesses exists ] of                    -- If we can't find it near ghc, fall back to the usual                    -- method.@@ -177,27 +179,27 @@                             reverse  -- | Given a single package DB, return all installed packages.-getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration+getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb                      -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb conf = do-  pkgss <- getInstalledPackages' verbosity [packagedb] conf-  toPackageIndex verbosity pkgss conf+getPackageDBContents verbosity packagedb progdb = do+  pkgss <- getInstalledPackages' verbosity [packagedb] progdb+  toPackageIndex verbosity pkgss progdb  -- | Given a package DB stack, return all installed packages.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb                      -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs conf = do+getInstalledPackages verbosity packagedbs progdb = do   checkPackageDbEnvVar   checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs conf-  index <- toPackageIndex verbosity pkgss conf+  pkgss <- getInstalledPackages' verbosity packagedbs progdb+  index <- toPackageIndex verbosity pkgss progdb   return $! index  toPackageIndex :: Verbosity                -> [(PackageDB, [InstalledPackageInfo])]-               -> ProgramConfiguration+               -> ProgramDb                -> IO InstalledPackageIndex-toPackageIndex verbosity pkgss conf = do+toPackageIndex verbosity pkgss progdb = do   -- On Windows, various fields have $topdir/foo rather than full   -- paths. We need to substitute the right value in so that when   -- we, for example, call gcc, we have proper paths to give it.@@ -207,7 +209,7 @@   return $! (mconcat indices)    where-    Just ghcjsProg = lookupProgram ghcjsProgram conf+    Just ghcjsProg = lookupProgram ghcjsProgram progdb  checkPackageDbEnvVar :: IO () checkPackageDbEnvVar =@@ -225,30 +227,30 @@   die $ "If the global package db is specified, it must be "      ++ "specified first and cannot be specified multiple times" -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration+getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb                       -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf =-  sequence-    [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb+getInstalledPackages' verbosity packagedbs progdb =+  sequenceA+    [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb          return (packagedb, pkgs)     | packagedb <- packagedbs ]  getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi =     (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdoutConf verbosity ghcjsProgram+     getDbProgramOutput verbosity ghcjsProgram      (withPrograms lbi) ["--print-libdir"]  getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath getLibDir' verbosity ghcjsProg =     (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdout verbosity ghcjsProg ["--print-libdir"]+     getProgramOutput verbosity ghcjsProg ["--print-libdir"]  -- | Return the 'FilePath' to the global GHC package database. getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath getGlobalPackageDB verbosity ghcjsProg =     (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdout verbosity ghcjsProg ["--print-global-package-db"]+     getProgramOutput verbosity ghcjsProg ["--print-global-package-db"]  toJSLibName :: String -> String toJSLibName lib@@ -266,7 +268,7 @@ buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)                -> PackageDescription -> LocalBuildInfo                -> Library            -> ComponentLocalBuildInfo -> IO ()-buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do+buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do   let uid = componentUnitId clbi       libTargetDir = buildDir lbi       whenVanillaLib forceVanilla =@@ -293,12 +295,12 @@    -- Determine if program coverage should be enabled and if so, what   -- '-hpcdir' should be.-  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi-      pkg_name = display $ PD.package $ localPkgDescr lbi+  let isCoverageEnabled = libCoverage lbi+      pkg_name = display $ PD.package pkg_descr       distPref = fromFlag $ configDistPref $ configFlags lbi       hpcdir way         | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name-        | otherwise = Mon.mempty+        | otherwise = mempty    createDirectoryIfMissingVerbose verbosity True libTargetDir   -- TODO: do we need to put hs-boot files into place for mutually recursive@@ -315,7 +317,7 @@       vanillaOptsNoJsLib = baseOpts `mappend` mempty {                       ghcOptMode         = toFlag GhcModeMake,                       ghcOptNumJobs      = numJobs,-                      ghcOptInputModules = toNubListR $ libModules lib,+                      ghcOptInputModules = toNubListR $ allLibModules lib clbi,                       ghcOptHPCDir       = hpcdir Hpc.Vanilla                     }       vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts@@ -361,7 +363,7 @@                               ghcOptHPCDir       = hpcdir Hpc.Dyn                             } -  unless (forRepl || (null (libModules lib) && null jsSrcs && null cObjs)) $+  unless (forRepl || (null (allLibModules lib clbi) && null jsSrcs && null cObjs)) $     do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)            shared  = whenSharedLib  forceSharedLib  (runGhcjsProg sharedOpts)            useDynToo = dynamicTooSupported &&@@ -412,7 +414,7 @@   -- TODO: problem here is we need the .c files built first, so we can load them   -- with ghci, but .c files can depend on .h files generated by ghc by ffi   -- exports.-  unless (null (libModules lib)) $+  unless (null (allLibModules lib clbi)) $      ifReplLib (runGhcjsProg replOpts)    -- link:@@ -428,16 +430,16 @@         sharedLibFilePath  = libTargetDir </> mkSharedLibName compiler_id uid         ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName uid -    hObjs     <- Internal.getHaskellObjects implInfo lib lbi+    hObjs     <- Internal.getHaskellObjects implInfo lib lbi clbi                       libTargetDir objExtension True     hProfObjs <-       if (withProfLib lbi)-              then Internal.getHaskellObjects implInfo lib lbi+              then Internal.getHaskellObjects implInfo lib lbi clbi                       libTargetDir ("p_" ++ objExtension) True               else return []     hSharedObjs <-       if (withSharedLib lbi)-              then Internal.getHaskellObjects implInfo lib lbi+              then Internal.getHaskellObjects implInfo lib lbi clbi                       libTargetDir ("dyn_" ++ objExtension) False               else return [] @@ -489,15 +491,15 @@         runGhcjsProg ghcSharedLinkArgs  -- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> Platform+startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform                  -> PackageDBStack -> IO ()-startInterpreter verbosity conf comp platform packageDBs = do+startInterpreter verbosity progdb comp platform packageDBs = do   let replOpts = mempty {         ghcOptMode       = toFlag GhcModeInteractive,         ghcOptPackageDBs = packageDBs         }   checkPackageDbStack packageDBs-  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf+  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb   runGHC verbosity ghcjsProg comp platform replOpts  buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)@@ -519,14 +521,15 @@       runGhcjsProg = runGHC verbosity ghcjsProg comp platform       exeBi        = buildInfo exe +  let exeName'' = unUnqualComponentName exeName'   -- exeNameReal, the name that GHC really uses (with .exe on Windows)-  let exeNameReal = exeName' <.>-                    (if takeExtension exeName' /= ('.':exeExtension)+  let exeNameReal = exeName'' <.>+                    (if takeExtension exeName'' /= ('.':exeExtension)                        then exeExtension                        else "") -  let targetDir = (buildDir lbi) </> exeName'-  let exeDir    = targetDir </> (exeName' ++ "-tmp")+  let targetDir = (buildDir lbi) </> exeName''+  let exeDir    = targetDir </> (exeName'' ++ "-tmp")   createDirectoryIfMissingVerbose verbosity True targetDir   createDirectoryIfMissingVerbose verbosity True exeDir   -- TODO: do we need to put hs-boot files into place for mutually recursive@@ -534,10 +537,10 @@    -- Determine if program coverage should be enabled and if so, what   -- '-hpcdir' should be.-  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi+  let isCoverageEnabled = exeCoverage lbi       distPref = fromFlag $ configDistPref $ configFlags lbi       hpcdir way-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName''         | otherwise = mempty    -- build executables@@ -698,13 +701,13 @@     whenShared  $ copyModuleFiles "dyn_hi"      -- copy the built library files over:-    whenVanilla $ installOrdinary builtDir targetDir       vanillaLibName-    whenProf    $ installOrdinary builtDir targetDir       profileLibName-    whenGHCi    $ installOrdinary builtDir targetDir       ghciLibName-    whenShared  $ installShared   builtDir dynlibTargetDir sharedLibName+    whenVanilla $ installOrdinaryNative builtDir targetDir       vanillaLibName+    whenProf    $ installOrdinaryNative builtDir targetDir       profileLibName+    whenGHCi    $ installOrdinaryNative builtDir targetDir       ghciLibName+    whenShared  $ installSharedNative   builtDir dynlibTargetDir sharedLibName    where-    install isShared srcDir dstDir name = do+    install isShared isJS srcDir dstDir name = do       let src = srcDir </> name           dst = dstDir </> name       createDirectoryIfMissingVerbose verbosity True dstDir@@ -713,14 +716,18 @@         then installExecutableFile verbosity src dst         else installOrdinaryFile   verbosity src dst -      when (stripLibs lbi) $ Strip.stripLib verbosity-                             (hostPlatform lbi) (withPrograms lbi) dst+      when (stripLibs lbi && not isJS) $+        Strip.stripLib verbosity+        (hostPlatform lbi) (withPrograms lbi) dst -    installOrdinary = install False-    installShared   = install True+    installOrdinary = install False True+    installShared   = install True  True +    installOrdinaryNative = install False False+    installSharedNative   = install True  False+     copyModuleFiles ext =-      findModuleFiles [builtDir] [ext] (libModules lib)+      findModuleFiles [builtDir] [ext] (allLibModules lib clbi)       >>= installOrdinaryFiles verbosity targetDir      compiler_id = compilerId (compiler lbi)@@ -730,7 +737,7 @@     ghciLibName    = Internal.mkGHCiLibName uid     sharedLibName  = (mkSharedLibName compiler_id)  uid -    hasLib    = not $ null (libModules lib)+    hasLib    = not $ null (allLibModules lib clbi)                    && null (cSources (libBuildInfo lib))     whenVanilla = when (hasLib && withVanillaLib lbi)     whenProf    = when (hasLib && withProfLib    lbi)@@ -749,12 +756,13 @@            (progprefix, progsuffix) _pkg exe = do   let binDir = bindir installDirs   createDirectoryIfMissingVerbose verbosity True binDir-  let exeFileName = exeName exe-      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix+  let exeName' = unUnqualComponentName $ exeName exe+      exeFileName = exeName'+      fixedExeBaseName = progprefix ++ exeName' ++ progsuffix       installBinary dest = do-        rawSystemProgramConf verbosity ghcjsProgram (withPrograms lbi) $+        runDbProgram verbosity ghcjsProgram (withPrograms lbi) $           [ "--install-executable"-          , buildPref </> exeName exe </> exeFileName+          , buildPref </> exeName' </> exeFileName           , "-o", dest           ] ++           case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of@@ -784,8 +792,9 @@            else error "libAbiHash: Can't find an enabled library way"   --   (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  getProgramInvocationOutput verbosity-    (ghcInvocation ghcjsProg comp platform ghcArgs)+  hash <- getProgramInvocationOutput verbosity+          (ghcInvocation ghcjsProg comp platform ghcArgs)+  return (takeWhile (not . isSpace) hash)  adjustExts :: String -> String -> GhcOptions -> GhcOptions adjustExts hiSuf objSuf opts =@@ -795,7 +804,7 @@   }  registerPackage :: Verbosity-                -> ProgramConfiguration+                -> ProgramDb                 -> HcPkg.MultiInstance                 -> PackageDBStack                 -> InstalledPackageInfo@@ -843,31 +852,31 @@ -- ----------------------------------------------------------------------------- -- Registering -hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo-hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg-                                 , HcPkg.noPkgDbStack    = False-                                 , HcPkg.noVerboseFlag   = False-                                 , HcPkg.flagPackageConf = False-                                 , HcPkg.supportsDirDbs  = True-                                 , HcPkg.requiresDirDbs  = v >= [7,10]-                                 , HcPkg.nativeMultiInstance  = v >= [7,10]-                                 , HcPkg.recacheMultiInstance = True-                                 }+hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo+hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg+                                   , HcPkg.noPkgDbStack    = False+                                   , HcPkg.noVerboseFlag   = False+                                   , HcPkg.flagPackageConf = False+                                   , HcPkg.supportsDirDbs  = True+                                   , HcPkg.requiresDirDbs  = ver >= v7_10+                                   , HcPkg.nativeMultiInstance  = ver >= v7_10+                                   , HcPkg.recacheMultiInstance = True+                                   }   where-    v                 = versionBranch ver-    Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram conf+    v7_10 = mkVersion [7,10]+    Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram progdb     Just ver          = programVersion ghcjsPkgProg  -- | Get the JavaScript file name and command and arguments to run a --   program compiled by GHCJS --   the exe should be the base program name without exe extension-runCmd :: ProgramConfiguration -> FilePath+runCmd :: ProgramDb -> FilePath             -> (FilePath, FilePath, [String])-runCmd conf exe =+runCmd progdb exe =   ( script   , programPath ghcjsProg   , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]   )   where     script = exe <.> "jsexe" </> "all" <.> "js"-    Just ghcjsProg = lookupProgram ghcjsProgram conf+    Just ghcjsProg = lookupProgram ghcjsProgram progdb
cabal/Cabal/Distribution/Simple/Haddock.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}  ----------------------------------------------------------------------------- -- |@@ -22,11 +24,14 @@   haddockPackagePaths   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS  -- local-import Distribution.Compat.Semigroup as Semi+import Distribution.Types.ForeignLib import Distribution.Package import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD hiding (Flag)@@ -50,17 +55,13 @@ import Distribution.Verbosity import Language.Haskell.Extension +import Distribution.Compat.Semigroup (All (..), Any (..)) -import Control.Monad    ( when, forM_ )-import Data.Char        ( isSpace ) import Data.Either      ( rights )-import Data.Foldable    ( traverse_, foldl' )-import Data.Maybe       ( fromMaybe, listToMaybe )-import GHC.Generics     ( Generic )  import System.Directory (doesFileExist)-import System.FilePath  ( (</>), (<.>)-                        , normalise, splitPath, joinPath, isAbsolute )+import System.FilePath  ( (</>), (<.>), normalise, splitPath, joinPath+                        , isAbsolute ) import System.IO        (hClose, hPutStr, hPutStrLn, hSetEncoding, utf8)  -- ------------------------------------------------------------------------------@@ -124,26 +125,28 @@   |    not (hasLibs pkg_descr)     && not (fromFlag $ haddockExecutables haddockFlags)     && not (fromFlag $ haddockTestSuites  haddockFlags)-    && not (fromFlag $ haddockBenchmarks  haddockFlags) =+    && not (fromFlag $ haddockBenchmarks  haddockFlags)+    && not (fromFlag $ haddockForeignLibs haddockFlags)+    =       warn (fromFlag $ haddockVerbosity haddockFlags) $            "No documentation was generated as this package does not contain "-        ++ "a library. Perhaps you want to use the --executables, --tests or"-        ++ " --benchmarks flags."+        ++ "a library. Perhaps you want to use the --executables, --tests,"+        ++ " --benchmarks or --foreign-libraries flags."  haddock pkg_descr lbi suffixes flags' = do     let verbosity     = flag haddockVerbosity         comp          = compiler lbi         platform      = hostPlatform lbi -        flags-          | fromFlag (haddockForHackage flags') = flags'+        flags = case haddockTarget of+          ForDevelopment -> flags'+          ForHackage -> flags'             { haddockHoogle       = Flag True             , haddockHtml         = Flag True             , haddockHtmlLocation = Flag (pkg_url ++ "/docs")             , haddockContents     = Flag (toPathTemplate pkg_url)             , haddockHscolour     = Flag True             }-          | otherwise = flags'         pkg_url       = "/package/$pkg-$version"         flag f        = fromFlag $ f flags @@ -151,18 +154,20 @@                        { optKeepTempFiles = flag haddockKeepTempFiles }         htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation                         $ flags+        haddockTarget =+          fromFlagOrDefault ForDevelopment (haddockForHackage flags')      setupMessage verbosity "Running Haddock for" (packageId pkg_descr)-    (confHaddock, version, _) <-+    (haddockProg, version, _) <-       requireProgramVersion verbosity haddockProgram-        (orLaterVersion (Version [2,0] [])) (withPrograms lbi)+        (orLaterVersion (mkVersion [2,0])) (withPrograms lbi)      -- various sanity checks     when ( flag haddockHoogle-           && version < Version [2,2] []) $+           && version < mkVersion [2,2]) $          die "haddock 2.0 and 2.1 do not support the --hoogle flag." -    haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock+    haddockGhcVersionStr <- getProgramOutput verbosity haddockProg                               ["--ghc-version"]     case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of       (Nothing, _) -> die "Could not get GHC version from Haddock"@@ -178,15 +183,14 @@     -- the tools match the requests, we can proceed      when (flag haddockHscolour) $-      hscolour' (warn verbosity) pkg_descr lbi suffixes+      hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes       (defaultHscolourFlags `mappend` haddockToHscolour flags)      libdirArgs <- getGhcLibDir  verbosity lbi     let commonArgs = mconcat             [ libdirArgs             , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags-            , fromPackageDescription forDist pkg_descr ]-        forDist = fromFlagOrDefault False (haddockForHackage flags)+            , fromPackageDescription haddockTarget pkg_descr ]      withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do       initialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity@@ -196,11 +200,11 @@           Just exe -> do             withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $               \tmp -> do-                exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate-                           version+                exeArgs <- fromExecutable verbosity tmp lbi clbi htmlTemplate+                             version exe                 let exeArgs' = commonArgs `mappend` exeArgs                 runHaddock verbosity tmpFileOpts comp platform-                  confHaddock exeArgs'+                  haddockProg exeArgs'           Nothing -> do            warn (fromFlag $ haddockVerbosity flags)              "Unsupported component, skipping..."@@ -209,17 +213,24 @@         CLib lib -> do           withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $             \tmp -> do-              libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate-                         version+              libArgs <- fromLibrary verbosity tmp lbi clbi htmlTemplate+                           version lib               let libArgs' = commonArgs `mappend` libArgs-              runHaddock verbosity tmpFileOpts comp platform confHaddock libArgs'+              runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs'+        CFLib flib -> do+          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $+            \tmp -> do+              flibArgs <- fromForeignLib verbosity tmp lbi clbi htmlTemplate+                            version flib+              let libArgs' = commonArgs `mappend` flibArgs+              runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs'         CExe   _ -> when (flag haddockExecutables) $ doExe component         CTest  _ -> when (flag haddockTestSuites)  $ doExe component         CBench _ -> when (flag haddockBenchmarks)  $ doExe component -    forM_ (extraDocFiles pkg_descr) $ \ fpath -> do+    for_ (extraDocFiles pkg_descr) $ \ fpath -> do       files <- matchFileGlob fpath-      forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)+      for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)  -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs.@@ -247,11 +258,12 @@       argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags     } -fromPackageDescription :: Bool -> PackageDescription -> HaddockArgs-fromPackageDescription forDist pkg_descr =+fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs+fromPackageDescription haddockTarget pkg_descr =       mempty { argInterfaceFile = Flag $ haddockName pkg_descr,                argPackageName = Flag $ packageId $ pkg_descr,-               argOutputDir = Dir $ "doc" </> "html" </> name,+               argOutputDir = Dir $+                   "doc" </> "html" </> haddockDirName haddockTarget pkg_descr,                argPrologue = Flag $ if null desc then synopsis pkg_descr                                     else desc,                argTitle = Flag $ showPkg ++ subtitle@@ -259,9 +271,6 @@       where         desc = PD.description pkg_descr         showPkg = display (packageId pkg_descr)-        name-          | forDist = showPkg ++ "-docs"-          | otherwise = display (packageName pkg_descr)         subtitle | null (synopsis pkg_descr) = ""                  | otherwise                 = ": " ++ synopsis pkg_descr @@ -277,14 +286,16 @@                        "haddock only supports GHC and GHCJS"   in f verbosity lbi bi clbi odir -fromLibrary :: Verbosity-            -> FilePath-            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo-            -> Maybe PathTemplate -- ^ template for HTML location-            -> Version-            -> IO HaddockArgs-fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do-    inFiles <- map snd `fmap` getLibSourceFiles lbi lib clbi+mkHaddockArgs :: Verbosity+              -> FilePath+              -> LocalBuildInfo+              -> ComponentLocalBuildInfo+              -> Maybe PathTemplate -- ^ template for HTML location+              -> Version+              -> [FilePath]+              -> BuildInfo+              -> IO HaddockArgs+mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate     let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {                           -- Noooooooooo!!!!!111@@ -315,57 +326,59 @@                         (compilerCompatVersion GHC (compiler lbi))      return ifaceArgs {-      argHideModules = (mempty,otherModules $ bi),       argGhcOptions  = toFlag (opts, ghcVersion),       argTargets     = inFiles     }-  where-    bi = libBuildInfo lib +fromLibrary :: Verbosity+            -> FilePath+            -> LocalBuildInfo+            -> ComponentLocalBuildInfo+            -> Maybe PathTemplate -- ^ template for HTML location+            -> Version+            -> Library+            -> IO HaddockArgs+fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do+    inFiles <- map snd `fmap` getLibSourceFiles lbi lib clbi+    args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion+                 inFiles (libBuildInfo lib)+    return args {+      argHideModules = (mempty, otherModules (libBuildInfo lib))+    }+ fromExecutable :: Verbosity                -> FilePath-               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo+               -> LocalBuildInfo+               -> ComponentLocalBuildInfo                -> Maybe PathTemplate -- ^ template for HTML location                -> Version+               -> Executable                -> IO HaddockArgs-fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do+fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do     inFiles <- map snd `fmap` getExeSourceFiles lbi exe clbi-    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate-    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {-                          -- Noooooooooo!!!!!111-                          -- haddock stomps on our precious .hi-                          -- and .o files. Workaround by telling-                          -- haddock to write them elsewhere.-                          ghcOptObjDir  = toFlag tmp,-                          ghcOptHiDir   = toFlag tmp,-                          ghcOptStubDir = toFlag tmp-                      } `mappend` getGhcCppOpts haddockVersion bi-        sharedOpts = vanillaOpts {-                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                         ghcOptFPic        = toFlag True,-                         ghcOptHiSuffix    = toFlag "dyn_hi",-                         ghcOptObjSuffix   = toFlag "dyn_o",-                         ghcOptExtra       =-                           toNubListR $ hcSharedOptions GHC bi-                     }-    opts <- if withVanillaLib lbi-            then return vanillaOpts-            else if withSharedLib lbi-            then return sharedOpts-            else die $ "Must have vanilla or shared libraries "-                       ++ "enabled in order to run haddock"-    ghcVersion <- maybe (die "Compiler has no GHC version")-                        return-                        (compilerCompatVersion GHC (compiler lbi))+    args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate+                 haddockVersion inFiles (buildInfo exe)+    return args {+      argOutputDir  = Dir  $ unUnqualComponentName $ exeName exe,+      argTitle      = Flag $ unUnqualComponentName $ exeName exe+    } -    return ifaceArgs {-      argGhcOptions = toFlag (opts, ghcVersion),-      argOutputDir  = Dir (exeName exe),-      argTitle      = Flag (exeName exe),-      argTargets    = inFiles+fromForeignLib :: Verbosity+               -> FilePath+               -> LocalBuildInfo+               -> ComponentLocalBuildInfo+               -> Maybe PathTemplate -- ^ template for HTML location+               -> Version+               -> ForeignLib+               -> IO HaddockArgs+fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do+    inFiles <- map snd `fmap` getFLibSourceFiles lbi flib clbi+    args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate+                 haddockVersion inFiles (foreignLibBuildInfo flib)+    return args {+      argOutputDir  = Dir  $ unUnqualComponentName $ foreignLibName flib,+      argTitle      = Flag $ unUnqualComponentName $ foreignLibName flib     }-  where-    bi = buildInfo exe  compToExe :: Component -> Maybe Executable compToExe comp =@@ -411,7 +424,7 @@     haddockVersionMacro  = "-D__HADDOCK_VERSION__="                            ++ show (v1 * 1000 + v2 * 10 + v3)       where-        [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]+        [v1, v2, v3] = take 3 $ versionNumbers haddockVersion ++ [0,0]  getGhcLibDir :: Verbosity -> LocalBuildInfo              -> IO HaddockArgs@@ -431,13 +444,13 @@               -> ConfiguredProgram               -> HaddockArgs               -> IO ()-runHaddock verbosity tmpFileOpts comp platform confHaddock args = do+runHaddock verbosity tmpFileOpts comp platform haddockProg args = do   let haddockVersion = fromMaybe (error "unable to determine haddock version")-                       (programVersion confHaddock)+                       (programVersion haddockProg)   renderArgs verbosity tmpFileOpts haddockVersion comp platform args $     \(flags,result)-> do -      rawSystemProgram verbosity confHaddock flags+      runProgram verbosity haddockProg flags        notice verbosity $ "Documentation created: " ++ result @@ -451,8 +464,8 @@               -> (([String], FilePath) -> IO a)               -> IO a renderArgs verbosity tmpFileOpts version comp platform args k = do-  let haddockSupportsUTF8          = version >= Version [2,14,4] []-      haddockSupportsResponseFiles = version >  Version [2,16,2] []+  let haddockSupportsUTF8          = version >= mkVersion [2,14,4]+      haddockSupportsResponseFiles = version >  mkVersion [2,16,2]   createDirectoryIfMissingVerbose verbosity True outputDir   withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $     \prologueFileName h -> do@@ -467,8 +480,13 @@                  withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $                     \responseFileName hf -> do                          when haddockSupportsUTF8 (hSetEncoding hf utf8)-                         hPutStr hf $ unlines $ map escapeArg renderedArgs+                         let responseContents =+                                 unlines $ map escapeArg renderedArgs+                         hPutStr hf responseContents                          hClose hf+                         info verbosity $ responseFileName ++ " contents: <<<"+                         info verbosity responseContents+                         info verbosity $ ">>> " ++ responseFileName                          let respFile = "@" ++ responseFileName                          k ([respFile], result)                else@@ -554,7 +572,7 @@         map (\(i,mh) -> "--read-interface=" ++           maybe "" (++",") mh ++ i)       bool a b c = if c then a else b-      isVersion major minor  = version >= Version [major,minor]  []+      isVersion major minor  = version >= mkVersion [major,minor]       verbosityFlag        | isVersion 2 5 = "--verbosity=1"        | otherwise     = "--verbose"@@ -565,9 +583,9 @@ -- HTML paths, and an optional warning for packages with missing documentation. haddockPackagePaths :: [InstalledPackageInfo]                     -> Maybe (InstalledPackageInfo -> FilePath)-                    -> IO ([(FilePath, Maybe FilePath)], Maybe String)+                    -> NoCallStackIO ([(FilePath, Maybe FilePath)], Maybe String) haddockPackagePaths ipkgs mkHtmlPath = do-  interfaces <- sequence+  interfaces <- sequenceA     [ case interfaceAndHtmlPath ipkg of         Nothing -> return (Left (packageId ipkg))         Just (interface, html) -> do@@ -589,7 +607,7 @@    where     -- Don't warn about missing documentation for these packages. See #1231.-    noHaddockWhitelist = map PackageName [ "rts" ]+    noHaddockWhitelist = map mkPackageName [ "rts" ]      -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.     interfaceAndHtmlPath :: InstalledPackageInfo@@ -642,25 +660,25 @@          -> [PPSuffixHandler]          -> HscolourFlags          -> IO ()-hscolour pkg_descr lbi suffixes flags = do-  hscolour' die pkg_descr lbi suffixes flags+hscolour = hscolour' die ForDevelopment  hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.+          -> HaddockTarget           -> PackageDescription           -> LocalBuildInfo           -> [PPSuffixHandler]           -> HscolourFlags           -> IO ()-hscolour' onNoHsColour pkg_descr lbi suffixes flags =+hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =     either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<       lookupProgramVersion verbosity hscolourProgram-      (orLaterVersion (Version [1,8] [])) (withPrograms lbi)+      (orLaterVersion (mkVersion [1,8])) (withPrograms lbi)   where     go :: ConfiguredProgram -> IO ()     go hscolourProg = do       setupMessage verbosity "Running hscolour for" (packageId pkg_descr)       createDirectoryIfMissingVerbose verbosity True $-        hscolourPref distPref pkg_descr+        hscolourPref haddockTarget distPref pkg_descr        withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do         initialBuildSteps distPref pkg_descr lbi clbi verbosity@@ -668,8 +686,8 @@         let           doExe com = case (compToExe com) of             Just exe -> do-              let outputDir = hscolourPref distPref pkg_descr-                              </> exeName exe </> "src"+              let outputDir = hscolourPref haddockTarget distPref pkg_descr+                              </> unUnqualComponentName (exeName exe) </> "src"               runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe clbi             Nothing -> do               warn (fromFlag $ hscolourVerbosity flags)@@ -677,8 +695,12 @@               return ()         case comp of           CLib lib -> do-            let outputDir = hscolourPref distPref pkg_descr </> "src"+            let outputDir = hscolourPref haddockTarget distPref pkg_descr </> "src"             runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib clbi+          CFLib flib -> do+            let outputDir = hscolourPref haddockTarget distPref pkg_descr+                              </> unUnqualComponentName (foreignLibName flib) </> "src"+            runHsColour hscolourProg outputDir =<< getFLibSourceFiles lbi flib clbi           CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp           CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp           CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp@@ -692,14 +714,14 @@          createDirectoryIfMissingVerbose verbosity True outputDir           case stylesheet of -- copy the CSS file-           Nothing | programVersion prog >= Just (Version [1,9] []) ->-                       rawSystemProgram verbosity prog+           Nothing | programVersion prog >= Just (mkVersion [1,9]) ->+                       runProgram verbosity prog                           ["-print-css", "-o" ++ outputDir </> "hscolour.css"]                    | otherwise -> return ()            Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css") -         forM_ moduleFiles $ \(m, inFile) ->-             rawSystemProgram verbosity prog+         for_ moduleFiles $ \(m, inFile) ->+             runProgram verbosity prog                     ["-css", "-anchor", "-o" ++ outFile m, inFile]         where           outFile m = outputDir </>@@ -712,6 +734,7 @@       hscolourExecutables = haddockExecutables flags,       hscolourTestSuites  = haddockTestSuites  flags,       hscolourBenchmarks  = haddockBenchmarks  flags,+      hscolourForeignLibs = haddockForeignLibs flags,       hscolourVerbosity   = haddockVerbosity   flags,       hscolourDistPref    = haddockDistPref    flags     }@@ -725,8 +748,10 @@ getLibSourceFiles lbi lib clbi = getSourceFiles searchpaths modules   where     bi               = libBuildInfo lib-    modules          = PD.exposedModules lib ++ otherModules bi-    searchpaths      = autogenModulesDir lbi clbi : buildDir lbi : hsSourceDirs bi+    modules          = allLibModules lib clbi+    searchpaths      = componentBuildDir lbi clbi : hsSourceDirs bi +++                     [ autogenComponentModulesDir lbi clbi+                     , autogenPackageModulesDir lbi ]  getExeSourceFiles :: LocalBuildInfo                      -> Executable@@ -739,33 +764,55 @@   where     bi          = buildInfo exe     modules     = otherModules bi-    searchpaths = autogenModulesDir lbi clbi : exeBuildDir lbi exe : hsSourceDirs bi+    searchpaths = autogenComponentModulesDir lbi clbi+                : autogenPackageModulesDir lbi+                : exeBuildDir lbi exe : hsSourceDirs bi +getFLibSourceFiles :: LocalBuildInfo+                   -> ForeignLib+                   -> ComponentLocalBuildInfo+                   -> IO [(ModuleName.ModuleName, FilePath)]+getFLibSourceFiles lbi flib clbi = getSourceFiles searchpaths modules+  where+    bi          = foreignLibBuildInfo flib+    modules     = otherModules bi+    searchpaths = autogenComponentModulesDir lbi clbi+                : autogenPackageModulesDir lbi+                : flibBuildDir lbi flib : hsSourceDirs bi+ getSourceFiles :: [FilePath]                   -> [ModuleName.ModuleName]                   -> IO [(ModuleName.ModuleName, FilePath)]-getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $-    findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m)+getSourceFiles dirs modules = flip traverse modules $ \m -> fmap ((,) m) $+    findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m)       >>= maybe (notFound m) (return . normalise)   where-    notFound module_ = die $ "can't find source for module " ++ display module_+    notFound module_ = die $ "haddock: can't find source for module " ++ display module_  -- | The directory where we put build results for an executable exeBuildDir :: LocalBuildInfo -> Executable -> FilePath-exeBuildDir lbi exe = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"+exeBuildDir lbi exe = buildDir lbi </> nm </> nm ++ "-tmp"+  where+    nm = unUnqualComponentName $ exeName exe +-- | The directory where we put build results for a foreign library+flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath+flibBuildDir lbi flib = buildDir lbi </> nm </> nm ++ "-tmp"+  where+    nm = unUnqualComponentName $ foreignLibName flib+ -- ------------------------------------------------------------------------------ -- Boilerplate Monoid instance. instance Monoid HaddockArgs where     mempty = gmempty-    mappend = (Semi.<>)+    mappend = (<>)  instance Semigroup HaddockArgs where     (<>) = gmappend  instance Monoid Directory where     mempty = Dir "."-    mappend = (Semi.<>)+    mappend = (<>)  instance Semigroup Directory where     Dir m <> Dir n = Dir $ m </> n
cabal/Cabal/Distribution/Simple/HaskellSuite.hs view
@@ -1,15 +1,19 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ module Distribution.Simple.HaskellSuite where -import Control.Monad-import Data.Maybe-import Data.Version-import qualified Data.Map as M (empty)+import Prelude ()+import Distribution.Compat.Prelude +import qualified Data.Map as Map (empty)+ import Distribution.Simple.Program import Distribution.Simple.Compiler as Compiler import Distribution.Simple.Utils import Distribution.Simple.BuildPaths import Distribution.Verbosity+import Distribution.Version import Distribution.Text import Distribution.Package import Distribution.InstalledPackageInfo hiding (includeDirs)@@ -23,8 +27,8 @@  configure   :: Verbosity -> Maybe FilePath -> Maybe FilePath-  -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity mbHcPath hcPkgPath conf0 = do+  -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)+configure verbosity mbHcPath hcPkgPath progdb0 = do    -- We have no idea how a haskell-suite tool is named, so we require at   -- least some information from the user.@@ -35,23 +39,23 @@   when (isJust hcPkgPath) $     warn verbosity "--with-hc-pkg option is ignored for haskell-suite" -  (comp, confdCompiler, conf1) <- configureCompiler hcPath conf0+  (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0    -- Update our pkg tool. It uses the same executable as the compiler, but   -- all command start with "pkg"-  (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram conf1-  let conf2 =+  (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1+  let progdb2 =         updateProgram           confdPkg             { programLocation = programLocation confdCompiler             , programDefaultArgs = ["pkg"]             }-          conf1+          progdb1 -  return (comp, Nothing, conf2)+  return (comp, Nothing, progdb2)    where-    configureCompiler hcPath conf0' = do+    configureCompiler hcPath progdb0' = do       let         haskellSuiteProgram' =           haskellSuiteProgram@@ -60,8 +64,8 @@       -- NB: cannot call requireProgram right away — it'd think that       -- the program is already configured and won't reconfigure it again.       -- Instead, call configureProgram directly first.-      conf1 <- configureProgram verbosity haskellSuiteProgram' conf0'-      (confdCompiler, conf2) <- requireProgram verbosity haskellSuiteProgram' conf1+      progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0'+      (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1        extensions <- getExtensions verbosity confdCompiler       languages  <- getLanguages  verbosity confdCompiler@@ -75,10 +79,10 @@           compilerCompat         = [],           compilerLanguages      = languages,           compilerExtensions     = extensions,-          compilerProperties     = M.empty+          compilerProperties     = Map.empty         } -      return (comp, confdCompiler, conf2)+      return (comp, confdCompiler, progdb2)  hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) hstoolVersion = findProgramVersion "--hspkg-version" id@@ -116,12 +120,12 @@  -- Other compilers do some kind of a packagedb stack check here. Not sure -- if we need something like that as well.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb                      -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs conf =-  liftM (PackageIndex.fromList . concat) $ forM packagedbs $ \packagedb ->+getInstalledPackages verbosity packagedbs progdb =+  liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb ->     do str <--        getDbProgramOutput verbosity haskellSuitePkgProgram conf+        getDbProgramOutput verbosity haskellSuitePkgProgram progdb                 ["dump", packageDbOpt packagedb]          `catchExit` \_ -> die $ "pkg dump failed"        case parsePackages str of@@ -159,13 +163,15 @@       srcDirs = hsSourceDirs bi ++ [odir]       dbStack = withPackageDB lbi       language = fromMaybe Haskell98 (defaultLanguage bi)-      conf = withPrograms lbi+      progdb = withPrograms lbi       pkgid = packageId pkg_descr -  runDbProgram verbosity haskellSuiteProgram conf $+  runDbProgram verbosity haskellSuiteProgram progdb $     [ "compile", "--build-dir", odir ] ++     concat [ ["-i", d] | d <- srcDirs ] ++-    concat [ ["-I", d] | d <- [autogenModulesDir lbi clbi, odir] ++ includeDirs bi ] +++    concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi+                              ,autogenPackageModulesDir lbi+                              ,odir] ++ includeDirs bi ] ++     [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++     [ "--package-name", display pkgid ] ++     concat [ ["--package-id", display ipkgid ]@@ -173,7 +179,7 @@     ["-G", display language] ++     concat [ ["-X", display ex] | ex <- usedExtensions bi ] ++     cppOptions (libBuildInfo lib) ++-    [ display modu | modu <- libModules lib ]+    [ display modu | modu <- allLibModules lib clbi ]   @@ -187,19 +193,19 @@   -> Library   -> ComponentLocalBuildInfo   -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib _clbi = do-  let conf = withPrograms lbi-  runDbProgram verbosity haskellSuitePkgProgram conf $+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do+  let progdb = withPrograms lbi+  runDbProgram verbosity haskellSuitePkgProgram progdb $     [ "install-library"     , "--build-dir", builtDir     , "--target-dir", targetDir     , "--dynlib-target-dir", dynlibTargetDir     , "--package-id", display $ packageId pkg-    ] ++ map display (libModules lib)+    ] ++ map display (allLibModules lib clbi)  registerPackage   :: Verbosity-  -> ProgramConfiguration+  -> ProgramDb   -> PackageDBStack   -> InstalledPackageInfo   -> IO ()@@ -211,9 +217,9 @@       ["update", packageDbOpt $ last packageDbs])       { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo } -initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()-initPackageDB verbosity conf dbPath =-  runDbProgram verbosity haskellSuitePkgProgram conf+initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO ()+initPackageDB verbosity progdb dbPath =+  runDbProgram verbosity haskellSuitePkgProgram progdb     ["init", dbPath]  packageDbOpt :: PackageDB -> String
cabal/Cabal/Distribution/Simple/Hpc.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Hpc@@ -21,8 +24,11 @@     , markupTest     ) where -import Control.Monad ( when )+import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.ModuleName ( main )+import Distribution.Package import Distribution.PackageDescription     ( TestSuite(..)     , testModules@@ -96,22 +102,23 @@            -> TestSuite            -> IO () markupTest verbosity lbi distPref libName suite = do-    tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName suite+    tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'     when tixFileExists $ do         -- behaviour of 'markup' depends on version, so we need *a* version         -- but no particular one         (hpc, hpcVer, _) <- requireProgramVersion verbosity             hpcProgram anyVersion (withPrograms lbi)-        let htmlDir_ = htmlDir distPref way $ testName suite+        let htmlDir_ = htmlDir distPref way testName'         markup hpc hpcVer verbosity-            (tixFilePath distPref way $ testName suite) mixDirs+            (tixFilePath distPref way testName') mixDirs             htmlDir_             (testModules suite ++ [ main ])         notice verbosity $ "Test coverage report written to "                             ++ htmlDir_ </> "hpc_index" <.> "html"   where     way = guessWay lbi-    mixDirs = map (mixDir distPref way) [ testName suite, libName ]+    testName' = unUnqualComponentName $ testName suite+    mixDirs = map (mixDir distPref way) [ testName', libName ]  -- | Generate the HTML markup for all of a package's test suites. markupPackage :: Verbosity@@ -121,8 +128,8 @@               -> [TestSuite]               -> IO () markupPackage verbosity lbi distPref libName suites = do-    let tixFiles = map (tixFilePath distPref way . testName) suites-    tixFilesExist <- mapM doesFileExist tixFiles+    let tixFiles = map (tixFilePath distPref way) testNames+    tixFilesExist <- traverse doesFileExist tixFiles     when (and tixFilesExist) $ do         -- behaviour of 'markup' depends on version, so we need *a* version         -- but no particular one@@ -138,4 +145,5 @@                            ++ htmlDir' </> "hpc_index.html"   where     way = guessWay lbi-    mixDirs = map (mixDir distPref way) $ libName : map testName suites+    testNames = fmap (unUnqualComponentName . testName) suites+    mixDirs = map (mixDir distPref way) $ libName : testNames
cabal/Cabal/Distribution/Simple/Install.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Install@@ -16,8 +19,16 @@         install,   ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.TargetInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.ForeignLib+import Distribution.Types.PackageDescription++import Distribution.Package import Distribution.PackageDescription-import Distribution.Package (Package(..)) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils@@ -26,7 +37,8 @@          , die, info, notice, warn, matchDirFileGlob ) import Distribution.Simple.Compiler          ( CompilerFlavor(..), compilerFlavor )-import Distribution.Simple.Setup (CopyFlags(..), fromFlag)+import Distribution.Simple.Setup+         ( CopyFlags(..), fromFlag, HaddockTarget(ForDevelopment) ) import Distribution.Simple.BuildTarget  import qualified Distribution.Simple.GHC   as GHC@@ -35,12 +47,12 @@ import qualified Distribution.Simple.LHC   as LHC import qualified Distribution.Simple.UHC   as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite+import Distribution.Compat.Graph (IsNode(..)) -import Control.Monad (when, unless) import System.Directory          ( doesDirectoryExist, doesFileExist ) import System.FilePath-         ( takeFileName, takeDirectory, (</>), isAbsolute )+         ( takeFileName, takeDirectory, (</>), isRelative )  import Distribution.Verbosity import Distribution.Text@@ -57,10 +69,30 @@         -> CopyFlags -- ^flags sent to copy or install         -> IO () install pkg_descr lbi flags = do-  let distPref  = fromFlag (copyDistPref flags)-      verbosity = fromFlag (copyVerbosity flags)-      copydest  = fromFlag (copyDest flags)-      -- This is a bit of a hack, to handle files which are not+  checkHasLibsOrExes+  targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags)++  copyPackage verbosity pkg_descr lbi distPref copydest++  -- It's not necessary to do these in build-order, but it's harmless+  withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target ->+    let comp = targetComponent target+        clbi = targetCLBI target+    in copyComponent verbosity pkg_descr lbi comp clbi copydest+ where+  distPref  = fromFlag (copyDistPref flags)+  verbosity = fromFlag (copyVerbosity flags)+  copydest  = fromFlag (copyDest flags)++  checkHasLibsOrExes =+    unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $+      die "No executables and no library found. Nothing to do."++-- | Copy package global files.+copyPackage :: Verbosity -> PackageDescription+            -> LocalBuildInfo -> FilePath -> CopyDest -> IO ()+copyPackage verbosity pkg_descr lbi distPref copydest = do+  let -- This is a bit of a hack, to handle files which are not       -- per-component (data files and Haddock files.)       InstallDirs {          datadir    = dataPref,@@ -80,31 +112,27 @@              -- packages we'll just pick a nondescriptive foo-0.1              = absoluteInstallDirs pkg_descr lbi copydest -  unless (hasLibs pkg_descr || hasExes pkg_descr) $-      die "No executables and no library found. Nothing to do."--  targets <- readBuildTargets pkg_descr (copyArgs flags)-  targets' <- checkBuildTargets verbosity pkg_descr targets-   -- Install (package-global) data files   installDataFiles verbosity pkg_descr dataPref    -- Install (package-global) Haddock files   -- TODO: these should be done per-library-  docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr-  info verbosity ("directory " ++ haddockPref distPref pkg_descr +++  docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr+  info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++                   " does exist: " ++ show docExists) +  -- TODO: this is a bit questionable, Haddock files really should+  -- be per library (when there are convenience libraries.)   when docExists $ do       createDirectoryIfMissingVerbose verbosity True htmlPref       installDirectoryContents verbosity-          (haddockPref distPref pkg_descr) htmlPref+          (haddockPref ForDevelopment distPref pkg_descr) htmlPref       -- setPermissionsRecursive [Read] htmlPref       -- The haddock interface file actually already got installed       -- in the recursive copy, but now we install it where we actually       -- want it to be (normally the same place). We could remove the       -- copy in htmlPref first.-      let haddockInterfaceFileSrc  = haddockPref distPref pkg_descr+      let haddockInterfaceFileSrc  = haddockPref ForDevelopment distPref pkg_descr                                                    </> haddockName pkg_descr           haddockInterfaceFileDest = interfacePref </> haddockName pkg_descr       -- We only generate the haddock interface file for libs, So if the@@ -122,10 +150,7 @@       [ installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)       | lfile <- lfiles ] -  -- It's not necessary to do these in build-order, but it's harmless-  withComponentsInBuildOrder pkg_descr lbi (map fst targets') $ \comp clbi ->-    copyComponent verbosity pkg_descr lbi comp clbi copydest-+-- | Copy files associated with a component. copyComponent :: Verbosity -> PackageDescription               -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo               -> CopyDest@@ -133,18 +158,14 @@ copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do     let InstallDirs{             libdir = libPref,+            dynlibdir = dynlibPref,             includedir = incPref             } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest         buildPref = componentBuildDir lbi clbi-    -- TODO: decide if we need the user to be able to control the libdir-    -- for shared libs independently of the one for static libs. If so-    -- it should also have a flag in the command line UI-    -- For the moment use dynlibdir = libdir-        dynlibPref = libPref -    if componentUnitId clbi == localUnitId lbi-        then notice verbosity ("Installing library in " ++ libPref)-        else notice verbosity ("Installing internal library " ++ libName lib ++ " in " ++ libPref)+    case libName lib of+        Nothing -> notice verbosity ("Installing library in " ++ libPref)+        Just n -> notice verbosity ("Installing internal library " ++ display n ++ " in " ++ libPref)      -- install include files for all compilers - they may be needed to compile     -- haskell files (using the CPP extension)@@ -162,6 +183,20 @@               ++ display (compilerFlavor (compiler lbi))               ++ " is not implemented" +copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do+    let InstallDirs{+            flibdir = flibPref+            } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest+        buildPref = componentBuildDir lbi clbi++    notice verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref)++    case compilerFlavor (compiler lbi) of+      GHC   -> GHC.installFLib   verbosity lbi flibPref buildPref pkg_descr flib+      _ -> die $ "installing foreign lib with "+              ++ display (compilerFlavor (compiler lbi))+              ++ " is not implemented"+ copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do     let installDirs@InstallDirs {             bindir = binPref@@ -172,7 +207,7 @@         uid = componentUnitId clbi         progPrefixPref = substPathTemplate (packageId pkg_descr) lbi uid (progPrefix lbi)         progSuffixPref = substPathTemplate (packageId pkg_descr) lbi uid (progSuffix lbi)-    notice verbosity ("Installing executable " ++ exeName exe ++ " in " ++ binPref)+    notice verbosity ("Installing executable " ++ display (exeName exe) ++ " in " ++ binPref)     inPath <- isInSearchPath binPref     when (not inPath) $       warn verbosity ("The directory " ++ binPref@@ -189,13 +224,14 @@               ++ " is not implemented"  -- Nothing to do for benchmark/testsuite-copyComponent _ _ _ _ _ _ = return ()+copyComponent _ _ _ (CBench _) _ _ = return ()+copyComponent _ _ _ (CTest _) _ _ = return ()  -- | Install the files listed in data-files -- installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () installDataFiles verbosity pkg_descr destDataDir =-  flip mapM_ (dataFiles pkg_descr) $ \ file -> do+  flip traverse_ (dataFiles pkg_descr) $ \ file -> do     let srcDataDir = dataDir pkg_descr     files <- matchDirFileGlob srcDataDir file     let dir = takeDirectory file@@ -208,9 +244,9 @@ -- installIncludeFiles :: Verbosity -> Library -> FilePath -> IO () installIncludeFiles verbosity lib destIncludeDir = do-    let relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)+    let relincdirs = "." : filter isRelative (includeDirs lbi)         lbi = libBuildInfo lib-    incs <- mapM (findInc relincdirs) (installIncludes lbi)+    incs <- traverse (findInc relincdirs) (installIncludes lbi)     sequence_       [ do createDirectoryIfMissingVerbose verbosity True destDir            installOrdinaryFile verbosity srcFile destFile
cabal/Cabal/Distribution/Simple/InstallDirs.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}  ----------------------------------------------------------------------------- -- |@@ -25,6 +26,7 @@         InstallDirs(..),         InstallDirTemplates,         defaultInstallDirs,+        defaultInstallDirs',         combineInstallDirs,         absoluteInstallDirs,         CopyDest(..),@@ -45,22 +47,20 @@         installDirsTemplateEnv,   ) where +import Prelude ()+import Distribution.Compat.Prelude -import Distribution.Compat.Binary (Binary)-import Distribution.Compat.Semigroup as Semi import Distribution.Package import Distribution.System import Distribution.Compiler import Distribution.Text -import Data.List (isPrefixOf)-import Data.Maybe (fromMaybe)-import GHC.Generics (Generic) import System.Directory (getAppUserDataDirectory) import System.FilePath ((</>), isPathSeparator, pathSeparator) import System.FilePath (dropDrive) -#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS+import qualified Prelude import Foreign import Foreign.C #endif@@ -82,6 +82,7 @@         libdir       :: dir,         libsubdir    :: dir,         dynlibdir    :: dir,+        flibdir      :: dir, -- ^ foreign libraries         libexecdir   :: dir,         includedir   :: dir,         datadir      :: dir,@@ -97,7 +98,7 @@  instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup dir => Semigroup (InstallDirs dir) where   (<>) = gmappend@@ -112,6 +113,7 @@     libdir       = libdir a     `combine` libdir b,     libsubdir    = libsubdir a  `combine` libsubdir b,     dynlibdir    = dynlibdir a  `combine` dynlibdir b,+    flibdir      = flibdir a    `combine` flibdir b,     libexecdir   = libexecdir a `combine` libexecdir b,     includedir   = includedir a `combine` includedir b,     datadir      = datadir a    `combine` datadir b,@@ -159,7 +161,17 @@ -- Default installation directories  defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates-defaultInstallDirs comp userInstall _hasLibs = do+defaultInstallDirs = defaultInstallDirs' False++defaultInstallDirs' :: Bool {- use external internal deps -}+                    -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates+defaultInstallDirs' True comp userInstall hasLibs = do+  dflt <- defaultInstallDirs' False comp userInstall hasLibs+  -- Be a bit more hermetic about per-component installs+  return dflt { datasubdir = toPathTemplate $ "$abi" </> "$libname",+                docdir     = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"+              }+defaultInstallDirs' False comp userInstall _hasLibs = do   installPrefix <-       if userInstall       then getAppUserDataDirectory "cabal"@@ -182,7 +194,12 @@            LHC    -> "$compiler"            UHC    -> "$pkgid"            _other -> "$abi" </> "$libname",-      dynlibdir    = "$libdir",+      dynlibdir    = "$libdir" </> case comp of+           JHC    -> "$compiler"+           LHC    -> "$compiler"+           UHC    -> "$pkgid"+           _other -> "$abi",+      flibdir      = "$libdir",       libexecdir   = case buildOS of         Windows   -> "$prefix" </> "$libname"         _other    -> "$prefix" </> "libexec",@@ -224,6 +241,7 @@       libdir     = subst libdir     [prefixVar, bindirVar],       libsubdir  = subst libsubdir  [],       dynlibdir  = subst dynlibdir  [prefixVar, bindirVar, libdirVar],+      flibdir    = subst flibdir    [prefixVar, bindirVar, libdirVar],       libexecdir = subst libexecdir prefixBinLibVars,       includedir = subst includedir prefixBinLibVars,       datadir    = subst datadir    prefixBinLibVars,@@ -331,6 +349,7 @@      | BindirVar     -- ^ The @$bindir@ path variable      | LibdirVar     -- ^ The @$libdir@ path variable      | LibsubdirVar  -- ^ The @$libsubdir@ path variable+     | DynlibdirVar  -- ^ The @$dynlibdir@ path variable      | DatadirVar    -- ^ The @$datadir@ path variable      | DatasubdirVar -- ^ The @$datasubdir@ path variable      | DocdirVar     -- ^ The @$docdir@ path variable@@ -358,7 +377,7 @@ -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. -- toPathTemplate :: FilePath -> PathTemplate-toPathTemplate = PathTemplate . read+toPathTemplate = PathTemplate . read -- TODO: eradicateNoParse  -- | Convert back to a path, any remaining vars are included --@@ -392,10 +411,12 @@   ++ abiTemplateEnv compiler platform  packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv-packageTemplateEnv pkgId libname =+packageTemplateEnv pkgId uid =   [(PkgNameVar,  PathTemplate [Ordinary $ display (packageName pkgId)])   ,(PkgVerVar,   PathTemplate [Ordinary $ display (packageVersion pkgId)])-  ,(LibNameVar,  PathTemplate [Ordinary $ display libname])+  -- Invariant: uid is actually a HashedUnitId.  Hard to enforce because+  -- it's an API change.+  ,(LibNameVar,  PathTemplate [Ordinary $ display uid])   ,(PkgIdVar,    PathTemplate [Ordinary $ display pkgId])   ] @@ -426,6 +447,7 @@   ,(BindirVar,     bindir     dirs)   ,(LibdirVar,     libdir     dirs)   ,(LibsubdirVar,  libsubdir  dirs)+  ,(DynlibdirVar,  dynlibdir  dirs)   ,(DatadirVar,    datadir    dirs)   ,(DatasubdirVar, datasubdir dirs)   ,(DocdirVar,     docdir     dirs)@@ -448,6 +470,7 @@   show BindirVar     = "bindir"   show LibdirVar     = "libdir"   show LibsubdirVar  = "libsubdir"+  show DynlibdirVar  = "dynlibdir"   show DatadirVar    = "datadir"   show DatasubdirVar = "datasubdir"   show DocdirVar     = "docdir"@@ -476,6 +499,7 @@                  ,("bindir",     BindirVar)                  ,("libdir",     LibdirVar)                  ,("libsubdir",  LibsubdirVar)+                 ,("dynlibdir",  DynlibdirVar)                  ,("datadir",    DatadirVar)                  ,("datasubdir", DatasubdirVar)                  ,("docdir",     DocdirVar)@@ -531,17 +555,17 @@ -- --------------------------------------------------------------------------- -- Internal utilities -getWindowsProgramFilesDir :: IO FilePath+getWindowsProgramFilesDir :: NoCallStackIO FilePath getWindowsProgramFilesDir = do-#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS   m <- shGetFolderPath csidl_PROGRAM_FILES #else   let m = Nothing #endif   return (fromMaybe "C:\\Program Files" m) -#if mingw32_HOST_OS-shGetFolderPath :: CInt -> IO (Maybe FilePath)+#ifdef mingw32_HOST_OS+shGetFolderPath :: CInt -> NoCallStackIO (Maybe FilePath) shGetFolderPath n =   allocaArray long_path_size $ \pPath -> do      r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath@@ -568,5 +592,5 @@                               -> Ptr ()                               -> CInt                               -> CWString-                              -> IO CInt+                              -> Prelude.IO CInt #endif
cabal/Cabal/Distribution/Simple/JHC.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.JHC@@ -16,6 +19,9 @@         installLib, installExe  ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.PackageDescription as PD hiding (Flag) import Distribution.InstalledPackageInfo import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo@@ -37,9 +43,7 @@     ( readP_to_S, string, skipSpaces ) import Distribution.System ( Platform ) -import Data.List                ( nub )-import Data.Char                ( isSpace )-import qualified Data.Map as M  ( empty )+import qualified Data.Map as Map  ( empty )  import qualified Data.ByteString.Lazy.Char8 as BS.Char8 @@ -48,12 +52,12 @@ -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do+          -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)+configure verbosity hcPath _hcPkgPath progdb = do -  (jhcProg, _, conf') <- requireProgramVersion verbosity-                           jhcProgram (orLaterVersion (Version [0,7,2] []))-                           (userMaybeSpecifyPath "jhc" hcPath conf)+  (jhcProg, _, progdb') <- requireProgramVersion verbosity+                           jhcProgram (orLaterVersion (mkVersion [0,7,2]))+                           (userMaybeSpecifyPath "jhc" hcPath progdb)    let Just version = programVersion jhcProg       comp = Compiler {@@ -62,10 +66,10 @@         compilerCompat         = [],         compilerLanguages      = jhcLanguages,         compilerExtensions     = jhcLanguageExtensions,-        compilerProperties     = M.empty+        compilerProperties     = Map.empty       }       compPlatform = Nothing-  return (comp, compPlatform, conf')+  return (comp, compPlatform, progdb')  jhcLanguages :: [(Language, Flag)] jhcLanguages = [(Haskell98, "")]@@ -83,13 +87,13 @@     ,(DisableExtension CPP                        , "-fno-cpp")     ] -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb                     -> IO InstalledPackageIndex-getInstalledPackages verbosity _packageDBs conf = do+getInstalledPackages verbosity _packageDBs progdb = do    -- jhc --list-libraries lists all available libraries.    -- How shall I find out, whether they are global or local    -- without checking all files and locations?-   str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"]+   str <- getDbProgramOutput verbosity jhcProgram progdb ["--list-libraries"]    let pCheck :: [(a, String)] -> [a]        pCheck rs = [ r | (r,s) <- rs, all isSpace s ]    let parseLine ln =@@ -119,9 +123,9 @@       pfile = buildDir lbi </> "jhc-pkg.conf"       hlfile= buildDir lbi </> (pkgid ++ ".hl")   writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr-  rawSystemProgram verbosity jhcProg $+  runProgram verbosity jhcProg $      ["--build-hl="++pfile, "-o", hlfile] ++-     args ++ map display (libModules lib)+     args ++ map display (allLibModules lib clbi)  -- | Building an executable for JHC. -- Currently C source files are not supported.@@ -130,9 +134,9 @@ buildExe verbosity _pkg_descr lbi exe clbi = do   let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi)   let exeBi = buildInfo exe-  let out   = buildDir lbi </> exeName exe+  let out   = buildDir lbi </> display (exeName exe)   let args  = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity-  rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe])+  runProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe])  constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo                     -> FilePath -> Verbosity -> [String]@@ -143,7 +147,8 @@      ++ extensionsToFlags (compiler lbi) (usedExtensions bi)      ++ ["--noauto","-i-"]      ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)]-     ++ ["-i", autogenModulesDir lbi clbi]+     ++ ["-i", autogenComponentModulesDir lbi clbi]+     ++ ["-i", autogenPackageModulesDir lbi]      ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]      -- It would be better if JHC would accept package names with versions,      -- but JHC-0.7.2 doesn't accept this.@@ -154,10 +159,9 @@ jhcPkgConf :: PackageDescription -> String jhcPkgConf pd =   let sline name sel = name ++ ": "++sel pd-      lib pd' = case libraries pd' of-                [lib'] -> lib'-                [] -> error "no library available"-                _ -> error "JHC does not support multiple libraries (yet)"+      lib pd' = case library pd' of+                Just lib' -> lib'+                Nothing -> error "no library available"       comma = intercalate "," . map display   in unlines [sline "name" (display . pkgName . packageId)              ,sline "version" (display . pkgVersion . packageId)@@ -181,7 +185,7 @@  installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () installExe verb dest build_dir (progprefix,progsuffix) _ exe = do-    let exe_name = exeName exe+    let exe_name = display $ exeName exe         src = exe_name </> exeExtension         out   = (progprefix ++ exe_name ++ progsuffix) </> exeExtension     createDirectoryIfMissingVerbose verb True dest
cabal/Cabal/Distribution/Simple/LHC.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.LHC@@ -40,6 +43,9 @@         ghcVerbosityOptions  ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.PackageDescription as PD hiding (Flag) import Distribution.InstalledPackageInfo import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo@@ -60,11 +66,7 @@ import Distribution.System import Language.Haskell.Extension -import Control.Monad            ( unless, when )-import Data.Monoid as Mon-import Data.List-import qualified Data.Map as M  ( empty )-import Data.Maybe               ( catMaybes )+import qualified Data.Map as Map ( empty ) import System.Directory         ( removeFile, renameFile,                                   getDirectoryContents, doesFileExist,                                   getTemporaryDirectory )@@ -76,18 +78,18 @@ -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath hcPkgPath conf = do+          -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)+configure verbosity hcPath hcPkgPath progdb = do -  (lhcProg, lhcVersion, conf') <-+  (lhcProg, lhcVersion, progdb') <-     requireProgramVersion verbosity lhcProgram-      (orLaterVersion (Version [0,7] []))-      (userMaybeSpecifyPath "lhc" hcPath conf)+      (orLaterVersion (mkVersion [0,7]))+      (userMaybeSpecifyPath "lhc" hcPath progdb) -  (lhcPkgProg, lhcPkgVersion, conf'') <-+  (lhcPkgProg, lhcPkgVersion, progdb'') <-     requireProgramVersion verbosity lhcPkgProgram-      (orLaterVersion (Version [0,7] []))-      (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf')+      (orLaterVersion (mkVersion [0,7]))+      (userMaybeSpecifyPath "lhc-pkg" hcPkgPath progdb')    when (lhcVersion /= lhcPkgVersion) $ die $        "Version mismatch between lhc and lhc-pkg: "@@ -103,16 +105,16 @@         compilerCompat         = [],         compilerLanguages      = languages,         compilerExtensions     = extensions,-        compilerProperties     = M.empty+        compilerProperties     = Map.empty       }-      conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld+      progdb''' = configureToolchain lhcProg progdb'' -- configure gcc and ld       compPlatform = Nothing-  return (comp, compPlatform, conf''')+  return (comp, compPlatform, progdb''')  -- | Adjust the way we find and configure gcc and ld ---configureToolchain :: ConfiguredProgram -> ProgramConfiguration-                                        -> ProgramConfiguration+configureToolchain :: ConfiguredProgram -> ProgramDb+                                        -> ProgramDb configureToolchain lhcProg =     addKnownProgram gccProgram {       programFindLocation = findProg gccProgram (baseDir </> "gcc.exe"),@@ -140,7 +142,7 @@                           programFindLocation prog verbosity searchpath       | otherwise = programFindLocation prog -    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureGcc :: Verbosity -> ConfiguredProgram -> NoCallStackIO ConfiguredProgram     configureGcc       | isWindows = \_ gccProg -> case programLocation gccProg of           -- if it's found on system then it means we're using the result@@ -162,12 +164,12 @@              withTempFile tempDir ".o" $ \testofile testohnd -> do                hPutStrLn testchnd "int foo() { return 0; }"                hClose testchnd; hClose testohnd-               rawSystemProgram verbosity lhcProg ["-c", testcfile,+               runProgram verbosity lhcProg ["-c", testcfile,                                                    "-o", testofile]                withTempFile tempDir ".o" $ \testofile' testohnd' ->                  do                    hClose testohnd'-                   _ <- rawSystemProgramStdout verbosity ldProg+                   _ <- getProgramOutput verbosity ldProg                      ["-x", "-r", testofile, "-o", testofile']                    return True                  `catchIO`   (\_ -> return False)@@ -176,7 +178,7 @@         then return ldProg { programDefaultArgs = ["-x"] }         else return ldProg -getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]+getLanguages :: Verbosity -> ConfiguredProgram -> NoCallStackIO [(Language, Flag)] getLanguages _ _ = return [(Haskell98, "")] --FIXME: does lhc support -XHaskell98 flag? from what version? @@ -194,21 +196,21 @@     return $ [ (ext, "-X" ++ display ext)              | Just ext <- map readExtension (lines exts) ] -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb                      -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs conf = do+getInstalledPackages verbosity packagedbs progdb = do   checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf+  pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs progdb   let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)                 | (_, pkgs) <- pkgss ]-  return $! (Mon.mconcat indexes)+  return $! (mconcat indexes)    where     -- On Windows, various fields have $topdir/foo rather than full     -- paths. We need to substitute the right value in so that when     -- we, for example, call gcc, we have proper paths to give it-    Just ghcProg = lookupProgram lhcProgram conf-    Just lhcPkg  = lookupProgram lhcPkgProgram conf+    Just ghcProg = lookupProgram lhcProgram progdb+    Just lhcPkg  = lookupProgram lhcPkgProgram progdb     compilerDir  = takeDirectory (programPath ghcProg)     topDir       = takeDirectory compilerDir @@ -222,12 +224,12 @@ -- | Get the packages from specific PackageDBs, not cumulative. -- getInstalledPackages' :: ConfiguredProgram -> Verbosity-                      -> [PackageDB] -> ProgramConfiguration+                      -> [PackageDB] -> ProgramDb                       -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' lhcPkg verbosity packagedbs conf+getInstalledPackages' lhcPkg verbosity packagedbs progdb   =-  sequence-    [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf+  sequenceA+    [ do str <- getDbProgramOutput verbosity lhcPkgProgram progdb                   ["dump", packageDbGhcPkgFlag packagedb]            `catchExit` \_ -> die $ "ghc-pkg dump failed"          case parsePackages str of@@ -256,7 +258,7 @@     packageDbGhcPkgFlag (SpecificPackageDB path) = "--" ++ packageDbFlag ++ "=" ++ path      packageDbFlag-      | programVersion lhcPkg < Just (Version [7,5] [])+      | programVersion lhcPkg < Just (mkVersion [7,5])       = "package-conf"       | otherwise       = "package-db"@@ -292,7 +294,7 @@   let lib_name = componentUnitId clbi       pref = componentBuildDir lbi clbi       pkgid = packageId pkg_descr-      runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)+      runGhcProg = runDbProgram verbosity lhcProgram (withPrograms lbi)       ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)       ifProfLib = when (withProfLib lbi)       ifSharedLib = when (withSharedLib lbi)@@ -310,7 +312,7 @@   let ghcArgs =              ["-package-name", display pkgid ]           ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity-          ++ map display (libModules lib)+          ++ map display (allLibModules lib clbi)       lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x]       ghcArgsProf = ghcArgs           ++ ["-prof",@@ -324,7 +326,7 @@               "-osuf", "dyn_o", "-fPIC"              ]           ++ hcSharedOptions GHC libBi-  unless (null (libModules lib)) $+  unless (null (allLibModules lib clbi)) $     do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs)        ifProfLib (runGhcProg $ lhcWrap ghcArgsProf)        ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared)@@ -349,29 +351,29 @@       sharedLibFilePath  = libTargetDir </> mkSharedLibName cid lib_name       ghciLibFilePath    = libTargetDir </> mkGHCiLibName       lib_name -  stubObjs <- fmap catMaybes $ sequence+  stubObjs <- fmap catMaybes $ sequenceA     [ findFileWithExtension [objExtension] [libTargetDir]         (ModuleName.toFilePath x ++"_stub")-    | x <- libModules lib ]-  stubProfObjs <- fmap catMaybes $ sequence+    | x <- allLibModules lib clbi ]+  stubProfObjs <- fmap catMaybes $ sequenceA     [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]         (ModuleName.toFilePath x ++"_stub")-    | x <- libModules lib ]-  stubSharedObjs <- fmap catMaybes $ sequence+    | x <- allLibModules lib clbi ]+  stubSharedObjs <- fmap catMaybes $ sequenceA     [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]         (ModuleName.toFilePath x ++"_stub")-    | x <- libModules lib ]+    | x <- allLibModules lib clbi ] -  hObjs     <- getHaskellObjects lib lbi+  hObjs     <- getHaskellObjects lib lbi clbi                     pref objExtension True   hProfObjs <-     if (withProfLib lbi)-            then getHaskellObjects lib lbi+            then getHaskellObjects lib lbi clbi                     pref ("p_" ++ objExtension) True             else return []   hSharedObjs <-     if (withSharedLib lbi)-            then getHaskellObjects lib lbi+            then getHaskellObjects lib lbi clbi                     pref ("dyn_" ++ objExtension) False             else return [] @@ -427,11 +429,11 @@             -- output goes to <ldLibName>.tmp, and any existing file             -- named <ldLibName> is included when linking. The             -- output is renamed to <lib_name>.-          rawSystemProgramConf verbosity ldProgram (withPrograms lbi)+          runDbProgram verbosity ldProgram (withPrograms lbi)             (args ++ if exists then [ldLibName] else [])           renameFile (ldLibName <.> "tmp") ldLibName -        runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi)+        runAr = runDbProgram verbosity arProgram (withPrograms lbi)           --TODO: discover this at configure time or runtime on Unix          -- The value is 32k on Windows and POSIX specifies a minimum of 4k@@ -457,18 +459,19 @@                       -> Executable         -> ComponentLocalBuildInfo -> IO () buildExe verbosity _pkg_descr lbi   exe@Executable { exeName = exeName', modulePath = modPath } clbi = do+  let exeName'' = unUnqualComponentName exeName'   let pref = buildDir lbi-      runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)+      runGhcProg = runDbProgram verbosity lhcProgram (withPrograms lbi)    exeBi <- hackThreadedFlag verbosity              (compiler lbi) (withProfExe lbi) (buildInfo exe)    -- exeNameReal, the name that GHC really uses (with .exe on Windows)-  let exeNameReal = exeName' <.>-                    (if null $ takeExtension exeName' then exeExtension else "")+  let exeNameReal = exeName'' <.>+                    (if null $ takeExtension exeName'' then exeExtension else "") -  let targetDir = pref </> exeName'-  let exeDir    = targetDir </> (exeName' ++ "-tmp")+  let targetDir = pref </> exeName''+  let exeDir    = targetDir </> (exeName'' ++ "-tmp")   createDirectoryIfMissingVerbose verbosity True targetDir   createDirectoryIfMissingVerbose verbosity True exeDir   -- TODO: do we need to put hs-boot files into place for mutually recursive modules?@@ -525,7 +528,7 @@                   ++ "profiling in ghc-6.8 and older. It will be disabled."     return bi { options = filterHcOptions (/= "-threaded") (options bi) }   where-    mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] []+    mustFilterThreaded = prof && compilerVersion comp < mkVersion [6, 10]                       && "-threaded" `elem` hcOptions GHC bi     filterHcOptions p hcoptss =       [ (hc, if hc == GHC then filter p opts else opts)@@ -533,13 +536,13 @@  -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module.-getHaskellObjects :: Library -> LocalBuildInfo-                  -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs+getHaskellObjects :: Library -> LocalBuildInfo -> ComponentLocalBuildInfo+                  -> FilePath -> String -> Bool -> NoCallStackIO [FilePath]+getHaskellObjects lib lbi clbi pref wanted_obj_ext allow_split_objs   | splitObjs lbi && allow_split_objs = do         let dirs = [ pref </> (ModuleName.toFilePath x ++ "_split")-                   | x <- libModules lib ]-        objss <- mapM getDirectoryContents dirs+                   | x <- allLibModules lib clbi ]+        objss <- traverse getDirectoryContents dirs         let objs = [ dir </> obj                    | (objs',dir) <- zip objss dirs, obj <- objs',                      let obj_ext = takeExtension obj,@@ -547,7 +550,7 @@         return objs   | otherwise  =         return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext-               | x <- libModules lib ]+               | x <- allLibModules lib clbi ]   constructGHCCmdLine@@ -578,15 +581,17 @@      ++ ["-i"]      ++ ["-i" ++ odir]      ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]-     ++ ["-i" ++ autogenModulesDir lbi clbi]-     ++ ["-I" ++ autogenModulesDir lbi clbi]+     ++ ["-i" ++ autogenComponentModulesDir lbi clbi]+     ++ ["-i" ++ autogenPackageModulesDir lbi]+     ++ ["-I" ++ autogenComponentModulesDir lbi clbi]+     ++ ["-I" ++ autogenPackageModulesDir lbi]      ++ ["-I" ++ odir]      ++ ["-I" ++ dir | dir <- PD.includeDirs bi]      ++ ["-optP" ++ opt | opt <- cppOptions bi]-     ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi clbi </> cppHeaderName) ]+     ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi </> cppHeaderName) ]      ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ]      ++ [ "-odir",  odir, "-hidir", odir ]-     ++ (if compilerVersion c >= Version [6,8] []+     ++ (if compilerVersion c >= mkVersion [6,8]            then ["-stubdir", odir] else [])      ++ ghcPackageFlags lbi clbi      ++ (case withOptimization lbi of@@ -600,7 +605,7 @@  ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] ghcPackageFlags lbi clbi-  | ghcVer >= Version [6,11] []+  | ghcVer >= mkVersion [6,11]               = concat [ ["-package-id", display ipkgid]                        | (ipkgid, _) <- componentPackageDeps clbi ] @@ -622,7 +627,7 @@      dbstack = withPackageDB lbi     packageDbFlag-      | compilerVersion (compiler lbi) < Version [7,5] []+      | compilerVersion (compiler lbi) < mkVersion [7,5]       = "package-conf"       | otherwise       = "package-db"@@ -630,7 +635,7 @@ constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo                    -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) constructCcCmdLine lbi bi clbi pref filename verbosity-  =  let odir | compilerVersion (compiler lbi) >= Version [6,4,1] []  = pref+  =  let odir | compilerVersion (compiler lbi) >= mkVersion [6,4,1] = pref               | otherwise = pref </> takeDirectory filename                         -- ghc 6.4.1 fixed a bug in -odir handling                         -- for C compilations.@@ -671,11 +676,11 @@ installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do   let binDir = bindir installDirs   createDirectoryIfMissingVerbose verbosity True binDir-  let exeFileName = exeName exe <.> exeExtension-      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix+  let exeFileName = unUnqualComponentName (exeName exe) <.> exeExtension+      fixedExeBaseName = progprefix ++ unUnqualComponentName (exeName exe) ++ progsuffix       installBinary dest = do           installExecutableFile verbosity-            (buildPref </> exeName exe </> exeFileName)+            (buildPref </> unUnqualComponentName (exeName exe) </> exeFileName)             (dest <.> exeExtension)           stripExe verbosity lbi exeFileName (dest <.> exeExtension)   installBinary (binDir </> fixedExeBaseName)@@ -683,7 +688,7 @@ stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () stripExe verbosity lbi name path = when (stripExes lbi) $   case lookupProgram stripProgram (withPrograms lbi) of-    Just strip -> rawSystemProgram verbosity strip args+    Just strip -> runProgram verbosity strip args     Nothing    -> unless (buildOS == Windows) $                   -- Don't bother warning on windows, we don't expect them to                   -- have the strip program anyway.@@ -713,12 +718,12 @@         createDirectoryIfMissingVerbose verbosity True dst         installOrdinaryFile verbosity (src </> n) (dst </> n)       copyModuleFiles ext =-        findModuleFiles [builtDir] [ext] (libModules lib)+        findModuleFiles [builtDir] [ext] (allLibModules lib clbi)           >>= installOrdinaryFiles verbosity targetDir   ifVanilla $ copyModuleFiles "hi"   ifProf    $ copyModuleFiles "p_hi"-  hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib)-  flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]+  hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (allLibModules lib clbi)+  flip traverse_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]    -- copy the built library files over:   ifVanilla $ copy builtDir targetDir       vanillaLibName@@ -734,21 +739,21 @@     ghciLibName    = mkGHCiLibName       lib_name     sharedLibName  = mkSharedLibName cid lib_name -    hasLib    = not $ null (libModules lib)+    hasLib    = not $ null (allLibModules lib clbi)                    && null (cSources (libBuildInfo lib))     ifVanilla = when (hasLib && withVanillaLib lbi)     ifProf    = when (hasLib && withProfLib    lbi)     ifGHCi    = when (hasLib && withGHCiLib    lbi)     ifShared  = when (hasLib && withSharedLib  lbi) -    runLhc    = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)+    runLhc    = runDbProgram verbosity lhcProgram (withPrograms lbi)  -- ----------------------------------------------------------------------------- -- Registering  registerPackage   :: Verbosity-  -> ProgramConfiguration+  -> ProgramDb   -> PackageDBStack   -> InstalledPackageInfo   -> IO ()@@ -756,15 +761,15 @@   HcPkg.reregister (hcPkgInfo progdb) verbosity packageDbs     (Right installedPkgInfo) -hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo-hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = lhcPkgProg-                                 , HcPkg.noPkgDbStack    = False-                                 , HcPkg.noVerboseFlag   = False-                                 , HcPkg.flagPackageConf = False-                                 , HcPkg.supportsDirDbs  = True-                                 , HcPkg.requiresDirDbs  = True-                                 , HcPkg.nativeMultiInstance  = False -- ?-                                 , HcPkg.recacheMultiInstance = False -- ?-                                 }+hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo+hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = lhcPkgProg+                                   , HcPkg.noPkgDbStack    = False+                                   , HcPkg.noVerboseFlag   = False+                                   , HcPkg.flagPackageConf = False+                                   , HcPkg.supportsDirDbs  = True+                                   , HcPkg.requiresDirDbs  = True+                                   , HcPkg.nativeMultiInstance  = False -- ?+                                   , HcPkg.recacheMultiInstance = False -- ?+                                   }   where-    Just lhcPkgProg = lookupProgram lhcPkgProgram conf+    Just lhcPkgProg = lookupProgram lhcPkgProgram progdb
cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}  ----------------------------------------------------------------------------- -- |@@ -32,33 +33,30 @@         showComponentName,         componentNameString,         ComponentLocalBuildInfo(..),-        getLocalComponent,-        componentComponentId,         componentBuildDir,         foldComponent,         componentName,         componentBuildInfo,-        componentEnabled,-        componentDisabledReason,-        ComponentDisabledReason(..),+        componentBuildable,         pkgComponents,-        pkgEnabledComponents,+        pkgBuildableComponents,         lookupComponent,         getComponent,-        maybeGetDefaultLibraryLocalBuildInfo,-        maybeGetComponentLocalBuildInfo,         getComponentLocalBuildInfo,         allComponentsInBuildOrder,         componentsInBuildOrder,-        checkComponentsCyclic,         depLibraryPaths,+        allLibModules,          withAllComponentsInBuildOrder,         withComponentsInBuildOrder,         withComponentsLBI,         withLibLBI,         withExeLBI,+        withBenchLBI,         withTestLBI,+        enabledTestLBIs,+        enabledBenchLBIs,          -- * Installation directories         module Distribution.Simple.InstallDirs,@@ -67,385 +65,119 @@         substPathTemplate   ) where +import Prelude ()+import Distribution.Compat.Prelude +import Distribution.Types.Component+import Distribution.Types.ComponentName+import Distribution.Types.PackageDescription+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo+ import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,                                                prefixRelativeInstallDirs,                                                substPathTemplate, ) import qualified Distribution.Simple.InstallDirs as InstallDirs-import Distribution.Simple.Program import Distribution.PackageDescription import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package+import Distribution.ModuleName import Distribution.Simple.Compiler import Distribution.Simple.PackageIndex-import Distribution.Simple.Setup import Distribution.Simple.Utils import Distribution.Text-import Distribution.System+import qualified Distribution.Compat.Graph as Graph -import Data.Array ((!))-import Distribution.Compat.Binary (Binary)-import Data.Graph-import Data.List (nub, find, stripPrefix)-import Data.Maybe-import Data.Tree  (flatten)-import GHC.Generics (Generic)+import Data.List (stripPrefix) import System.FilePath+import qualified Data.Map as Map  import System.Directory (doesDirectoryExist, canonicalizePath) --- | Data cached after configuration step.  See also--- 'Distribution.Simple.Setup.ConfigFlags'.-data LocalBuildInfo = LocalBuildInfo {-        configFlags   :: ConfigFlags,-        -- ^ Options passed to the configuration step.-        -- Needed to re-run configuration when .cabal is out of date-        flagAssignment :: FlagAssignment,-        -- ^ The final set of flags which were picked for this package-        extraConfigArgs     :: [String],-        -- ^ Extra args on the command line for the configuration step.-        -- Needed to re-run configuration when .cabal is out of date-        installDirTemplates :: InstallDirTemplates,-                -- ^ The installation directories for the various different-                -- kinds of files-        --TODO: inplaceDirTemplates :: InstallDirs FilePath-        compiler      :: Compiler,-                -- ^ The compiler we're building with-        hostPlatform  :: Platform,-                -- ^ The platform we're building for-        buildDir      :: FilePath,-                -- ^ Where to build the package.-        componentsConfigs   :: [(ComponentLocalBuildInfo, [UnitId])],-                -- ^ All the components to build, ordered by topological-                -- sort, and with their INTERNAL dependencies over the-                -- intrapackage dependency graph.-                -- TODO: this is assumed to be short; otherwise we want-                -- some sort of ordered map.-        installedPkgs :: InstalledPackageIndex,-                -- ^ All the info about the installed packages that the-                -- current package depends on (directly or indirectly).-                -- Does NOT include internal dependencies.-        pkgDescrFile  :: Maybe FilePath,-                -- ^ the filename containing the .cabal file, if available-        localPkgDescr :: PackageDescription,-                -- ^ The resolved package description, that does not contain-                -- any conditionals.-        withPrograms  :: ProgramConfiguration, -- ^Location and args for all programs-        withPackageDB :: PackageDBStack,  -- ^What package database to use, global\/user-        withVanillaLib:: Bool,  -- ^Whether to build normal libs.-        withProfLib   :: Bool,  -- ^Whether to build profiling versions of libs.-        withSharedLib :: Bool,  -- ^Whether to build shared versions of libs.-        withDynExe    :: Bool,  -- ^Whether to link executables dynamically-        withProfExe   :: Bool,  -- ^Whether to build executables for profiling.-        withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.-        withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.-        withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available).-        withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available).-        withGHCiLib   :: Bool,  -- ^Whether to build libs suitable for use with GHCi.-        splitObjs     :: Bool,  -- ^Use -split-objs with GHC, if available-        stripExes     :: Bool,  -- ^Whether to strip executables during install-        stripLibs     :: Bool,  -- ^Whether to strip libraries during install-        progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables-        progSuffix    :: PathTemplate, -- ^Suffix to be appended to installed executables-        relocatable   :: Bool --  ^Whether to build a relocatable package-  } deriving (Generic, Read, Show)--instance Binary LocalBuildInfo---- TODO: Get rid of these functions, as much as possible.  They are--- a bit useful in some cases, but you should be very careful!---- | Extract the 'ComponentId' from the public library component of a--- 'LocalBuildInfo' if it exists, or make a fake component ID based--- on the package ID.-localComponentId :: LocalBuildInfo -> ComponentId-localComponentId lbi-    = case localUnitId lbi of-        SimpleUnitId cid -> cid---- | Extract the 'UnitId' from the library component of a--- 'LocalBuildInfo' if it exists, or make a fake unit ID based on--- the package ID.-localUnitId :: LocalBuildInfo -> UnitId-localUnitId lbi-    = case maybeGetDefaultLibraryLocalBuildInfo lbi of-        Just LibComponentLocalBuildInfo { componentUnitId = uid } -> uid-        -- Something fake:-        _ -> mkLegacyUnitId (package (localPkgDescr lbi))---- | Extract the compatibility package key from the public library component of a--- 'LocalBuildInfo' if it exists, or make a fake package key based--- on the package ID.-localCompatPackageKey :: LocalBuildInfo -> String-localCompatPackageKey lbi =-    case maybeGetDefaultLibraryLocalBuildInfo lbi of-        Just LibComponentLocalBuildInfo { componentCompatPackageKey = pk } -> pk-        -- Something fake:-        _ -> display (package (localPkgDescr lbi))---- | External package dependencies for the package as a whole. This is the--- union of the individual 'componentPackageDeps', less any internal deps.-externalPackageDeps :: LocalBuildInfo -> [(UnitId, PackageId)]-externalPackageDeps lbi =-    -- TODO:  what about non-buildable components?-    nub [ (ipkgid, pkgid)-        | (clbi,_)      <- componentsConfigs lbi-        , (ipkgid, pkgid) <- componentPackageDeps clbi-        , not (internal ipkgid) ]-  where-    -- True if this dependency is an internal one (depends on the library-    -- defined in the same package).-    internal ipkgid = any ((==ipkgid) . componentUnitId . fst) (componentsConfigs lbi)- -- -------------------------------------------------------------------------------- Source-representation of buildable components--data Component = CLib   Library-               | CExe   Executable-               | CTest  TestSuite-               | CBench Benchmark-               deriving (Show, Eq, Read)---- | This gets the 'String' component name. In fact, it is--- guaranteed to uniquely identify a component, returning--- @Nothing@ if the 'ComponentName' was for the public--- library (which CAN conflict with an executable name.)-componentNameString :: PackageName -> ComponentName -> Maybe String-componentNameString (PackageName pkg_name) (CLibName n) | pkg_name == n = Nothing-componentNameString _ (CLibName   n) = Just n-componentNameString _ (CExeName   n) = Just n-componentNameString _ (CTestName  n) = Just n-componentNameString _ (CBenchName n) = Just n--showComponentName :: ComponentName -> String-showComponentName (CLibName   name) = "library '" ++ name ++ "'"-showComponentName (CExeName   name) = "executable '" ++ name ++ "'"-showComponentName (CTestName  name) = "test suite '" ++ name ++ "'"-showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"--foldComponent :: (Library -> a)-              -> (Executable -> a)-              -> (TestSuite -> a)-              -> (Benchmark -> a)-              -> Component-              -> a-foldComponent f _ _ _ (CLib   lib) = f lib-foldComponent _ f _ _ (CExe   exe) = f exe-foldComponent _ _ f _ (CTest  tst) = f tst-foldComponent _ _ _ f (CBench bch) = f bch--componentBuildInfo :: Component -> BuildInfo-componentBuildInfo =-  foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo--componentName :: Component -> ComponentName-componentName =-  foldComponent (CLibName . libName)-                (CExeName . exeName)-                (CTestName . testName)-                (CBenchName . benchmarkName)---- | All the components in the package (libs, exes, or test suites).----pkgComponents :: PackageDescription -> [Component]-pkgComponents pkg =-    [ CLib  lib | lib <- libraries pkg ]- ++ [ CExe  exe | exe <- executables pkg ]- ++ [ CTest tst | tst <- testSuites  pkg ]- ++ [ CBench bm | bm  <- benchmarks  pkg ]---- | All the components in the package that are buildable and enabled.--- Thus this excludes non-buildable components and test suites or benchmarks--- that have been disabled.----pkgEnabledComponents :: PackageDescription -> [Component]-pkgEnabledComponents = filter componentEnabled . pkgComponents--componentEnabled :: Component -> Bool-componentEnabled = isNothing . componentDisabledReason--data ComponentDisabledReason = DisabledComponent-                             | DisabledAllTests-                             | DisabledAllBenchmarks--componentDisabledReason :: Component -> Maybe ComponentDisabledReason-componentDisabledReason (CLib  lib)-  | not (buildable (libBuildInfo lib))      = Just DisabledComponent-componentDisabledReason (CExe  exe)-  | not (buildable (buildInfo exe))         = Just DisabledComponent-componentDisabledReason (CTest tst)-  | not (buildable (testBuildInfo tst))     = Just DisabledComponent-  | not (testEnabled tst)                   = Just DisabledAllTests-componentDisabledReason (CBench bm)-  | not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent-  | not (benchmarkEnabled bm)               = Just DisabledAllBenchmarks-componentDisabledReason _                   = Nothing--lookupComponent :: PackageDescription -> ComponentName -> Maybe Component-lookupComponent pkg (CLibName "") = lookupComponent pkg (defaultLibName (package pkg))-lookupComponent pkg (CLibName name) =-    fmap CLib $ find ((name ==) . libName) (libraries pkg)-lookupComponent pkg (CExeName name) =-    fmap CExe $ find ((name ==) . exeName) (executables pkg)-lookupComponent pkg (CTestName name) =-    fmap CTest $ find ((name ==) . testName) (testSuites pkg)-lookupComponent pkg (CBenchName name) =-    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)--getComponent :: PackageDescription -> ComponentName -> Component-getComponent pkg cname =-    case lookupComponent pkg cname of-      Just cpnt -> cpnt-      Nothing   -> missingComponent-  where-    missingComponent =-      error $ "internal error: the package description contains no "-           ++ "component corresponding to " ++ show cname---- ----------------------------------------------------------------------------- -- Configuration information of buildable components -data ComponentLocalBuildInfo-  = LibComponentLocalBuildInfo {-    -- | It would be very convenient to store the literal Library here,-    -- but if we do that, it will get serialized (via the Binary)-    -- instance twice.  So instead we just provide the ComponentName,-    -- which can be used to find the Component in the-    -- PackageDescription.  NB: eventually, this will NOT uniquely-    -- identify the ComponentLocalBuildInfo.-    componentLocalName :: ComponentName,-    -- | Resolved internal and external package dependencies for this component.-    -- The 'BuildInfo' specifies a set of build dependencies that must be-    -- satisfied in terms of version ranges. This field fixes those dependencies-    -- to the specific versions available on this machine for this compiler.-    componentPackageDeps :: [(UnitId, PackageId)],-    -- | The computed 'UnitId' which uniquely identifies this-    -- component.-    componentUnitId :: UnitId,-    -- | Compatibility "package key" that we pass to older versions of GHC.-    componentCompatPackageKey :: String,-    -- | Compatability "package name" that we register this component as.-    componentCompatPackageName :: PackageName,-    -- | A list of exposed modules (either defined in this component,-    -- or reexported from another component.)-    componentExposedModules :: [Installed.ExposedModule],-    -- | Convenience field, specifying whether or not this is the-    -- "public library" that has the same name as the package.-    componentIsPublic :: Bool,-    -- | The set of packages that are brought into scope during-    -- compilation, including a 'ModuleRenaming' which may used-    -- to hide or rename modules.  This is what gets translated into-    -- @-package-id@ arguments.  This is a modernized version of-    -- 'componentPackageDeps', which is kept around for BC purposes.-    componentIncludes :: [(UnitId, ModuleRenaming)]-  }-  | ExeComponentLocalBuildInfo {-    componentLocalName :: ComponentName,-    componentUnitId :: UnitId,-    componentPackageDeps :: [(UnitId, PackageId)],-    componentIncludes :: [(UnitId, ModuleRenaming)]-  }-  | TestComponentLocalBuildInfo {-    componentLocalName :: ComponentName,-    componentUnitId :: UnitId,-    componentPackageDeps :: [(UnitId, PackageId)],-    componentIncludes :: [(UnitId, ModuleRenaming)]-  }-  | BenchComponentLocalBuildInfo {-    componentLocalName :: ComponentName,-    componentUnitId :: UnitId,-    componentPackageDeps :: [(UnitId, PackageId)],-    componentIncludes :: [(UnitId, ModuleRenaming)]-  }-  deriving (Generic, Read, Show)--instance Binary ComponentLocalBuildInfo--getLocalComponent :: PackageDescription -> ComponentLocalBuildInfo -> Component-getLocalComponent pkg_descr clbi = getComponent pkg_descr (componentLocalName clbi)--componentComponentId :: ComponentLocalBuildInfo -> ComponentId-componentComponentId clbi = case componentUnitId clbi of-                                SimpleUnitId cid -> cid- componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath-componentBuildDir lbi LibComponentLocalBuildInfo{ componentIsPublic = True }-    = buildDir lbi -- For now, we assume that libraries/executables/test-suites/benchmarks -- are only ever built once.  With Backpack, we need a special case for -- libraries so that we can handle building them multiple times. componentBuildDir lbi clbi-    = buildDir lbi </> case componentLocalName clbi of-                        CLibName s   -> s-                        CExeName s   -> s-                        CTestName s  -> s-                        CBenchName s -> s+    = buildDir lbi </>+        case componentLocalName clbi of+            CLibName      ->+                if display (componentUnitId clbi) == display (componentComponentId clbi)+                    then ""+                    else display (componentUnitId clbi)+            CSubLibName s ->+                if display (componentUnitId clbi) == display (componentComponentId clbi)+                    then unUnqualComponentName s+                    else display (componentUnitId clbi)+            CFLibName s  -> unUnqualComponentName s+            CExeName s   -> unUnqualComponentName s+            CTestName s  -> unUnqualComponentName s+            CBenchName s -> unUnqualComponentName s +{-# DEPRECATED getComponentLocalBuildInfo "This function is not well-defined, because a 'ComponentName' does not uniquely identify a 'ComponentLocalBuildInfo'.  If you have a 'TargetInfo', you should use 'targetCLBI' to get the 'ComponentLocalBuildInfo'.  Otherwise, use 'componentNameTargets' to get all possible 'ComponentLocalBuildInfo's.  This will be removed in Cabal 2.2." #-} getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo getComponentLocalBuildInfo lbi cname =-    case maybeGetComponentLocalBuildInfo lbi cname of-      Just clbi -> clbi-      Nothing   ->+    case componentNameCLBIs lbi cname of+      [clbi] -> clbi+      [] ->           error $ "internal error: there is no configuration data "                ++ "for component " ++ show cname--maybeGetComponentLocalBuildInfo-    :: LocalBuildInfo -> ComponentName -> Maybe ComponentLocalBuildInfo-maybeGetComponentLocalBuildInfo lbi cname =-    case [ clbi-         | (clbi, _) <- componentsConfigs lbi-         , cid <- componentNameToUnitIds lbi cname-         , cid == componentUnitId clbi ] of-      [clbi] -> Just clbi-      _      -> Nothing--maybeGetDefaultLibraryLocalBuildInfo-    :: LocalBuildInfo-    -> Maybe ComponentLocalBuildInfo-maybeGetDefaultLibraryLocalBuildInfo lbi =-    case [ clbi-         | (clbi@LibComponentLocalBuildInfo{}, _) <- componentsConfigs lbi-         , componentIsPublic clbi-         ] of-      [clbi] -> Just clbi-      _ -> Nothing--componentNameToUnitIds :: LocalBuildInfo -> ComponentName -> [UnitId]-componentNameToUnitIds lbi cname =-    [ componentUnitId clbi-    | (clbi, _) <- componentsConfigs lbi-    , componentName (getLocalComponent (localPkgDescr lbi) clbi) == cname ]+      clbis ->+          error $ "internal error: the component name " ++ show cname+               ++ "is ambiguous.  Refers to: "+               ++ intercalate ", " (map (display . componentUnitId) clbis) --- | Perform the action on each buildable 'library' in the package--- description.  Extended version of 'withLib' that also gives--- corresponding build info.+-- | Perform the action on each enabled 'library' in the package+-- description with the 'ComponentLocalBuildInfo'. withLibLBI :: PackageDescription -> LocalBuildInfo            -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () withLibLBI pkg lbi f =-    sequence_-        [ f lib clbi-        | (clbi@LibComponentLocalBuildInfo{}, _) <- componentsConfigs lbi-        , CLib lib <- [getComponent pkg (componentLocalName clbi)] ]+    withAllTargetsInBuildOrder' pkg lbi $ \target ->+        case targetComponent target of+            CLib lib -> f lib (targetCLBI target)+            _ -> return () --- | Perform the action on each buildable 'Executable' in the package+-- | Perform the action on each enabled 'Executable' in the package -- description.  Extended version of 'withExe' that also gives corresponding -- build info. withExeLBI :: PackageDescription -> LocalBuildInfo            -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () withExeLBI pkg lbi f =-    sequence_-        [ f exe clbi-        | (clbi@ExeComponentLocalBuildInfo{}, _) <- componentsConfigs lbi-        , CExe exe <- [getComponent pkg (componentLocalName clbi)] ]+    withAllTargetsInBuildOrder' pkg lbi $ \target ->+        case targetComponent target of+            CExe exe -> f exe (targetCLBI target)+            _ -> return () +-- | Perform the action on each enabled 'Benchmark' in the package+-- description.+withBenchLBI :: PackageDescription -> LocalBuildInfo+            -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO ()+withBenchLBI pkg lbi f =+    sequence_ [ f test clbi | (test, clbi) <- enabledBenchLBIs pkg lbi ]+ withTestLBI :: PackageDescription -> LocalBuildInfo             -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () withTestLBI pkg lbi f =-    sequence_-        [ f test clbi-        | (clbi@TestComponentLocalBuildInfo{}, _) <- componentsConfigs lbi-        , CTest test <- [getComponent pkg (componentLocalName clbi)] ]+    sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ] +enabledTestLBIs :: PackageDescription -> LocalBuildInfo+             -> [(TestSuite, ComponentLocalBuildInfo)]+enabledTestLBIs pkg lbi =+    [ (test, targetCLBI target)+    | target <- allTargetsInBuildOrder' pkg lbi+    , CTest test <- [targetComponent target] ]++enabledBenchLBIs :: PackageDescription -> LocalBuildInfo+             -> [(Benchmark, ComponentLocalBuildInfo)]+enabledBenchLBIs pkg lbi =+    [ (bench, targetCLBI target)+    | target <- allTargetsInBuildOrder' pkg lbi+    , CBench bench <- [targetComponent target] ]+ {-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-} withComponentsLBI :: PackageDescription -> LocalBuildInfo                   -> (Component -> ComponentLocalBuildInfo -> IO ())@@ -459,66 +191,42 @@                               -> (Component -> ComponentLocalBuildInfo -> IO ())                               -> IO () withAllComponentsInBuildOrder pkg lbi f =-    sequence_-      [ f (getLocalComponent pkg clbi) clbi-      | clbi <- allComponentsInBuildOrder lbi ]+    withAllTargetsInBuildOrder' pkg lbi $ \target ->+        f (targetComponent target) (targetCLBI target) +{-# DEPRECATED withComponentsInBuildOrder "You have got a 'TargetInfo' right? Use 'withNeededTargetsInBuildOrder' on the 'UnitId's you can 'nodeKey' out." #-} withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo                            -> [ComponentName]                            -> (Component -> ComponentLocalBuildInfo -> IO ())                            -> IO () withComponentsInBuildOrder pkg lbi cnames f =-    sequence_-      [ f (getLocalComponent pkg clbi) clbi-      | clbi <- componentsInBuildOrder lbi cnames ]+    withNeededTargetsInBuildOrder' pkg lbi uids $ \target ->+        f (targetComponent target) (targetCLBI target)+  where uids = concatMap (componentNameToUnitIds lbi) cnames  allComponentsInBuildOrder :: LocalBuildInfo                           -> [ComponentLocalBuildInfo] allComponentsInBuildOrder lbi =-    componentsInBuildOrder' lbi-      [ componentUnitId clbi | (clbi, _) <- componentsConfigs lbi ]+    Graph.topSort (componentGraph lbi) -componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]-                       -> [ComponentLocalBuildInfo]-componentsInBuildOrder lbi cnames =-    componentsInBuildOrder' lbi-        (concatMap (componentNameToUnitIds lbi) cnames)+-- | Private helper function for some of the deprecated implementations.+componentNameToUnitIds :: LocalBuildInfo -> ComponentName -> [UnitId]+componentNameToUnitIds lbi cname =+    case Map.lookup cname (componentNameMap lbi) of+        Just clbis -> map componentUnitId clbis+        Nothing -> error $ "componentNameToUnitIds " ++ display cname -componentsInBuildOrder' :: LocalBuildInfo -> [UnitId]+{-# DEPRECATED componentsInBuildOrder "You've got 'TargetInfo' right? Use 'neededTargetsInBuildOrder' on the 'UnitId's you can 'nodeKey' out." #-}+componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]                        -> [ComponentLocalBuildInfo]-componentsInBuildOrder' lbi cids =-      map ((\(clbi,_,_) -> clbi) . vertexToNode)-    . postOrder graph-    . map (\cid -> fromMaybe (noSuchComp cid) (keyToVertex cid))-    $ cids-  where-    (graph, vertexToNode, keyToVertex) =-      graphFromEdges (map (\(clbi,internal_deps) ->-                            (clbi,componentUnitId clbi,internal_deps)) (componentsConfigs lbi))--    noSuchComp cid = error $ "internal error: componentsInBuildOrder: "-                            ++ "no such component: " ++ show cid--    postOrder :: Graph -> [Vertex] -> [Vertex]-    postOrder g vs = postorderF (dfs g vs) []--    postorderF   :: Forest a -> [a] -> [a]-    postorderF ts = foldr (.) id $ map postorderT ts--    postorderT :: Tree a -> [a] -> [a]-    postorderT (Node a ts) = postorderF ts . (a :)+componentsInBuildOrder lbi cnames+    -- NB: use of localPkgDescr here is safe because we throw out the+    -- result immediately afterwards+    = map targetCLBI (neededTargetsInBuildOrder' (localPkgDescr lbi) lbi uids)+  where uids = concatMap (componentNameToUnitIds lbi) cnames -checkComponentsCyclic :: Ord key => [(node, key, [key])]-                      -> Maybe [(node, key, [key])]-checkComponentsCyclic es =-    let (graph, vertexToNode, _) = graphFromEdges es-        cycles                   = [ flatten c | c <- scc graph, isCycle c ]-        isCycle (Node v [])      = selfCyclic v-        isCycle _                = True-        selfCyclic v             = v `elem` graph ! v-     in case cycles of-         []    -> Nothing-         (c:_) -> Just (map vertexToNode c)+-- -----------------------------------------------------------------------------+-- A random function that has no business in this module  -- | Determine the directories containing the dynamic libraries of the -- transitive dependencies of the component we are building.@@ -528,7 +236,7 @@                 -> Bool -- ^ Generate prefix-relative library paths                 -> LocalBuildInfo                 -> ComponentLocalBuildInfo -- ^ Component that is being built-                -> IO [FilePath]+                -> NoCallStackIO [FilePath] depLibraryPaths inplace relative lbi clbi = do     let pkgDescr    = localPkgDescr lbi         installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest@@ -539,23 +247,48 @@                | otherwise  = libdir installDirs      let -- TODO: this is kind of inefficient-        internalDeps = [ cid-                       | (cid, _) <- componentPackageDeps clbi+        internalDeps = [ uid+                       | (uid, _) <- componentPackageDeps clbi                        -- Test that it's internal-                       , (sub_clbi, _) <- componentsConfigs lbi-                       , componentUnitId sub_clbi == cid ]-        internalLibs = [ getLibDir sub_clbi-                       | sub_clbi <- componentsInBuildOrder'-                                        lbi internalDeps ]+                       , sub_target <- allTargetsInBuildOrder' pkgDescr lbi+                       , componentUnitId (targetCLBI (sub_target)) == uid ]+        internalLibs = [ getLibDir (targetCLBI sub_target)+                       | sub_target <- neededTargetsInBuildOrder'+                                        pkgDescr lbi internalDeps ]+    {-+    -- This is better, but it doesn't work, because we may be passed a+    -- CLBI which doesn't actually exist, and was faked up when we+    -- were building a test suite/benchmark.  See #3599 for proposal+    -- to fix this.+    let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId)+                      . map targetCLBI+                      $ neededTargetsInBuildOrder lbi [componentUnitId clbi]+        internalLibs = map getLibDir internalCLBIs+    -}         getLibDir sub_clbi           | inplace    = componentBuildDir lbi sub_clbi-          | otherwise  = libdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest)+          | otherwise  = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) -    let ipkgs          = allPackages (installedPkgs lbi)-        allDepLibDirs  = concatMap Installed.libraryDirs ipkgs+    -- Why do we go through all the trouble of a hand-crafting+    -- internalLibs, when 'installedPkgs' actually contains the+    -- internal libraries?  The trouble is that 'installedPkgs'+    -- may contain *inplace* entries, which we must NOT use for+    -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation).+    -- See #4025 for more details. This is all horrible but it+    -- is a moot point if you are using a per-component build,+    -- because you never have any internal libraries in this case;+    -- they're all external.+    let external_ipkgs = filter is_external (allPackages (installedPkgs lbi))+        is_external ipkg = not (installedUnitId ipkg `elem` internalDeps)+        -- First look for dynamic libraries in `dynamic-library-dirs`, and use+        -- `library-dirs` as a fall back.+        getDynDir pkg  = case Installed.libraryDynDirs pkg of+                           [] -> Installed.libraryDirs pkg+                           d  -> d+        allDepLibDirs  = concatMap getDynDir external_ipkgs          allDepLibDirs' = internalLibs ++ allDepLibDirs-    allDepLibDirsC <- mapM canonicalizePathNoFail allDepLibDirs'+    allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs'      let p                = prefix installDirs         prefixRelative l = isJust (stripPrefix p l)@@ -578,6 +311,16 @@          then canonicalizePath p          else return p +-- | Get all module names that needed to be built by GHC; i.e., all+-- of these 'ModuleName's have interface files associated with them+-- that need to be installed.+allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName]+allLibModules lib clbi =+    ordNub $+    explicitLibModules lib +++    case clbi of+        LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts+        _ -> []  -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs
cabal/Cabal/Distribution/Simple/PackageIndex.hs view
@@ -77,6 +77,7 @@    -- ** Precise lookups   lookupUnitId,+  lookupComponentId,   lookupSourcePackageId,   lookupPackageId,   lookupPackageName,@@ -108,9 +109,11 @@   lookupInstalledPackageId,   ) where -import Distribution.Compat.Binary-import Distribution.Compat.Semigroup as Semi+import Prelude ()+import Distribution.Compat.Prelude hiding (lookup)+ import Distribution.Package+import Distribution.Backpack import Distribution.ModuleName import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Version@@ -120,15 +123,9 @@ import Data.Array ((!)) import qualified Data.Array as Array import qualified Data.Graph as Graph-import Data.List as List-         ( null, foldl', sort-         , groupBy, sortBy, find, nubBy, deleteBy, deleteFirstsBy )-import Data.Map (Map)+import Data.List as List ( groupBy,  deleteBy, deleteFirstsBy ) import qualified Data.Map as Map-import Data.Maybe (isNothing, fromMaybe) import qualified Data.Tree  as Tree-import GHC.Generics (Generic)-import Prelude hiding (lookup)  -- | The collection of information about packages from one or more 'PackageDB's. -- These packages generally should have an instance of 'PackageInstalled'@@ -136,11 +133,11 @@ -- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version. ---data PackageIndex a = PackageIndex+data PackageIndex a = PackageIndex {   -- The primary index. Each InstalledPackageInfo record is uniquely identified   -- by its UnitId.   ---  !(Map UnitId a)+  unitIdIndex :: !(Map UnitId a),    -- This auxiliary index maps package names (case-sensitively) to all the   -- versions and instances of that package. This allows us to find all@@ -153,9 +150,9 @@   --   -- FIXME: Clarify what "preference order" means. Check that this invariant is   -- preserved. See #1463 for discussion.-  !(Map PackageName (Map Version [a]))+  packageIdIndex :: !(Map PackageName (Map Version [a])) -  deriving (Eq, Generic, Show, Read)+  } deriving (Eq, Generic, Show, Read)  instance Binary a => Binary (PackageIndex a) @@ -165,7 +162,7 @@  instance HasUnitId a => Monoid (PackageIndex a) where   mempty  = PackageIndex Map.empty Map.empty-  mappend = (Semi.<>)+  mappend = (<>)   --save one mappend with empty in the common case:   mconcat [] = mempty   mconcat xs = foldr1 mappend xs@@ -188,6 +185,11 @@      , let pinstOk = packageName    pinst == pname                   && packageVersion pinst == pver      ]+  -- If you see this invariant failing (ie the assert in mkPackageIndex below)+  -- then one thing to check is if it is happening in fromList. Check if the+  -- second list above (the sort [...] bit) is ending up with duplicates. This+  -- has been observed in practice once due to a messed up ghc-pkg db. How/why+  -- it became messed up was not discovered.   --@@ -300,7 +302,7 @@       . Map.update deletePkgInstance (packageVersion spkgid)      deletePkgInstance =-        (\xs -> if List.null xs then Nothing else Just xs)+        (\xs -> if null xs then Nothing else Just xs)       . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined  -- | Backwards compatibility wrapper for Cabal pre-1.24.@@ -358,16 +360,16 @@ -- | Get all the packages from the index. -- allPackages :: PackageIndex a -> [a]-allPackages (PackageIndex pids _) = Map.elems pids+allPackages = Map.elems . unitIdIndex  -- | Get all the packages from the index. -- -- They are grouped by package name (case-sensitively). -- allPackagesByName :: PackageIndex a -> [(PackageName, [a])]-allPackagesByName (PackageIndex _ pnames) =+allPackagesByName index =   [ (pkgname, concat (Map.elems pvers))-  | (pkgname, pvers) <- Map.toList pnames ]+  | (pkgname, pvers) <- Map.toList (packageIdIndex index) ]  -- | Get all the packages from the index. --@@ -375,24 +377,32 @@ -- allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a                              -> [(PackageId, [a])]-allPackagesBySourcePackageId (PackageIndex _ pnames) =+allPackagesBySourcePackageId index =   [ (packageId ipkg, ipkgs)-  | pvers <- Map.elems pnames+  | pvers <- Map.elems (packageIdIndex index)   , ipkgs@(ipkg:_) <- Map.elems pvers ]  -- -- * Lookups -- --- | Does a lookup by source package id (name & version).+-- | Does a lookup by unit identifier. -- -- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package. -- lookupUnitId :: PackageIndex a -> UnitId              -> Maybe a-lookupUnitId (PackageIndex pids _) pid = Map.lookup pid pids+lookupUnitId index uid = Map.lookup uid (unitIdIndex index) +-- | Does a lookup by component identifier.  In the absence+-- of Backpack, this is just a 'lookupUnitId'.+--+lookupComponentId :: PackageIndex a -> ComponentId+                  -> Maybe a+lookupComponentId index cid =+    Map.lookup (newSimpleUnitId cid) (unitIdIndex index)+ -- | Backwards compatibility for Cabal pre-1.24. {-# DEPRECATED lookupInstalledPackageId "Use lookupUnitId instead" #-} lookupInstalledPackageId :: PackageIndex a -> UnitId@@ -407,8 +417,8 @@ -- preference, with the most preferred first. -- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a]-lookupSourcePackageId (PackageIndex _ pnames) pkgid =-  case Map.lookup (packageName pkgid) pnames of+lookupSourcePackageId index pkgid =+  case Map.lookup (packageName pkgid) (packageIdIndex index) of     Nothing     -> []     Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of       Nothing   -> []@@ -426,8 +436,8 @@ -- lookupPackageName :: PackageIndex a -> PackageName                   -> [(Version, [a])]-lookupPackageName (PackageIndex _ pnames) name =-  case Map.lookup name pnames of+lookupPackageName index name =+  case Map.lookup name (packageIdIndex index) of     Nothing     -> []     Just pvers  -> Map.toList pvers @@ -437,14 +447,26 @@ -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. ---lookupDependency :: PackageIndex a -> Dependency-                 -> [(Version, [a])]-lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) =-  case Map.lookup name pnames of+-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.+--+lookupDependency :: InstalledPackageIndex -> Dependency+                 -> [(Version, [IPI.InstalledPackageInfo])]+lookupDependency index (Dependency name versionRange) =+  case Map.lookup name (packageIdIndex index) of     Nothing    -> []-    Just pvers -> [ entry-                  | entry@(ver, _) <- Map.toList pvers-                  , ver `withinRange` versionRange ]+    Just pvers -> [ (ver, pkgs')+                  | (ver, pkgs) <- Map.toList pvers+                  , ver `withinRange` versionRange+                  , let pkgs' = filter eligible pkgs+                  -- Enforce the invariant+                  , not (null pkgs')+                  ]+ where+  -- When we select for dependencies, we ONLY want to pick up indefinite+  -- packages, or packages with no instantiations.  We'll do mix-in+  -- linking to improve any such package into an instantiated one+  -- later.+  eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg)  -- -- * Case insensitive name lookups@@ -463,12 +485,12 @@ -- it is a non-empty list of non-empty lists. -- searchByName :: PackageIndex a -> String -> SearchResult [a]-searchByName (PackageIndex _ pnames) name =-  case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames-              , lowercase name' == lname ] of+searchByName index name =+  case [ pkgs | pkgs@(pname,_) <- Map.toList (packageIdIndex index)+              , lowercase (unPackageName pname) == lname ] of     []               -> None     [(_,pvers)]      -> Unambiguous (concat (Map.elems pvers))-    pkgss            -> case find ((PackageName name==) . fst) pkgss of+    pkgss            -> case find ((mkPackageName name ==) . fst) pkgss of       Just (_,pvers) -> Unambiguous (concat (Map.elems pvers))       Nothing        -> Ambiguous (map (concat . Map.elems . snd) pkgss)   where lname = lowercase name@@ -480,10 +502,10 @@ -- That is, all packages that contain the given string in their name. -- searchByNameSubstring :: PackageIndex a -> String -> [a]-searchByNameSubstring (PackageIndex _ pnames) searchterm =+searchByNameSubstring index searchterm =   [ pkg-  | (PackageName name, pvers) <- Map.toList pnames-  , lsearchterm `isInfixOf` lowercase name+  | (pname, pvers) <- Map.toList (packageIdIndex index)+  , lsearchterm `isInfixOf` lowercase (unPackageName pname)   , pkgs <- Map.elems pvers   , pkg <- pkgs ]   where lsearchterm = lowercase searchterm@@ -662,8 +684,9 @@     IPI.ExposedModule m reexport <- IPI.exposedModules pkg     case reexport of         Nothing -> return (m, [pkg])-        Just (Module _ m') | m == m'   -> []-                           | otherwise -> return (m', [pkg])+        Just (OpenModuleVar _) -> []+        Just (OpenModule _ m') | m == m'   -> []+                                | otherwise -> return (m', [pkg])         -- The heuristic is this: we want to prefer the original package         -- which originally exported a module.  However, if a reexport         -- also *renamed* the module (m /= m'), then we have to use the
cabal/Cabal/Distribution/Simple/PreProcess.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.PreProcess@@ -26,6 +29,9 @@                                )     where +import Prelude ()+import Distribution.Compat.Prelude+import Distribution.Compat.Stack  import Distribution.Simple.PreProcess.Unlit import Distribution.Package@@ -44,10 +50,8 @@ import Distribution.Text import Distribution.Version import Distribution.Verbosity+import Distribution.Types.ForeignLib -import Control.Monad-import Data.Maybe (fromMaybe)-import Data.List (nub, isSuffixOf) import System.Directory (doesFileExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),@@ -146,24 +150,37 @@                     -> IO () preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of   (CLib lib@Library{ libBuildInfo = bi }) -> do-    let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi clbi]-    setupMessage verbosity "Preprocessing library" (packageId pd)-    forM_ (map ModuleName.toFilePath $ libModules lib) $-      pre dirs (buildDir lbi) (localHandlers bi)+    let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi+                                  ,autogenPackageModulesDir lbi]+        extra | componentIsPublic clbi = ""+              | otherwise = " '" ++ display (componentUnitId clbi) ++ "' for"+    setupMessage verbosity ("Preprocessing library" ++ extra) (packageId pd)+    for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $+      pre dirs (componentBuildDir lbi clbi) (localHandlers bi)+  (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do+    let nm' = unUnqualComponentName nm+        flibDir = buildDir lbi </> nm' </> nm' ++ "-tmp"+        dirs    = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi+                                     ,autogenPackageModulesDir lbi]+    setupMessage verbosity ("Preprocessing foreign library '" ++ nm' ++ "' for") (packageId pd)+    for_ (map ModuleName.toFilePath $ foreignLibModules flib) $+      pre dirs flibDir (localHandlers bi)   (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do-    let exeDir = buildDir lbi </> nm </> nm ++ "-tmp"-        dirs   = hsSourceDirs bi ++ [autogenModulesDir lbi clbi]-    setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd)-    forM_ (map ModuleName.toFilePath $ otherModules bi) $+    let nm' = unUnqualComponentName nm+        exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"+        dirs   = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi+                                    ,autogenPackageModulesDir lbi]+    setupMessage verbosity ("Preprocessing executable '" ++ nm' ++ "' for") (packageId pd)+    for_ (map ModuleName.toFilePath $ otherModules bi) $       pre dirs exeDir (localHandlers bi)     pre (hsSourceDirs bi) exeDir (localHandlers bi) $       dropExtensions (modulePath exe)   CTest test@TestSuite{ testName = nm } -> do-    setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd)+    let nm' = unUnqualComponentName nm+    setupMessage verbosity ("Preprocessing test suite '" ++ nm' ++ "' for") (packageId pd)     case testInterface test of       TestSuiteExeV10 _ f ->-          preProcessTest test f $ buildDir lbi </> testName test-              </> testName test ++ "-tmp"+          preProcessTest test f $ buildDir lbi </> nm' </> nm' ++ "-tmp"       TestSuiteLibV09 _ _ -> do           let testDir = buildDir lbi </> stubName test                   </> stubName test ++ "-tmp"@@ -172,11 +189,11 @@       TestSuiteUnsupported tt -> die $ "No support for preprocessing test "                                     ++ "suite type " ++ display tt   CBench bm@Benchmark{ benchmarkName = nm } -> do-    setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd)+    let nm' = unUnqualComponentName nm+    setupMessage verbosity ("Preprocessing benchmark '" ++ nm' ++ "' for") (packageId pd)     case benchmarkInterface bm of       BenchmarkExeV10 _ f ->-          preProcessBench bm f $ buildDir lbi </> benchmarkName bm-              </> benchmarkName bm ++ "-tmp"+          preProcessBench bm f $ buildDir lbi </> nm' </> nm' ++ "-tmp"       BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "                                  ++ "type " ++ display tt   where@@ -192,7 +209,8 @@                          (benchmarkModules bm)     preProcessComponent bi modules exePath dir = do         let biHandlers = localHandlers bi-            sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi clbi ]+            sourceDirs = hsSourceDirs bi ++ [ autogenComponentModulesDir lbi clbi+                                            , autogenPackageModulesDir lbi ]         sequence_ [ preprocessFile sourceDirs dir isSrcDist                 (ModuleName.toFilePath modu) verbosity builtinSuffixes                 biHandlers@@ -300,7 +318,7 @@     = PreProcessor {         platformIndependent = False,         runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-          rawSystemProgramConf verbosity greencardProgram (withPrograms lbi)+          runDbProgram verbosity greencardProgram (withPrograms lbi)               (["-tffi", "-o" ++ outFile, inFile])       } @@ -321,7 +339,7 @@ ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppCpp' extraArgs bi lbi clbi =   case compilerFlavor (compiler lbi) of-    GHC   -> ppGhcCpp ghcProgram   (>= Version [6,6] []) args bi lbi clbi+    GHC   -> ppGhcCpp ghcProgram   (>= mkVersion [6,6])  args bi lbi clbi     GHCJS -> ppGhcCpp ghcjsProgram (const True)          args bi lbi clbi     _     -> ppCpphs  args bi lbi clbi   where cppArgs = getCppOptions bi lbi@@ -335,7 +353,7 @@     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do       (prog, version, _) <- requireProgramVersion verbosity                               program anyVersion (withPrograms lbi)-      rawSystemProgram verbosity prog $+      runProgram verbosity prog $           ["-E", "-cpp"]           -- This is a bit of an ugly hack. We're going to           -- unlit the file ourselves later on if appropriate,@@ -343,7 +361,7 @@           -- double-unlitted. In the future we might switch to           -- using cpphs --unlit instead.        ++ (if xHs version then ["-x", "hs"] else [])-       ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi clbi </> cppHeaderName) ]+       ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi </> cppHeaderName) ]        ++ ["-o", outFile, inFile]        ++ extraArgs   }@@ -355,11 +373,11 @@     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do       (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity                                         cpphsProgram anyVersion (withPrograms lbi)-      rawSystemProgram verbosity cpphsProg $+      runProgram verbosity cpphsProg $           ("-O" ++ outFile) : inFile         : "--noline" : "--strip"-        : (if cpphsVersion >= Version [1,6] []-             then ["--include="++ (autogenModulesDir lbi clbi </> cppHeaderName)]+        : (if cpphsVersion >= mkVersion [1,6]+             then ["--include="++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]              else [])         ++ extraArgs   }@@ -370,7 +388,7 @@     platformIndependent = False,     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do       (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)-      rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $+      runDbProgram verbosity hsc2hsProgram (withPrograms lbi) $           [ "--cc=" ++ programPath gccProg           , "--ld=" ++ programPath gccProg ] @@ -402,8 +420,9 @@        ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi                                       ++ PD.cppOptions   bi ]        ++ [ "--cflag="   ++ opt | opt <--               [ "-I" ++ autogenModulesDir lbi clbi,-                 "-include", autogenModulesDir lbi clbi </> cppHeaderName ] ]+               [ "-I" ++ autogenComponentModulesDir lbi clbi,+                 "-I" ++ autogenPackageModulesDir lbi,+                 "-include", autogenComponentModulesDir lbi clbi </> cppHeaderName ] ]        ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]        ++ [ "--lflag=-Wl,-R," ++ opt | isELF                                 , opt <- PD.extraLibDirs bi ]@@ -425,13 +444,16 @@        ++ ["-o", outFile, inFile]   }   where-    -- TODO: installedPkgs contains ALL dependencies associated with-    -- the package, but we really only want to look at packages for the-    -- *current* dependency.  We should use PackageIndex.dependencyClosure-    -- on the direct depends of the component.  The signature of this-    -- function was recently refactored, so this should be fixable-    -- now.  Tracked with #2971 (which has a test case.)-    pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))+    hacked_index = packageHacks (installedPkgs lbi)+    -- Look only at the dependencies of the current component+    -- being built!  This relies on 'installedPkgs' maintaining+    -- 'InstalledPackageInfo' for internal deps too; see #2971.+    pkgs = PackageIndex.topologicalOrder $+           case PackageIndex.dependencyClosure hacked_index+                    (map fst (componentPackageDeps clbi)) of+            Left index' -> index'+            Right inf ->+                error ("ppHsc2hs: broken closure: " ++ show inf)     isOSX = case buildOS of OSX -> True; _ -> False     isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True;     packageHacks = case compilerFlavor (compiler lbi) of@@ -443,7 +465,7 @@     -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the     -- ldOptions for GHC's rts package:     hackRtsPackage index =-      case PackageIndex.lookupPackageName index (PackageName "rts") of+      case PackageIndex.lookupPackageName index (mkPackageName "rts") of         [(_, [rts])]            -> PackageIndex.insert rts { Installed.ldOptions = [] } index         _  -> error "No (or multiple) ghc rts package is registered!!"@@ -459,15 +481,15 @@     runPreProcessor = \(inBaseDir, inRelativeFile)                        (outBaseDir, outRelativeFile) verbosity -> do       (c2hsProg, _, _) <- requireProgramVersion verbosity-                            c2hsProgram (orLaterVersion (Version [0,15] []))+                            c2hsProgram (orLaterVersion (mkVersion [0,15]))                             (withPrograms lbi)       (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)-      rawSystemProgram verbosity c2hsProg $+      runProgram verbosity c2hsProg $            -- Options from the current package:            [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]         ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]-        ++ [ "--cppopts=-include" ++ (autogenModulesDir lbi clbi </> cppHeaderName) ]+        ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName) ]         ++ [ "--include=" ++ outBaseDir ]            -- Options from dependent packages@@ -533,10 +555,11 @@     -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all     -- the other compilers. Check if that's really what they want.     versionInt :: Version -> String-    versionInt (Version { versionBranch = [] }) = "1"-    versionInt (Version { versionBranch = [n] }) = show n-    versionInt (Version { versionBranch = n1:n2:_ })-      = -- 6.8.x -> 608+    versionInt v = case versionNumbers v of+      [] -> "1"+      [n] -> show n+      n1:n2:_ ->+        -- 6.8.x -> 608         -- 6.10.x -> 610         let s1 = show n1             s2 = show n2@@ -544,6 +567,7 @@                      _ : _ : _ -> ""                      _         -> "0"         in s1 ++ middle ++ s2+     osStr = case hostOS of       Linux     -> ["linux"]       Windows   -> ["mingw32"]@@ -602,7 +626,7 @@   PreProcessor {     platformIndependent = False,     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-      rawSystemProgramConf verbosity prog (withPrograms lbi)+      runDbProgram verbosity prog (withPrograms lbi)                            (args ++ ["-o", outFile, inFile])   } @@ -633,21 +657,47 @@                  -> IO [FilePath] preprocessExtras comp lbi = case comp of   CLib _ -> pp $ buildDir lbi-  (CExe Executable { exeName = nm }) ->-    pp $ buildDir lbi </> nm </> nm ++ "-tmp"+  (CExe Executable { exeName = nm }) -> do+    let nm' = unUnqualComponentName nm+    pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"+  (CFLib ForeignLib { foreignLibName = nm }) -> do+    let nm' = unUnqualComponentName nm+    pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"   CTest test -> do+    let nm' = unUnqualComponentName $ testName test     case testInterface test of       TestSuiteExeV10 _ _ ->-          pp $ buildDir lbi </> testName test </> testName test ++ "-tmp"+          pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"       TestSuiteLibV09 _ _ ->           pp $ buildDir lbi </> stubName test </> stubName test ++ "-tmp"       TestSuiteUnsupported tt -> die $ "No support for preprocessing test "                                     ++ "suite type " ++ display tt   CBench bm -> do+    let nm' = unUnqualComponentName $ benchmarkName bm     case benchmarkInterface bm of       BenchmarkExeV10 _ _ ->-          pp $ buildDir lbi </> benchmarkName bm </> benchmarkName bm ++ "-tmp"+          pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"       BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "                                  ++ "type " ++ display tt   where-    pp dir = (map (dir </>) . concat) `fmap` forM knownExtrasHandlers ($ dir)+    pp :: FilePath -> IO [FilePath]+    pp dir = (map (dir </>) . filter not_sub . concat)+          <$> for knownExtrasHandlers+                (withLexicalCallStack (\f -> f dir))+    -- TODO: This is a terrible hack to work around #3545 while we don't+    -- reorganize the directory layout.  Basically, for the main+    -- library, we might accidentally pick up autogenerated sources for+    -- our subcomponents, because they are all stored as subdirectories+    -- in dist/build.  This is a cheap and cheerful check to prevent+    -- this from happening.  It is not particularly correct; for example+    -- if a user has a test suite named foobar and puts their C file in+    -- foobar/foo.c, this test will incorrectly exclude it.  But I+    -- didn't want to break BC...+    not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ]+    component_dirs = component_names (localPkgDescr lbi)+    -- TODO: libify me+    component_names pkg_descr = fmap unUnqualComponentName $+        mapMaybe libName (subLibraries pkg_descr) +++        map exeName (executables pkg_descr) +++        map testName (testSuites pkg_descr) +++        map benchmarkName (benchmarks pkg_descr)
cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs view
@@ -15,9 +15,11 @@  module Distribution.Simple.PreProcess.Unlit (unlit,plain) where -import Data.Char-import Data.List+import Prelude ()+import Distribution.Compat.Prelude +import Data.List (mapAccumL)+ data Classified = BirdTrack String | Blank String | Ordinary String                 | Line !Int String | CPP String                 | BeginCode | EndCode@@ -35,7 +37,7 @@                                   && length file >= 2                                   && head file == '"'                                   && last file == '"'-                                -> Line (read line) (tail (init file))+                                -> Line (read line) (tail (init file)) -- TODO:eradicateNoParse                      _          -> CPP s   where tokens = unfoldr $ \str -> case lex str of                                    (t@(_:_), str'):_ -> Just (t, str')
cabal/Cabal/Distribution/Simple/Program.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program@@ -11,14 +14,14 @@ -- 'ConfiguredProgram' is a 'Program' that has been found on the current -- machine and is ready to be run (possibly with some user-supplied default -- args). Configuring a program involves finding its location and if necessary--- finding its version. There is also a 'ProgramConfiguration' type which holds+-- finding its version. There is also a 'ProgramDb' type which holds -- configured and not-yet configured programs. It is the parameter to lots of -- actions elsewhere in Cabal that need to look up and run programs. If we had--- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or--- state component of it. +-- a Cabal monad, the 'ProgramDb' would probably be a reader or+-- state component of it. -- -- The module also defines all the known built-in 'Program's and the--- 'defaultProgramConfiguration' which contains them all.+-- 'defaultProgramDb' which contains them all. -- -- One nice thing about using it is that any program that is -- registered with Cabal will get some \"configure\" and \".cabal\"@@ -63,10 +66,10 @@     , builtinPrograms      -- * The collection of configured programs we can run-    , ProgramConfiguration-    , emptyProgramConfiguration-    , defaultProgramConfiguration-    , restoreProgramConfiguration+    , ProgramDb+    , defaultProgramDb+    , emptyProgramDb+    , restoreProgramDb     , addKnownProgram     , addKnownPrograms     , lookupKnownProgram@@ -118,6 +121,10 @@     , hpcProgram      -- * deprecated+    , ProgramConfiguration+    , emptyProgramConfiguration+    , defaultProgramConfiguration+    , restoreProgramConfiguration     , rawSystemProgram     , rawSystemProgramStdout     , rawSystemProgramConf@@ -127,6 +134,9 @@      ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run import Distribution.Simple.Program.Db@@ -135,9 +145,7 @@ import Distribution.Simple.Utils import Distribution.Verbosity - -- | Runs the given configured program.--- runProgram :: Verbosity          -- ^Verbosity            -> ConfiguredProgram  -- ^The program to run            -> [ProgArg]          -- ^Any /extra/ arguments to add@@ -191,28 +199,37 @@ -- Deprecated aliases -- +{-# DEPRECATED rawSystemProgram "use runProgram instead" #-} rawSystemProgram :: Verbosity -> ConfiguredProgram                  -> [ProgArg] -> IO () rawSystemProgram = runProgram +{-# DEPRECATED rawSystemProgramStdout "use getProgramOutput instead" #-} rawSystemProgramStdout :: Verbosity -> ConfiguredProgram                        -> [ProgArg] -> IO String rawSystemProgramStdout = getProgramOutput +{-# DEPRECATED rawSystemProgramConf "use runDbProgram instead" #-} rawSystemProgramConf :: Verbosity  -> Program -> ProgramConfiguration                      -> [ProgArg] -> IO () rawSystemProgramConf = runDbProgram +{-# DEPRECATED rawSystemProgramStdoutConf "use getDbProgramOutput instead" #-} rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration                            -> [ProgArg] -> IO String rawSystemProgramStdoutConf = getDbProgramOutput +{-# DEPRECATED ProgramConfiguration "use ProgramDb instead" #-} type ProgramConfiguration = ProgramDb +{-# DEPRECATED emptyProgramConfiguration "use emptyProgramDb instead" #-}+{-# DEPRECATED defaultProgramConfiguration "use defaultProgramDb instead" #-} emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration emptyProgramConfiguration   = emptyProgramDb defaultProgramConfiguration = defaultProgramDb +{-# DEPRECATED restoreProgramConfiguration+               "use restoreProgramDb instead" #-} restoreProgramConfiguration :: [Program] -> ProgramConfiguration                                          -> ProgramConfiguration restoreProgramConfiguration = restoreProgramDb
cabal/Cabal/Distribution/Simple/Program/Ar.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE NoMonoLocalBinds #-}  -----------------------------------------------------------------------------@@ -16,10 +19,11 @@     multiStageProgramInvocation   ) where -import Control.Monad (unless)+import Prelude ()+import Distribution.Compat.Prelude+ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8-import Data.Char (isSpace) import Distribution.Compat.CopyFile (filesEqual) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.Program@@ -44,7 +48,7 @@ createArLibArchive :: Verbosity -> LocalBuildInfo                    -> FilePath -> [FilePath] -> IO () createArLibArchive verbosity lbi targetPath files = do-  (ar, _) <- requireProgram verbosity arProgram progConf+  (ar, _) <- requireProgram verbosity arProgram progDb    let (targetDir, targetName) = splitFileName targetPath   withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do@@ -92,7 +96,7 @@   unless equal $ renameFile tmpPath targetPath    where-    progConf = withPrograms lbi+    progDb = withPrograms lbi     Platform hostArch hostOS = hostPlatform lbi     verbosityOpts v | v >= deafening = ["-v"]                     | v >= verbose   = []
cabal/Cabal/Distribution/Simple/Program/Builtin.hs view
@@ -45,6 +45,9 @@     hpcProgram,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Program.Find import Distribution.Simple.Program.Internal import Distribution.Simple.Program.Run@@ -54,8 +57,6 @@ import Distribution.Verbosity import Distribution.Version -import Data.Char-         ( isDigit ) import qualified Data.Map as Map  -- ------------------------------------------------------------@@ -112,8 +113,8 @@              }            -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4.            affectedVersionRange = intersectVersionRanges-                                  (laterVersion   $ Version [7,8,0] [])-                                  (earlierVersion $ Version [7,8,4] [])+                                  (laterVersion   $ mkVersion [7,8,0])+                                  (earlierVersion $ mkVersion [7,8,4])        return $ maybe ghcProg          (\v -> if withinRange v affectedVersionRange                 then ghcProg' else ghcProg)
cabal/Cabal/Distribution/Simple/Program/Db.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Db@@ -55,6 +59,9 @@    ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Program.Types import Distribution.Simple.Program.Find import Distribution.Simple.Program.Builtin@@ -62,16 +69,10 @@ import Distribution.Version import Distribution.Text import Distribution.Verbosity-import Distribution.Compat.Binary -import Data.List-         ( foldl' )-import Data.Maybe-         ( catMaybes )+import Control.Monad (join) import Data.Tuple (swap) import qualified Data.Map as Map-import Control.Monad-         ( join, foldM )  -- ------------------------------------------------------------ -- * Programs database@@ -90,6 +91,7 @@         progSearchPath    :: ProgramSearchPath,         configuredProgs   :: ConfiguredProgs     }+  deriving (Typeable)  type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) type UnconfiguredProgs   = Map.Map String UnconfiguredProgram@@ -106,13 +108,13 @@ -- internal helpers: updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs)                         -> ProgramDb -> ProgramDb-updateUnconfiguredProgs update conf =-  conf { unconfiguredProgs = update (unconfiguredProgs conf) }+updateUnconfiguredProgs update progdb =+  progdb { unconfiguredProgs = update (unconfiguredProgs progdb) }  updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs)                       -> ProgramDb -> ProgramDb-updateConfiguredProgs update conf =-  conf { configuredProgs = update (configuredProgs conf) }+updateConfiguredProgs update progdb =+  progdb { configuredProgs = update (configuredProgs progdb) }   -- Read & Show instances are based on listToFM@@ -172,7 +174,7 @@   addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb-addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs+addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs   lookupKnownProgram :: String -> ProgramDb -> Maybe Program@@ -181,9 +183,9 @@   knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)]-knownPrograms conf =-  [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf)-           , let p' = Map.lookup (programName p) (configuredProgs conf) ]+knownPrograms progdb =+  [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb)+           , let p' = Map.lookup (programName p) (configuredProgs progdb) ]  -- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This is the default list of locations where programs are looked for when@@ -224,8 +226,8 @@  userMaybeSpecifyPath :: String -> Maybe FilePath                      -> ProgramDb -> ProgramDb-userMaybeSpecifyPath _    Nothing conf     = conf-userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf+userMaybeSpecifyPath _    Nothing progdb     = progdb+userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb   -- |User-specify the arguments for this program.  Basically override@@ -250,8 +252,8 @@ userSpecifyPaths :: [(String, FilePath)]                  -> ProgramDb                  -> ProgramDb-userSpecifyPaths paths conf =-  foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths+userSpecifyPaths paths progdb =+  foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths   -- | Like 'userSpecifyPath' but for a list of progs and their args.@@ -259,8 +261,8 @@ userSpecifyArgss :: [(String, [ProgArg])]                  -> ProgramDb                  -> ProgramDb-userSpecifyArgss argss conf =-  foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss+userSpecifyArgss argss progdb =+  foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss   -- | Get the path that has been previously specified for a program, if any.@@ -317,17 +319,17 @@                  -> Program                  -> ProgramDb                  -> IO ProgramDb-configureProgram verbosity prog conf = do+configureProgram verbosity prog progdb = do   let name = programName prog-  maybeLocation <- case userSpecifiedPath prog conf of+  maybeLocation <- case userSpecifiedPath prog progdb of     Nothing   ->-      programFindLocation prog verbosity (progSearchPath conf)+      programFindLocation prog verbosity (progSearchPath progdb)       >>= return . fmap (swap . fmap FoundOnSystem . swap)     Just path -> do       absolute <- doesExecutableExist path       if absolute         then return (Just (UserSpecified path, []))-        else findProgramOnSearchPath verbosity (progSearchPath conf) path+        else findProgramOnSearchPath verbosity (progSearchPath progdb) path              >>= maybe (die notFound)                        (return . Just . swap . fmap UserSpecified . swap)       where notFound = "Cannot find the program '" ++ name@@ -335,22 +337,22 @@                      ++ path ++ "' does not refer to an executable and "                      ++ "the program is not on the system path."   case maybeLocation of-    Nothing -> return conf+    Nothing -> return progdb     Just (location, triedLocations) -> do       version <- programFindVersion prog verbosity (locationPath location)-      newPath <- programSearchPathAsPATHVar (progSearchPath conf)+      newPath <- programSearchPathAsPATHVar (progSearchPath progdb)       let configuredProg        = ConfiguredProgram {             programId           = name,             programVersion      = version,             programDefaultArgs  = [],-            programOverrideArgs = userSpecifiedArgs prog conf,+            programOverrideArgs = userSpecifiedArgs prog progdb,             programOverrideEnv  = [("PATH", Just newPath)],             programProperties   = Map.empty,             programLocation     = location,             programMonitorFiles = triedLocations           }       configuredProg' <- programPostConf prog verbosity configuredProg-      return (updateConfiguredProgs (Map.insert name configuredProg') conf)+      return (updateConfiguredProgs (Map.insert name configuredProg') progdb)   -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'.@@ -359,8 +361,8 @@                   -> [Program]                   -> ProgramDb                   -> IO ProgramDb-configurePrograms verbosity progs conf =-  foldM (flip (configureProgram verbosity)) conf progs+configurePrograms verbosity progs progdb =+  foldM (flip (configureProgram verbosity)) progdb progs   -- | Try to configure all the known programs that have not yet been configured.@@ -368,12 +370,12 @@ configureAllKnownPrograms :: Verbosity                           -> ProgramDb                           -> IO ProgramDb-configureAllKnownPrograms verbosity conf =+configureAllKnownPrograms verbosity progdb =   configurePrograms verbosity-    [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf+    [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb   where-    notYetConfigured = unconfiguredProgs conf-      `Map.difference` configuredProgs conf+    notYetConfigured = unconfiguredProgs progdb+      `Map.difference` configuredProgs progdb   -- | reconfigure a bunch of programs given new user-specified args. It takes@@ -385,14 +387,14 @@                     -> [(String, [ProgArg])]                     -> ProgramDb                     -> IO ProgramDb-reconfigurePrograms verbosity paths argss conf = do+reconfigurePrograms verbosity paths argss progdb = do   configurePrograms verbosity progs    . userSpecifyPaths paths    . userSpecifyArgss argss-   $ conf+   $ progdb    where-    progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ]+    progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ]   -- | Check that a program is configured and available to be run.@@ -402,16 +404,16 @@ -- requireProgram :: Verbosity -> Program -> ProgramDb                -> IO (ConfiguredProgram, ProgramDb)-requireProgram verbosity prog conf = do+requireProgram verbosity prog progdb = do    -- If it's not already been configured, try to configure it now-  conf' <- case lookupProgram prog conf of-    Nothing -> configureProgram verbosity prog conf-    Just _  -> return conf+  progdb' <- case lookupProgram prog progdb of+    Nothing -> configureProgram verbosity prog progdb+    Just _  -> return progdb -  case lookupProgram prog conf' of+  case lookupProgram prog progdb' of     Nothing             -> die notFound-    Just configuredProg -> return (configuredProg, conf')+    Just configuredProg -> return (configuredProg, progdb')    where notFound       = "The program '" ++ programName prog                       ++ "' is required but it could not be found."
cabal/Cabal/Distribution/Simple/Program/Find.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, DeriveGeneric #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}  ----------------------------------------------------------------------------- -- |@@ -31,20 +34,19 @@     getSystemSearchPath,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Verbosity import Distribution.Simple.Utils import Distribution.System import Distribution.Compat.Environment-import Distribution.Compat.Binary  import qualified System.Directory as Directory          ( findExecutable ) import System.FilePath as FilePath          ( (</>), (<.>), splitSearchPath, searchPathSeparator, getSearchPath          , takeDirectory )-import Data.List-         ( nub )-import GHC.Generics #if defined(mingw32_HOST_OS) import qualified System.Win32 as Win32 #endif@@ -93,7 +95,7 @@           where             alltried = concat (reverse (notfoundat : tried)) -    tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath])+    tryPathElem :: ProgramSearchPathEntry -> NoCallStackIO (Maybe FilePath, [FilePath])     tryPathElem (ProgramSearchPathDir dir) =         findFirstExe [ dir </> prog <.> ext | ext <- exeExtensions ] @@ -118,7 +120,7 @@       dirs <- getSystemSearchPath       findFirstExe [ dir </> prog <.> ext | dir <- dirs, ext <- exeExtensions ] -    findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath])+    findFirstExe :: [FilePath] -> NoCallStackIO (Maybe FilePath, [FilePath])     findFirstExe = go []       where         go fs' []     = return (Nothing, reverse fs')@@ -131,9 +133,9 @@ -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. -- Note that this is close but not perfect because on Windows the search -- algorithm looks at more than just the @%PATH%@.-programSearchPathAsPATHVar :: ProgramSearchPath -> IO String+programSearchPathAsPATHVar :: ProgramSearchPath -> NoCallStackIO String programSearchPathAsPATHVar searchpath = do-    ess <- mapM getEntries searchpath+    ess <- traverse getEntries searchpath     return (intercalate [searchPathSeparator] (concat ess))   where     getEntries (ProgramSearchPathDir dir) = return [dir]@@ -144,7 +146,7 @@ -- | Get the system search path. On Unix systems this is just the @$PATH@ env -- var, but on windows it's a bit more complicated. ---getSystemSearchPath :: IO [FilePath]+getSystemSearchPath :: NoCallStackIO [FilePath] getSystemSearchPath = fmap nub $ do #if defined(mingw32_HOST_OS)     processdir <- takeDirectory `fmap` Win32.getModuleFileName Win32.nullHANDLE@@ -166,7 +168,7 @@ #endif #endif -findExecutable :: FilePath -> IO (Maybe FilePath)+findExecutable :: FilePath -> NoCallStackIO (Maybe FilePath) #ifdef HAVE_directory_121 findExecutable = Directory.findExecutable #else
cabal/Cabal/Distribution/Simple/Program/GHC.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE NoMonoLocalBinds #-}  module Distribution.Simple.Program.GHC (@@ -15,9 +17,12 @@    ) where -import Distribution.Compat.Semigroup as Semi-import Distribution.Simple.GHC.ImplInfo+import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Package+import Distribution.Backpack+import Distribution.Simple.GHC.ImplInfo import Distribution.PackageDescription hiding (Flag) import Distribution.ModuleName import Distribution.Simple.Compiler hiding (Flag)@@ -30,8 +35,7 @@ import Distribution.Utils.NubList import Language.Haskell.Extension -import GHC.Generics (Generic)-import qualified Data.Map as M+import qualified Data.Map as Map  -- | A structured set of GHC options/flags --@@ -81,13 +85,28 @@   -- (we need to handle backwards compatibility.)   ghcOptThisUnitId   :: Flag String, +  -- | GHC doesn't make any assumptions about the format of+  -- definite unit ids, so when we are instantiating a package it+  -- needs to be told explicitly what the component being instantiated+  -- is.  This only gets set when 'ghcOptInstantiatedWith' is non-empty+  ghcOptThisComponentId :: Flag ComponentId,++  -- | How the requirements of the package being compiled are to+  -- be filled.  When typechecking an indefinite package, the 'OpenModule'+  -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module+  -- that instantiates a package.+  ghcOptInstantiatedWith :: [(ModuleName, OpenModule)],++  -- | No code? (But we turn on interface writing+  ghcOptNoCode :: Flag Bool,+   -- | GHC package databases to use, the @ghc -package-conf@ flag.   ghcOptPackageDBs    :: PackageDBStack,    -- | The GHC packages to bring into scope when compiling,   -- the @ghc -package-id@ flags.   ghcOptPackages      ::-    NubListR (UnitId, ModuleRenaming),+    NubListR (OpenUnitId, ModuleRenaming),    -- | Start with a clean package set; the @ghc -hide-all-packages@ flag   ghcOptHideAllPackages :: Flag Bool,@@ -122,6 +141,9 @@   -- flag.   ghcOptLinkNoHsMain :: Flag Bool, +  -- | Module definition files (Windows specific)+  ghcOptLinkModDefFiles :: NubListR FilePath,+   --------------------   -- C and CPP stuff @@ -151,7 +173,7 @@    -- | A GHC version-dependent mapping of extensions to flags. This must be   -- set to be able to make use of the 'ghcOptExtensions'.-  ghcOptExtensionMap    :: M.Map Extension String,+  ghcOptExtensionMap    :: Map Extension String,    ----------------   -- Compilation@@ -196,9 +218,10 @@   ghcOptStubDir       :: Flag FilePath,    ---------------------  -- Dynamic linking+  -- Creating libraries    ghcOptDynLinkMode   :: Flag GhcDynLinkMode,+  ghcOptStaticLib     :: Flag Bool,   ghcOptShared        :: Flag Bool,   ghcOptFPic          :: Flag Bool,   ghcOptDylibName     :: Flag String,@@ -210,6 +233,10 @@   -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.   ghcOptVerbosity     :: Flag Verbosity, +  -- | Put the extra folders in the PATH environment variable we invoke+  -- GHC with+  ghcOptExtraPath     :: NubListR FilePath,+   -- | Let GHC know that it is Cabal that's calling it.   -- Modifies some of the GHC error messages.   ghcOptCabal         :: Flag Bool@@ -251,7 +278,9 @@ ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions               -> ProgramInvocation ghcInvocation prog comp platform opts =-    programInvocation prog (renderGhcOptions comp platform opts)+    (programInvocation prog (renderGhcOptions comp platform opts)) {+        progInvokePathEnv = fromNubListR (ghcOptExtraPath opts)+    }  renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] renderGhcOptions comp _platform@(Platform _arch os) opts@@ -322,9 +351,10 @@     else []    ---------------------  -- Dynamic linking+  -- Creating libraries -  , [ "-shared"  | flagBool ghcOptShared  ]+  , [ "-staticlib" | flagBool ghcOptStaticLib ]+  , [ "-shared"    | flagBool ghcOptShared    ]   , case flagToMaybe (ghcOptDynLinkMode opts) of       Nothing                  -> []       Just GhcStaticOnly       -> ["-static"]@@ -379,6 +409,7 @@   , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ]   , concat [ [ "-optl-Wl,-rpath," ++ dir]            | dir <- flags ghcOptRPaths ]+  , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ]    -------------   -- Packages@@ -390,6 +421,19 @@              , this_arg ]              | this_arg <- flag ghcOptThisUnitId ] +  , concat [ ["-this-component-id", display this_cid ]+           | this_cid <- flag ghcOptThisComponentId ]++  , if null (ghcOptInstantiatedWith opts)+        then []+        else "-instantiated-with"+             : intercalate "," (map (\(n,m) -> display n ++ "="+                                            ++ display m)+                                    (ghcOptInstantiatedWith opts))+             : []++  , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ]+   , [ "-hide-all-packages"     | flagBool ghcOptHideAllPackages ]   , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] @@ -407,7 +451,7 @@     then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ]     else [] -  , [ case M.lookup ext (ghcOptExtensionMap opts) of+  , [ case Map.lookup ext (ghcOptExtensionMap opts) of         Just arg -> arg         Nothing  -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "                           ++ display ext ++ " not present in ghcOptExtensionMap."@@ -492,7 +536,7 @@  instance Monoid GhcOptions where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup GhcOptions where   (<>) = gmappend
cabal/Cabal/Distribution/Simple/Program/HcPkg.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.HcPkg@@ -40,6 +43,9 @@     listInvocation,   ) where +import Prelude ()+import Distribution.Compat.Prelude hiding (init)+ import Distribution.Package hiding (installedUnitId) import Distribution.InstalledPackageInfo import Distribution.ParseUtils@@ -51,9 +57,6 @@ import Distribution.Verbosity import Distribution.Compat.Exception -import Prelude hiding (init)-import Data.Char-         ( isSpace ) import Data.List          ( stripPrefix ) import System.FilePath as FilePath@@ -234,7 +237,8 @@    output <- getProgramInvocationOutput verbosity               (dumpInvocation hpi verbosity packagedb)-    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"+    `catchIO` \e -> die $ programId (hcPkgProgram hpi) ++ " dump failed: "+                       ++ displayException e    case parsePackages output of     Left ok -> return ok@@ -311,11 +315,12 @@ -- field, so if it is missing then we fill it as the source package ID. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo setUnitId pkginfo@InstalledPackageInfo {-                        installedUnitId = SimpleUnitId (ComponentId ""),+                        installedUnitId = uid,                         sourcePackageId = pkgid-                      }+                      } | unUnitId uid == ""                     = pkginfo {-                        installedUnitId = mkLegacyUnitId pkgid+                        installedUnitId = mkLegacyUnitId pkgid,+                        installedComponentId_ = mkComponentId (display pkgid)                       } setUnitId pkginfo = pkginfo @@ -341,7 +346,7 @@                   ++ programId (hcPkgProgram hpi) ++ " list'"    where-    parsePackageIds = sequence . map simpleParse . words+    parsePackageIds = traverse simpleParse . words  -------------------------- -- The program invocations
cabal/Cabal/Distribution/Simple/Program/Hpc.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Hpc@@ -13,6 +16,9 @@     , union     ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.ModuleName import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types@@ -54,7 +60,7 @@     runProgramInvocation verbosity       (markupInvocation hpc tixFile hpcDirs' destDir excluded)   where-    version07 = Version [0, 7] []+    version07 = mkVersion [0, 7]     (passedDirs, droppedDirs) = splitAt 1 hpcDirs  markupInvocation :: ConfiguredProgram
cabal/Cabal/Distribution/Simple/Program/Internal.hs view
@@ -11,8 +11,8 @@     stripExtractVersion,   ) where -import Data.Char (isDigit)-import Data.List (isPrefixOf, isSuffixOf)+import Prelude ()+import Distribution.Compat.Prelude  -- | Extract the version number from the output of 'strip --version'. --
cabal/Cabal/Distribution/Simple/Program/Ld.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Ld@@ -11,6 +14,9 @@ module Distribution.Simple.Program.Ld (     combineObjectFiles,   ) where++import Prelude ()+import Distribution.Compat.Prelude  import Distribution.Simple.Program.Types          ( ConfiguredProgram(..) )
cabal/Cabal/Distribution/Simple/Program/Run.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Run@@ -23,16 +26,16 @@     getEffectiveEnvironment,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Compat.Environment -import Data.List-         ( foldl', unfoldr ) import qualified Data.Map as Map-import Control.Monad-         ( when )+import System.FilePath import System.Exit          ( ExitCode(..), exitWith ) @@ -47,6 +50,8 @@        progInvokePath  :: FilePath,        progInvokeArgs  :: [String],        progInvokeEnv   :: [(String, Maybe String)],+       -- Extra paths to add to PATH+       progInvokePathEnv :: [FilePath],        progInvokeCwd   :: Maybe FilePath,        progInvokeInput :: Maybe String,        progInvokeInputEncoding  :: IOEncoding,@@ -62,6 +67,7 @@     progInvokePath  = "",     progInvokeArgs  = [],     progInvokeEnv   = [],+    progInvokePathEnv = [],     progInvokeCwd   = Nothing,     progInvokeInput = Nothing,     progInvokeInputEncoding  = IOEncodingText,@@ -92,6 +98,7 @@     progInvokePath  = path,     progInvokeArgs  = args,     progInvokeEnv   = [],+    progInvokePathEnv = [],     progInvokeCwd   = Nothing,     progInvokeInput = Nothing   } =@@ -102,10 +109,12 @@     progInvokePath  = path,     progInvokeArgs  = args,     progInvokeEnv   = envOverrides,+    progInvokePathEnv = extraPath,     progInvokeCwd   = mcwd,     progInvokeInput = Nothing   } = do-    menv <- getEffectiveEnvironment envOverrides+    pathOverride <- getExtraPathEnv envOverrides extraPath+    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)     exitCode <- rawSystemIOWithEnv verbosity                                    path args                                    mcwd menv@@ -118,11 +127,13 @@     progInvokePath  = path,     progInvokeArgs  = args,     progInvokeEnv   = envOverrides,+    progInvokePathEnv = extraPath,     progInvokeCwd   = mcwd,     progInvokeInput = Just inputStr,     progInvokeInputEncoding = encoding   } = do-    menv <- getEffectiveEnvironment envOverrides+    pathOverride <- getExtraPathEnv envOverrides extraPath+    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)     (_, errors, exitCode) <- rawSystemStdInOut verbosity                                     path args                                     mcwd menv@@ -142,6 +153,7 @@     progInvokePath  = path,     progInvokeArgs  = args,     progInvokeEnv   = envOverrides,+    progInvokePathEnv = extraPath,     progInvokeCwd   = mcwd,     progInvokeInput = minputStr,     progInvokeOutputEncoding = encoding@@ -149,7 +161,8 @@     let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False         decode | utf8      = fromUTF8 . normaliseLineEndings                | otherwise = id-    menv <- getEffectiveEnvironment envOverrides+    pathOverride <- getExtraPathEnv envOverrides extraPath+    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)     (output, errors, exitCode) <- rawSystemStdInOut verbosity                                     path args                                     mcwd menv@@ -167,10 +180,24 @@             IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8  +getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> NoCallStackIO [(String, Maybe String)]+getExtraPathEnv _ [] = return []+getExtraPathEnv env extras = do+    mb_path <- case lookup "PATH" env of+                Just x  -> return x+                Nothing -> lookupEnv "PATH"+    let extra = intercalate [searchPathSeparator] extras+        path' = case mb_path of+                    Nothing   -> extra+                    Just path -> extra ++ searchPathSeparator : path+    return [("PATH", Just path')]+ -- | Return the current environment extended with the given overrides.+-- If an entry is specified twice in @overrides@, the second entry takes+-- precedence. -- getEffectiveEnvironment :: [(String, Maybe String)]-                        -> IO (Maybe [(String, String)])+                        -> NoCallStackIO (Maybe [(String, String)]) getEffectiveEnvironment []        = return Nothing getEffectiveEnvironment overrides =     fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment
cabal/Cabal/Distribution/Simple/Program/Script.hs view
@@ -16,11 +16,11 @@     invocationAsBatchFile,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Program.Run import Distribution.System--import Data.Maybe-         ( maybeToList )  -- | Generate a system script, either POSIX shell script or Windows batch file -- as appropriate for the given system.
cabal/Cabal/Distribution/Simple/Program/Strip.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Strip@@ -10,19 +13,21 @@ module Distribution.Simple.Program.Strip (stripLib, stripExe)        where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Program import Distribution.Simple.Utils import Distribution.System import Distribution.Verbosity import Distribution.Version -import Control.Monad               (unless) import System.FilePath             (takeBaseName) -runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO ()-runStrip verbosity progConf path args =-  case lookupProgram stripProgram progConf of-    Just strip -> rawSystemProgram verbosity strip (path:args)+runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO ()+runStrip verbosity progDb path args =+  case lookupProgram stripProgram progDb of+    Just strip -> runProgram verbosity strip (path:args)     Nothing    -> unless (buildOS == Windows) $                   -- Don't bother warning on windows, we don't expect them to                   -- have the strip program anyway.@@ -30,9 +35,9 @@                                    ++ (takeBaseName path)                                    ++ "' (missing the 'strip' program)" -stripExe :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO ()-stripExe verbosity (Platform _arch os) conf path =-  runStrip verbosity conf path args+stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO ()+stripExe verbosity (Platform _arch os) progdb path =+  runStrip verbosity progdb path args   where     args = case os of        OSX -> ["-x"] -- By default, stripping the ghc binary on at least@@ -41,8 +46,8 @@                      -- The -x flag fixes that.        _   -> [] -stripLib :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO ()-stripLib verbosity (Platform arch os) conf path = do+stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO ()+stripLib verbosity (Platform arch os) progdb path = do   case os of     OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or            -- Solaris. See #1630.@@ -57,14 +62,14 @@     Linux | arch == I386 ->       -- Versions of 'strip' on 32-bit Linux older than 2.18 are       -- broken. See #2339.-      let okVersion = orLaterVersion (Version [2,18] [])-      in case programVersion =<< lookupProgram stripProgram conf of+      let okVersion = orLaterVersion (mkVersion [2,18])+      in case programVersion =<< lookupProgram stripProgram progdb of           Just v | withinRange v okVersion ->-            runStrip verbosity conf path args+            runStrip verbosity progdb path args           _ -> warn verbosity $ "Unable to strip library '"                                 ++ (takeBaseName path)                                 ++ "' (version of 'strip' too old; "                                 ++ "requires >= 2.18 on 32-bit Linux)"-    _   -> runStrip verbosity conf path args+    _   -> runStrip verbosity progdb path args   where     args = ["--strip-unneeded"]
cabal/Cabal/Distribution/Simple/Program/Types.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}  ----------------------------------------------------------------------------- -- |@@ -32,13 +35,14 @@     simpleConfiguredProgram,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Program.Find import Distribution.Version import Distribution.Verbosity-import Distribution.Compat.Binary  import qualified Data.Map as Map-import GHC.Generics (Generic)  -- | Represents a program which can be configured. --@@ -119,7 +123,7 @@        --        programMonitorFiles :: [FilePath]      }-  deriving (Eq, Generic, Read, Show)+  deriving (Eq, Generic, Read, Show, Typeable)  instance Binary ConfiguredProgram @@ -148,7 +152,7 @@ -- By default we'll just search for it in the path and not try to find the -- version name. You can override these behaviours if necessary, eg: ----- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... }+-- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } -- simpleProgram :: String -> Program simpleProgram name = Program {
cabal/Cabal/Distribution/Simple/Register.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Register@@ -27,6 +30,8 @@     register,     unregister, +    internalPackageDBPath,+     initPackageDB,     doesPackageDBExist,     createPackageDB,@@ -40,8 +45,16 @@     generalInstalledPackageInfo,   ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.TargetInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.ComponentLocalBuildInfo+ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths+import Distribution.Simple.BuildTarget  import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS@@ -62,18 +75,13 @@ import Distribution.System import Distribution.Text import Distribution.Verbosity as Verbosity+import Distribution.Version+import Distribution.Compat.Graph (IsNode(nodeKey))  import System.FilePath ((</>), (<.>), isAbsolute) import System.Directory-         ( getCurrentDirectory, removeDirectoryRecursive, removeFile-         , doesDirectoryExist, doesFileExist ) -import Data.Version-import Control.Monad (when)-import Data.Maybe-         ( isJust, fromMaybe, maybeToList )-import Data.List-         ( partition, nub )+import Data.List (partition) import qualified Data.ByteString.Lazy.Char8 as BS.Char8  -- -----------------------------------------------------------------------------@@ -82,43 +90,74 @@ register :: PackageDescription -> LocalBuildInfo          -> RegisterFlags -- ^Install in the user's database?; verbose          -> IO ()-register pkg lbi regFlags =-    -- We do NOT register libraries outside of the inplace database-    -- if there is no public library, since no one else can use it-    -- usefully (they're not public.)  If we start supporting scoped-    -- packages, we'll have to relax this.-    when (hasPublicLib pkg) $-        let maybeRegister (CLib lib) _clbi =-                registerOne pkg lbi regFlags lib-            maybeRegister _comp _clbi = return ()-        in withAllComponentsInBuildOrder pkg lbi maybeRegister+register pkg_descr lbi flags =+   -- Duncan originally asked for us to not register/install files+   -- when there was no public library.  But with per-component+   -- configure, we legitimately need to install internal libraries+   -- so that we can get them.  So just unconditionally install.+   doRegister+ where+  doRegister = do+    targets <- readTargetInfos verbosity pkg_descr lbi (regArgs flags) -registerOne :: PackageDescription -> LocalBuildInfo -> RegisterFlags-            -> Library-            -> IO ()-registerOne pkg lbi regFlags lib-  = do-    let clbi = getComponentLocalBuildInfo lbi (CLibName (libName lib))+    -- It's important to register in build order, because ghc-pkg+    -- will complain if a dependency is not registered.+    let maybeGenerateOne target+            | CLib lib <- targetComponent target+            = fmap Just (generateOne pkg_descr lib lbi clbi flags)+            | otherwise = return Nothing+          where clbi = targetCLBI target +    ipis <- fmap catMaybes+          . traverse maybeGenerateOne+          $ neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)+    registerAll pkg_descr lbi flags ipis+    return ()+   where+    verbosity = fromFlag (regVerbosity flags)++generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo+            -> RegisterFlags+            -> IO InstalledPackageInfo+generateOne pkg lib lbi clbi regFlags+  = do     absPackageDBs    <- absolutePackageDBPaths packageDbs-    -- TODO: registration info named base on LIBNAME!!!     installedPkgInfo <- generateRegistrationInfo                            verbosity pkg lib lbi clbi inplace reloc distPref                            (registrationPackageDB absPackageDBs)-     info verbosity (IPI.showInstalledPackageInfo installedPkgInfo)+    return installedPkgInfo+  where+    inplace   = fromFlag (regInPlace regFlags)+    reloc     = relocatable lbi+    -- FIXME: there's really no guarantee this will work.+    -- registering into a totally different db stack can+    -- fail if dependencies cannot be satisfied.+    packageDbs = nub $ withPackageDB lbi+                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))+    distPref  = fromFlag (regDistPref regFlags)+    verbosity = fromFlag (regVerbosity regFlags) +registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags+            -> [InstalledPackageInfo]+            -> IO ()+registerAll pkg lbi regFlags ipis+  = do     when (fromFlag (regPrintId regFlags)) $ do-      putStrLn (display (IPI.installedUnitId installedPkgInfo))+      for_ ipis $ \installedPkgInfo ->+        -- Only print the public library's IPI+        when (IPI.sourcePackageId installedPkgInfo == packageId pkg) $+          putStrLn (display (IPI.installedUnitId installedPkgInfo))       -- Three different modes:     case () of-     _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo-       | modeGenerateRegScript -> writeRegisterScript   installedPkgInfo+     _ | modeGenerateRegFile   -> writeRegistrationFileOrDirectory+       | modeGenerateRegScript -> writeRegisterScript        | otherwise             -> do            setupMessage verbosity "Registering" (packageId pkg)-           registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.NoMultiInstance-                           packageDbs installedPkgInfo+           for_ ipis $ \installedPkgInfo ->+               registerPackage verbosity (compiler lbi) (withPrograms lbi)+                               HcPkg.NoMultiInstance packageDbs installedPkgInfo    where     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))@@ -127,28 +166,39 @@      modeGenerateRegScript = fromFlag (regGenScript regFlags) -    inplace   = fromFlag (regInPlace regFlags)-    reloc     = relocatable lbi     -- FIXME: there's really no guarantee this will work.     -- registering into a totally different db stack can     -- fail if dependencies cannot be satisfied.     packageDbs = nub $ withPackageDB lbi                     ++ maybeToList (flagToMaybe  (regPackageDB regFlags))-    distPref  = fromFlag (regDistPref regFlags)     verbosity = fromFlag (regVerbosity regFlags) -    writeRegistrationFile installedPkgInfo = do-      notice verbosity ("Creating package registration file: " ++ regFile)-      writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)+    writeRegistrationFileOrDirectory = do+      -- Handles overwriting both directory and file+      deletePackageDB regFile+      case ipis of+        [installedPkgInfo] -> do+          info verbosity ("Creating package registration file: " ++ regFile)+          writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)+        _ -> do+          info verbosity ("Creating package registration directory: " ++ regFile)+          createDirectory regFile+          let num_ipis = length ipis+              lpad m xs = replicate (m - length ys) '0' ++ ys+                  where ys = take m xs+              number i = lpad (length (show num_ipis)) (show i)+          for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->+            writeUTF8File (regFile </> (number i ++ "-" ++ display (IPI.installedUnitId installedPkgInfo)))+                          (IPI.showInstalledPackageInfo installedPkgInfo) -    writeRegisterScript installedPkgInfo =+    writeRegisterScript =       case compilerFlavor (compiler lbi) of         JHC -> notice verbosity "Registration scripts not needed for jhc"         UHC -> notice verbosity "Registration scripts not needed for uhc"         _   -> withHcPkg                "Registration scripts are not implemented for this compiler"                (compiler lbi) (withPrograms lbi)-               (writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs)+               (writeHcPkgRegisterScript verbosity ipis packageDbs)   generateRegistrationInfo :: Verbosity@@ -168,13 +218,17 @@   --TODO: the method of setting the UnitId is compiler specific   --      this aspect should be delegated to a per-compiler helper.   let comp = compiler lbi+      lbi' = lbi {+                withPackageDB = withPackageDB lbi+                    ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]+             }   abi_hash <-     case compilerFlavor comp of-     GHC | compilerVersion comp >= Version [6,11] [] -> do-            fmap AbiHash $ GHC.libAbiHash verbosity pkg lbi lib clbi+     GHC | compilerVersion comp >= mkVersion [6,11] -> do+            fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi      GHCJS -> do-            fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi lib clbi-     _ -> return (AbiHash "")+            fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi+     _ -> return (mkAbiHash "")    installedPkgInfo <-     if inplace@@ -205,12 +259,12 @@     _   -> die "Distribution.Simple.Register.relocRegistrationInfo: \                \not implemented for this compiler" -initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath -> IO ()+initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () initPackageDB verbosity comp progdb dbPath =     createPackageDB verbosity comp progdb False dbPath  -- | Create an empty package DB at the specified location.-createPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> Bool+createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool                 -> FilePath -> IO () createPackageDB verbosity comp progdb preferCompat dbPath =     case compilerFlavor comp of@@ -222,7 +276,7 @@       _              -> die $ "Distribution.Simple.Register.createPackageDB: "                            ++ "not implemented for this compiler" -doesPackageDBExist :: FilePath -> IO Bool+doesPackageDBExist :: FilePath -> NoCallStackIO Bool doesPackageDBExist dbPath = do     -- currently one impl for all compiler flavours, but could change if needed     dir_exists <- doesDirectoryExist dbPath@@ -230,7 +284,7 @@         then return True         else doesFileExist dbPath -deletePackageDB :: FilePath -> IO ()+deletePackageDB :: FilePath -> NoCallStackIO () deletePackageDB dbPath = do     -- currently one impl for all compiler flavours, but could change if needed     dir_exists <- doesDirectoryExist dbPath@@ -241,25 +295,25 @@  -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it.-invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack+invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack                 -> [String] -> IO ()-invokeHcPkg verbosity comp conf dbStack extraArgs =-  withHcPkg "invokeHcPkg" comp conf+invokeHcPkg verbosity comp progdb dbStack extraArgs =+  withHcPkg "invokeHcPkg" comp progdb     (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) -withHcPkg :: String -> Compiler -> ProgramConfiguration+withHcPkg :: String -> Compiler -> ProgramDb           -> (HcPkg.HcPkgInfo -> IO a) -> IO a-withHcPkg name comp conf f =+withHcPkg name comp progdb f =   case compilerFlavor comp of-    GHC   -> f (GHC.hcPkgInfo conf)-    GHCJS -> f (GHCJS.hcPkgInfo conf)-    LHC   -> f (LHC.hcPkgInfo conf)+    GHC   -> f (GHC.hcPkgInfo progdb)+    GHCJS -> f (GHCJS.hcPkgInfo progdb)+    LHC   -> f (LHC.hcPkgInfo progdb)     _     -> die ("Distribution.Simple.Register." ++ name ++ ":\                   \not implemented for this compiler")  registerPackage :: Verbosity                 -> Compiler-                -> ProgramConfiguration+                -> ProgramDb                 -> HcPkg.MultiInstance                 -> PackageDBStack                 -> InstalledPackageInfo@@ -278,16 +332,20 @@     _    -> die "Registering is not implemented for this compiler"  writeHcPkgRegisterScript :: Verbosity-                         -> InstalledPackageInfo+                         -> [InstalledPackageInfo]                          -> PackageDBStack                          -> HcPkg.HcPkgInfo                          -> IO ()-writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do-  let invocation  = HcPkg.reregisterInvocation hpi Verbosity.normal-                      packageDbs (Right installedPkgInfo)-      regScript   = invocationAsSystemScript buildOS invocation+writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do+  let genScript installedPkgInfo =+          let invocation  = HcPkg.reregisterInvocation hpi Verbosity.normal+                              packageDbs (Right installedPkgInfo)+          in invocationAsSystemScript buildOS invocation+      scripts = map genScript ipis+      -- TODO: Do something more robust here+      regScript = unlines scripts -  notice verbosity ("Creating package registration script: " ++ regScriptFileName)+  info verbosity ("Creating package registration script: " ++ regScriptFileName)   writeUTF8File regScriptFileName regScript   setFileExecutable regScriptFileName @@ -319,6 +377,8 @@                                 pkgName = componentCompatPackageName clbi                              },     IPI.installedUnitId    = componentUnitId clbi,+    IPI.installedComponentId_ = componentComponentId clbi,+    IPI.instantiatedWith   = componentInstantiatedWith clbi,     IPI.compatPackageKey   = componentCompatPackageKey clbi,     IPI.license            = license     pkg,     IPI.copyright          = copyright   pkg,@@ -331,16 +391,14 @@     IPI.description        = description pkg,     IPI.category           = category    pkg,     IPI.abiHash            = abi_hash,+    IPI.indefinite         = componentIsIndefinite clbi,     IPI.exposed            = libExposed  lib,     IPI.exposedModules     = componentExposedModules clbi,     IPI.hiddenModules      = otherModules bi,     IPI.trusted            = IPI.trusted IPI.emptyInstalledPackageInfo,     IPI.importDirs         = [ libdir installDirs | hasModules ],-    -- Note. the libsubdir and datasubdir templates have already been expanded-    -- into libdir and datadir.-    IPI.libraryDirs        = if hasLibrary-                               then libdir installDirs : extraLibDirs bi-                               else                      extraLibDirs bi,+    IPI.libraryDirs        = libdirs,+    IPI.libraryDynDirs     = dynlibdirs,     IPI.dataDir            = datadir installDirs,     IPI.hsLibraries        = if hasLibrary                                then [getHSLibraryName (componentUnitId clbi)]@@ -349,7 +407,9 @@     IPI.extraGHCiLibraries = extraGHCiLibs bi,     IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,     IPI.includes           = includes bi,-    IPI.depends            = map fst (componentPackageDeps clbi),+                             --TODO: unclear what the root cause of the+                             -- duplication is, but we nub it here for now:+    IPI.depends            = ordNub $ map fst (componentPackageDeps clbi),     IPI.ccOptions          = [], -- Note. NOT ccOptions bi!                                  -- We don't want cc-options to be propagated                                  -- to C compilations in other packages.@@ -363,11 +423,26 @@   where     bi = libBuildInfo lib     (absinc, relinc) = partition isAbsolute (includeDirs bi)-    hasModules = not $ null (libModules lib)+    hasModules = not $ null (allLibModules lib clbi)+    comp = compiler lbi     hasLibrary = hasModules || not (null (cSources bi))                             || (not (null (jsSources bi)) &&-                                compilerFlavor (compiler lbi) == GHCJS)+                                compilerFlavor comp == GHCJS)+    (libdirs, dynlibdirs)+      | not hasLibrary+      = (extraLibDirs bi, [])+      -- the dynamic-library-dirs defaults to the library-dirs if not specified,+      -- so this works whether the dynamic-library-dirs field is supported or not +      | libraryDynDirSupported comp+      = (libdir    installDirs : extraLibDirs bi,+         dynlibdir installDirs : extraLibDirs bi)++      | otherwise+      = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, [])+      -- the compiler doesn't understand the dynamic-library-dirs field so we+      -- add the dyn directory to the "normal" list in the library-dirs field+ -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. --@@ -390,6 +465,7 @@     installDirs =       (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) {         libdir     = inplaceDir </> libTargetDir,+        dynlibdir  = inplaceDir </> libTargetDir,         datadir    = inplaceDir </> dataDir pkg,         docdir     = inplaceDocdir,         htmldir    = inplaceHtmldir,@@ -469,3 +545,9 @@ unregScriptFileName = case buildOS of                           Windows -> "unregister.bat"                           _       -> "unregister.sh"++internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath+internalPackageDBPath lbi distPref =+      case compilerFlavor (compiler lbi) of+        UHC -> UHC.inplacePackageDbPath lbi+        _   -> distPref </> "package.conf.inplace"
cabal/Cabal/Distribution/Simple/Setup.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoMonoLocalBinds #-}  ----------------------------------------------------------------------------- -- |@@ -35,10 +38,12 @@   GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,   configPrograms,-  AllowNewer(..),    AllowNewerDep(..),  isAllowNewer,+  RelaxDeps(..),    RelaxedDep(..),  isRelaxDeps,+  AllowNewer(..),   AllowOlder(..),   configAbsolutePaths, readPackageDbList, showPackageDbList,   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,+  HaddockTarget(..),   HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,   HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,   BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,@@ -55,6 +60,7 @@   CopyDest(..),   configureArgs, configureOptions, configureCCompiler, configureLinker,   buildOptions, haddockOptions, installDirsOptions,+  programDbOptions, programDbPaths',   programConfigurationOptions, programConfigurationPaths',   splitArgs, @@ -66,15 +72,21 @@   fromFlagOrDefault,   flagToMaybe,   flagToList,+  BooleanFlag(..),   boolOpt, boolOpt', trueArg, falseArg,   optionVerbosity, optionNumJobs, readPToMaybe ) where +import Prelude ()+import Distribution.Compat.Prelude hiding (get)+ import Distribution.Compiler import Distribution.ReadE import Distribution.Text import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp+import Distribution.ModuleName import Distribution.Package+import Distribution.Package.TextClass () import Distribution.PackageDescription hiding (Flag) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command@@ -84,16 +96,11 @@ import Distribution.Simple.InstallDirs import Distribution.Verbosity import Distribution.Utils.NubList-import Distribution.Compat.Binary (Binary)-import Distribution.Compat.Semigroup as Semi -import Control.Applicative as A ( Applicative(..), (<*) )-import Control.Monad            ( liftM )-import Data.List                ( sort )-import Data.Maybe               ( listToMaybe )-import Data.Char                ( isSpace, isAlpha )-import GHC.Generics             ( Generic )+import Distribution.Compat.Semigroup (Last' (..)) +import Data.Function (on)+ -- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist"@@ -129,7 +136,7 @@  instance Monoid (Flag a) where   mempty = NoFlag-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup (Flag a) where   _ <> f@(Flag _) = f@@ -175,6 +182,13 @@                  then Flag True                  else NoFlag +-- | Types that represent boolean flags.+class BooleanFlag a where+    asBool :: a -> Bool++instance BooleanFlag Bool where+  asBool = id+ -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------@@ -241,7 +255,7 @@  instance Monoid GlobalFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup GlobalFlags where   (<>) = gmappend@@ -250,79 +264,108 @@ -- * Config flags -- ------------------------------------------------------------ --- | Policy for relaxing upper bounds in dependencies. For example, given--- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper--- bound and choose a version of 'array' that is greater or equal to 0.5? By--- default the upper bounds are always strictly honored.-data AllowNewer =+-- | Generic data type for policy when relaxing bounds in dependencies.+-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending+-- on whether or not you are relaxing an lower or upper bound+-- (respectively).+data RelaxDeps =    -- | Default: honor the upper bounds in all dependencies, never choose   -- versions newer than allowed.-  AllowNewerNone+  RelaxDepsNone    -- | Ignore upper bounds in dependencies on the given packages.-  | AllowNewerSome [AllowNewerDep]+  | RelaxDepsSome [RelaxedDep]    -- | Ignore upper bounds in dependencies on all packages.-  | AllowNewerAll+  | RelaxDepsAll   deriving (Eq, Read, Show, Generic) +-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)+newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)++-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)+newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)+ -- | Dependencies can be relaxed either for all packages in the install plan, or -- only for some packages.-data AllowNewerDep = AllowNewerDep PackageName-                   | AllowNewerDepScoped PackageName PackageName-                   deriving (Eq, Read, Show, Generic)+data RelaxedDep = RelaxedDep PackageName+                | RelaxedDepScoped PackageName PackageName+                deriving (Eq, Read, Show, Generic) -instance Text AllowNewerDep where-  disp (AllowNewerDep p0)          = disp p0-  disp (AllowNewerDepScoped p0 p1) = disp p0 Disp.<> Disp.colon Disp.<> disp p1+instance Text RelaxedDep where+  disp (RelaxedDep p0)          = disp p0+  disp (RelaxedDepScoped p0 p1) = disp p0 Disp.<> Disp.colon Disp.<> disp p1    parse = scopedP Parse.<++ normalP     where-      scopedP = AllowNewerDepScoped `fmap` parse A.<* Parse.char ':' A.<*> parse-      normalP = AllowNewerDep       `fmap` parse+      scopedP = RelaxedDepScoped `fmap` parse <* Parse.char ':' <*> parse+      normalP = RelaxedDep       `fmap` parse +instance Binary RelaxDeps+instance Binary RelaxedDep instance Binary AllowNewer-instance Binary AllowNewerDep+instance Binary AllowOlder +instance Semigroup RelaxDeps where+  RelaxDepsNone       <> r                    = r+  l@RelaxDepsAll      <> _                    = l+  l@(RelaxDepsSome _) <> RelaxDepsNone       = l+  (RelaxDepsSome   _) <> r@RelaxDepsAll      = r+  (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)++instance Monoid RelaxDeps where+  mempty  = RelaxDepsNone+  mappend = (<>)+ instance Semigroup AllowNewer where-  AllowNewerNone       <> r                    = r-  l@AllowNewerAll      <> _                    = l-  l@(AllowNewerSome _) <> AllowNewerNone       = l-  (AllowNewerSome   _) <> r@AllowNewerAll      = r-  (AllowNewerSome   a) <> (AllowNewerSome b)   = AllowNewerSome (a ++ b)+  AllowNewer x <> AllowNewer y = AllowNewer (x <> y) +instance Semigroup AllowOlder where+  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)+ instance Monoid AllowNewer where-  mempty  = AllowNewerNone-  mappend = (Semi.<>)+  mempty  = AllowNewer mempty+  mappend = (<>) --- | Convert 'AllowNewer' to a boolean.-isAllowNewer :: AllowNewer -> Bool-isAllowNewer AllowNewerNone     = False-isAllowNewer (AllowNewerSome _) = True-isAllowNewer AllowNewerAll      = True+instance Monoid AllowOlder where+  mempty  = AllowOlder mempty+  mappend = (<>) -allowNewerParser :: Parse.ReadP r (Maybe AllowNewer)-allowNewerParser =-  (Just . AllowNewerSome) `fmap` Parse.sepBy1 parse (Parse.char ',')+-- | Convert 'RelaxDeps' to a boolean.+isRelaxDeps :: RelaxDeps -> Bool+isRelaxDeps RelaxDepsNone     = False+isRelaxDeps (RelaxDepsSome _) = True+isRelaxDeps RelaxDepsAll      = True -allowNewerPrinter :: (Maybe AllowNewer) -> [Maybe String]-allowNewerPrinter Nothing                      = []-allowNewerPrinter (Just AllowNewerNone)        = []-allowNewerPrinter (Just AllowNewerAll)         = [Nothing]-allowNewerPrinter (Just (AllowNewerSome pkgs)) = map (Just . display) $ pkgs+relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps)+relaxDepsParser =+  (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',') +relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]+relaxDepsPrinter Nothing                      = []+relaxDepsPrinter (Just RelaxDepsNone)        = []+relaxDepsPrinter (Just RelaxDepsAll)         = [Nothing]+relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs+ -- | Flags to @configure@ command. -- -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' -- should be updated.+-- IMPORTANT: every time a new flag is added, it should be added to the Eq instance data ConfigFlags = ConfigFlags {+    -- This is the same hack as in 'buildArgs' and 'copyArgs'.+    -- TODO: Stop using this eventually when 'UserHooks' gets changed+    configArgs :: [String],+     --FIXME: the configPrograms is only here to pass info through to configure     -- because the type of configure is constrained by the UserHooks.     -- when we change UserHooks next we should pass the initial-    -- ProgramConfiguration directly and not via ConfigFlags-    configPrograms_     :: Last' ProgramConfiguration, -- ^All programs that-                                                       -- @cabal@ may run+    -- ProgramDb directly and not via ConfigFlags+    configPrograms_     :: Last' ProgramDb, -- ^All programs that+                                            -- @cabal@ may run      configProgramPaths  :: [(String, FilePath)], -- ^user specified programs paths     configProgramArgs   :: [(String, [String])], -- ^user specified programs args@@ -357,8 +400,10 @@                                               -- frameworks (OS X only)     configExtraIncludeDirs :: [FilePath],   -- ^ path to search for header files     configIPID          :: Flag String, -- ^ explicit IPID to be used+    configCID           :: Flag ComponentId, -- ^ explicit CID to be used      configDistPref :: Flag FilePath, -- ^"dist" prefix+    configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use     configVerbosity :: Flag Verbosity, -- ^verbosity level     configUserInstall :: Flag Bool,    -- ^The --user\/--global flag     configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use@@ -368,8 +413,12 @@     configStripLibs :: Flag Bool,      -- ^Enable library stripping     configConstraints :: [Dependency], -- ^Additional constraints for                                        -- dependencies.-    configDependencies :: [(PackageName, UnitId)],+    configDependencies :: [(PackageName, ComponentId)],       -- ^The packages depended on.+    configInstantiateWith :: [(ModuleName, Module)],+      -- ^ The requested Backpack instantiation.  If empty, either this+      -- package does not use Backpack, or we just want to typecheck+      -- the indefinite package.     configConfigurationsFlags :: FlagAssignment,     configTests               :: Flag Bool, -- ^Enable test suite compilation     configBenchmarks          :: Flag Bool, -- ^Enable benchmark compilation@@ -382,6 +431,7 @@       -- ^Halt and show an error message indicating an error in flag assignment     configRelocatable :: Flag Bool, -- ^ Enable relocatable package built     configDebugInfo :: Flag DebugInfoLevel,  -- ^ Emit debug info.+    configAllowOlder :: Maybe AllowOlder, -- ^ dual to 'configAllowNewer'     configAllowNewer :: Maybe AllowNewer     -- ^ Ignore upper bounds on all or some dependencies. Wrapped in 'Maybe' to     -- distinguish between "default" and "explicitly disabled".@@ -392,18 +442,67 @@  -- | More convenient version of 'configPrograms'. Results in an -- 'error' if internal invariant is violated.-configPrograms :: ConfigFlags -> ProgramConfiguration+configPrograms :: ConfigFlags -> ProgramDb configPrograms = maybe (error "FIXME: remove configPrograms") id . getLast' . configPrograms_ -configAbsolutePaths :: ConfigFlags -> IO ConfigFlags+instance Eq ConfigFlags where+  (==) a b =+    -- configPrograms skipped: not user specified, has no Eq instance+    equal configProgramPaths+    && equal configProgramArgs+    && equal configProgramPathExtra+    && equal configHcFlavor+    && equal configHcPath+    && equal configHcPkg+    && equal configVanillaLib+    && equal configProfLib+    && equal configSharedLib+    && equal configDynExe+    && equal configProfExe+    && equal configProf+    && equal configProfDetail+    && equal configProfLibDetail+    && equal configConfigureArgs+    && equal configOptimization+    && equal configProgPrefix+    && equal configProgSuffix+    && equal configInstallDirs+    && equal configScratchDir+    && equal configExtraLibDirs+    && equal configExtraIncludeDirs+    && equal configIPID+    && equal configDistPref+    && equal configVerbosity+    && equal configUserInstall+    && equal configPackageDBs+    && equal configGHCiLib+    && equal configSplitObjs+    && equal configStripExes+    && equal configStripLibs+    && equal configConstraints+    && equal configDependencies+    && equal configConfigurationsFlags+    && equal configTests+    && equal configBenchmarks+    && equal configCoverage+    && equal configLibCoverage+    && equal configExactConfiguration+    && equal configFlagError+    && equal configRelocatable+    && equal configDebugInfo+    where+      equal f = on (==) f a b++configAbsolutePaths :: ConfigFlags -> NoCallStackIO ConfigFlags configAbsolutePaths f =   (\v -> f { configPackageDBs = v })-  `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath))+  `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath))   (configPackageDBs f) -defaultConfigFlags :: ProgramConfiguration -> ConfigFlags-defaultConfigFlags progConf = emptyConfigFlags {-    configPrograms_    = pure progConf,+defaultConfigFlags :: ProgramDb -> ConfigFlags+defaultConfigFlags progDb = emptyConfigFlags {+    configArgs         = [],+    configPrograms_    = pure progDb,     configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,     configVanillaLib   = Flag True,     configProfLib      = NoFlag,@@ -417,6 +516,7 @@     configProgPrefix   = Flag (toPathTemplate ""),     configProgSuffix   = Flag (toPathTemplate ""),     configDistPref     = NoFlag,+    configCabalFilePath = NoFlag,     configVerbosity    = Flag normal,     configUserInstall  = Flag False,           --TODO: reverse this #if defined(mingw32_HOST_OS)@@ -439,8 +539,8 @@     configAllowNewer   = Nothing   } -configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags-configureCommand progConf = CommandUI+configureCommand :: ProgramDb -> CommandUI ConfigFlags+configureCommand progDb = CommandUI   { commandName         = "configure"   , commandSynopsis     = "Prepare to build the package."   , commandDescription  = Just $ \_ -> wrapText $@@ -449,20 +549,32 @@       ++ "\n"       ++ "The configuration affects several other commands, "       ++ "including build, test, bench, run, repl.\n"-  , commandNotes        = Just $ \_pname -> programFlagsDescription progConf+  , commandNotes        = Just $ \_pname -> programFlagsDescription progDb   , commandUsage        = \pname ->       "Usage: " ++ pname ++ " configure [FLAGS]\n"-  , commandDefaultFlags = defaultConfigFlags progConf+  , commandDefaultFlags = defaultConfigFlags progDb   , commandOptions      = \showOrParseArgs ->          configureOptions showOrParseArgs-      ++ programConfigurationPaths   progConf showOrParseArgs+      ++ programDbPaths   progDb showOrParseArgs            configProgramPaths (\v fs -> fs { configProgramPaths = v })-      ++ programConfigurationOption progConf showOrParseArgs+      ++ programDbOption progDb showOrParseArgs            configProgramArgs (\v fs -> fs { configProgramArgs = v })-      ++ programConfigurationOptions progConf showOrParseArgs+      ++ programDbOptions progDb showOrParseArgs            configProgramArgs (\v fs -> fs { configProgramArgs = v })   } +-- | Inverse to 'dispModSubstEntry'.+parseModSubstEntry :: Parse.ReadP r (ModuleName, Module)+parseModSubstEntry =+    do k <- parse+       _ <- Parse.char '='+       v <- parse+       return (k, v)++-- | Pretty-print a single entry of a module substitution.+dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc+dispModSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v+ configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs =       [optionVerbosity configVerbosity@@ -483,6 +595,11 @@                     , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),                         "compile with a haskell-suite compiler")]) +      ,option "" ["cabal-file"]+         "use this Cabal file"+         configCabalFilePath (\v flags -> flags { configCabalFilePath = v })+         (reqArgFlag "PATH")+       ,option "w" ["with-compiler"]          "give the path to a particular compiler"          configHcPath (\v flags -> flags { configHcPath = v })@@ -634,6 +751,11 @@          configIPID (\v flags -> flags {configIPID = v})          (reqArgFlag "IPID") +      ,option "" ["cid"]+         "Installed component ID to compile this component as"+         (fmap display . configCID) (\v flags -> flags {configCID = fmap mkComponentId v})+         (reqArgFlag "CID")+       ,option "" ["extra-lib-dirs"]          "A list of directories to search for external libraries"          configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})@@ -660,10 +782,17 @@       ,option "" ["dependency"]          "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""          configDependencies (\v flags -> flags { configDependencies = v})-         (reqArg "NAME=ID"+         (reqArg "NAME=CID"                  (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency))                  (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) +      ,option "" ["instantiate-with"]+        "A mapping of signature names to concrete module instantiations."+        configInstantiateWith (\v flags -> flags { configInstantiateWith = v  })+        (reqArg "NAME=MOD"+            (readP_to_E ("Cannot parse module substitution: " ++) (fmap (:[]) parseModSubstEntry))+            (map (Disp.renderStyle defaultStyle . dispModSubstEntry)))+       ,option "" ["tests"]          "dependency checking and compilation for test suites listed in the package description file."          configTests (\v flags -> flags { configTests = v })@@ -679,12 +808,21 @@          configLibCoverage (\v flags -> flags { configLibCoverage = v })          (boolOpt [] []) +      ,option [] ["allow-older"]+       ("Ignore upper bounds in all dependencies or DEPS")+       (fmap unAllowOlder . configAllowOlder)+       (\v flags -> flags { configAllowOlder = fmap AllowOlder v})+       (optArg "DEPS"+        (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)+        (Just RelaxDepsAll) relaxDepsPrinter)+       ,option [] ["allow-newer"]        ("Ignore upper bounds in all dependencies or DEPS")-       configAllowNewer (\v flags -> flags { configAllowNewer = v})+       (fmap unAllowNewer . configAllowNewer)+       (\v flags -> flags { configAllowNewer = fmap AllowNewer v})        (optArg "DEPS"-        (readP_to_E ("Cannot parse the list of packages: " ++) allowNewerParser)-        (Just AllowNewerAll) allowNewerPrinter)+        (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)+        (Just RelaxDepsAll) relaxDepsPrinter)        ,option "" ["exact-configuration"]          "All direct dependencies and flags are provided on the command line."@@ -705,12 +843,12 @@   where     readFlagList :: String -> FlagAssignment     readFlagList = map tagWithValue . words-      where tagWithValue ('-':fname) = (FlagName (lowercase fname), False)-            tagWithValue fname       = (FlagName (lowercase fname), True)+      where tagWithValue ('-':fname) = (mkFlagName (lowercase fname), False)+            tagWithValue fname       = (mkFlagName (lowercase fname), True)      showFlagList :: FlagAssignment -> [String]-    showFlagList fs = [ if not set then '-':fname else fname-                      | (FlagName fname, set) <- fs]+    showFlagList fs = [ if not set then '-':unFlagName fname else unFlagName fname+                      | (fname, set) <- fs]      liftInstallDirs =       liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })@@ -737,7 +875,7 @@ showProfDetailLevelFlag NoFlag    = [] showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] -parseDependency :: Parse.ReadP r (PackageName, UnitId)+parseDependency :: Parse.ReadP r (PackageName, ComponentId) parseDependency = do   x <- parse   _ <- Parse.char '='@@ -766,6 +904,11 @@       libsubdir (\v flags -> flags { libsubdir = v })       installDirArg +  , option "" ["dynlibdir"]+      "installation directory for dynamic libraries"+      dynlibdir (\v flags -> flags { dynlibdir = v })+      installDirArg+   , option "" ["libexecdir"]       "installation directory for program executables"       libexecdir (\v flags -> flags { libexecdir = v })@@ -811,7 +954,7 @@  instance Monoid ConfigFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup ConfigFlags where   (<>) = gmappend@@ -827,6 +970,7 @@     copyVerbosity :: Flag Verbosity,     -- This is the same hack as in 'buildArgs'.  But I (ezyang) don't     -- think it's a hack, it's the right way to make hooks more robust+    -- TODO: Stop using this eventually when 'UserHooks' gets changed     copyArgs :: [String]   }   deriving (Show, Generic)@@ -878,7 +1022,7 @@  instance Monoid CopyFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup CopyFlags where   (<>) = gmappend@@ -949,7 +1093,7 @@  instance Monoid InstallFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup InstallFlags where   (<>) = gmappend@@ -1016,7 +1160,7 @@  instance Monoid SDistFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup SDistFlags where   (<>) = gmappend@@ -1034,7 +1178,9 @@     regInPlace     :: Flag Bool,     regDistPref    :: Flag FilePath,     regPrintId     :: Flag Bool,-    regVerbosity   :: Flag Verbosity+    regVerbosity   :: Flag Verbosity,+    -- Same as in 'buildArgs' and 'copyArgs'+    regArgs        :: [String]   }   deriving (Show, Generic) @@ -1046,6 +1192,7 @@     regInPlace     = Flag False,     regDistPref    = NoFlag,     regPrintId     = Flag False,+    regArgs        = [],     regVerbosity   = Flag normal   } @@ -1083,7 +1230,7 @@          trueArg        ,option "" ["gen-pkg-config"]-         "instead of registering, generate a package registration file"+         "instead of registering, generate a package registration file/directory"          regGenPkgConf (\v flags -> flags { regGenPkgConf  = v })          (optArg' "PKG" Flag flagToList) @@ -1129,7 +1276,7 @@  instance Monoid RegisterFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup RegisterFlags where   (<>) = gmappend@@ -1143,6 +1290,7 @@     hscolourExecutables :: Flag Bool,     hscolourTestSuites  :: Flag Bool,     hscolourBenchmarks  :: Flag Bool,+    hscolourForeignLibs :: Flag Bool,     hscolourDistPref    :: Flag FilePath,     hscolourVerbosity   :: Flag Verbosity   }@@ -1158,12 +1306,13 @@     hscolourTestSuites  = Flag False,     hscolourBenchmarks  = Flag False,     hscolourDistPref    = NoFlag,+    hscolourForeignLibs = Flag False,     hscolourVerbosity   = Flag normal   }  instance Monoid HscolourFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup HscolourFlags where   (<>) = gmappend@@ -1200,14 +1349,23 @@          hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })          trueArg +      ,option "" ["foreign-libraries"]+         "Run hscolour for Foreign Library targets"+         hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v })+         trueArg+       ,option "" ["all"]          "Run hscolour for all targets"          (\f -> allFlags [ hscolourExecutables f                          , hscolourTestSuites  f-                         , hscolourBenchmarks  f])+                         , hscolourBenchmarks  f+                         , hscolourForeignLibs f+                         ])          (\v flags -> flags { hscolourExecutables = v                             , hscolourTestSuites  = v-                            , hscolourBenchmarks  = v })+                            , hscolourBenchmarks  = v+                            , hscolourForeignLibs = v+                            })          trueArg        ,option "" ["css"]@@ -1221,16 +1379,31 @@ -- * Haddock flags -- ------------------------------------------------------------ ++-- | When we build haddock documentation, there are two cases:+--+-- 1. We build haddocks only for the current development version,+--    intended for local use and not for distribution. In this case,+--    we store the generated documentation in @<dist>/doc/html/<package name>@.+--+-- 2. We build haddocks for intended for uploading them to hackage.+--    In this case, we need to follow the layout that hackage expects+--    from documentation tarballs, and we might also want to use different+--    flags than for development builds, so in this case we store the generated+--    documentation in @<dist>/doc/html/<package id>-docs@.+data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic)+ data HaddockFlags = HaddockFlags {     haddockProgramPaths :: [(String, FilePath)],     haddockProgramArgs  :: [(String, [String])],     haddockHoogle       :: Flag Bool,     haddockHtml         :: Flag Bool,     haddockHtmlLocation :: Flag String,-    haddockForHackage   :: Flag Bool,+    haddockForHackage   :: Flag HaddockTarget,     haddockExecutables  :: Flag Bool,     haddockTestSuites   :: Flag Bool,     haddockBenchmarks   :: Flag Bool,+    haddockForeignLibs  :: Flag Bool,     haddockInternal     :: Flag Bool,     haddockCss          :: Flag FilePath,     haddockHscolour     :: Flag Bool,@@ -1249,10 +1422,11 @@     haddockHoogle       = Flag False,     haddockHtml         = Flag False,     haddockHtmlLocation = NoFlag,-    haddockForHackage   = Flag False,+    haddockForHackage   = Flag ForDevelopment,     haddockExecutables  = Flag False,     haddockTestSuites   = Flag False,     haddockBenchmarks   = Flag False,+    haddockForeignLibs  = Flag False,     haddockInternal     = Flag False,     haddockCss          = NoFlag,     haddockHscolour     = Flag False,@@ -1275,17 +1449,17 @@   , commandDefaultFlags = defaultHaddockFlags   , commandOptions      = \showOrParseArgs ->          haddockOptions showOrParseArgs-      ++ programConfigurationPaths   progConf ParseArgs+      ++ programDbPaths   progDb ParseArgs              haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})-      ++ programConfigurationOption  progConf showOrParseArgs+      ++ programDbOption  progDb showOrParseArgs              haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })-      ++ programConfigurationOptions progConf ParseArgs+      ++ programDbOptions progDb ParseArgs              haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})   }   where-    progConf = addKnownProgram haddockProgram+    progDb = addKnownProgram haddockProgram              $ addKnownProgram ghcProgram-             $ emptyProgramConfiguration+             $ emptyProgramDb  haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] haddockOptions showOrParseArgs =@@ -1318,7 +1492,7 @@   ,option "" ["for-hackage"]    "Collection of flags to generate documentation suitable for upload to hackage"    haddockForHackage (\v flags -> flags { haddockForHackage = v })-   trueArg+   (noArg (Flag ForHackage))    ,option "" ["executables"]    "Run haddock for Executables targets"@@ -1335,14 +1509,23 @@    haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })    trueArg +  ,option "" ["foreign-libraries"]+   "Run haddock for Foreign Library targets"+   haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v })+   trueArg+   ,option "" ["all"]    "Run haddock for all targets"    (\f -> allFlags [ haddockExecutables f                    , haddockTestSuites  f-                   , haddockBenchmarks  f])+                   , haddockBenchmarks  f+                   , haddockForeignLibs f+                   ])          (\v flags -> flags { haddockExecutables = v                             , haddockTestSuites  = v-                            , haddockBenchmarks  = v })+                            , haddockBenchmarks  = v+                            , haddockForeignLibs = v+                            })          trueArg    ,option "" ["internal"]@@ -1378,7 +1561,7 @@  instance Monoid HaddockFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup HaddockFlags where   (<>) = gmappend@@ -1429,7 +1612,7 @@  instance Monoid CleanFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup CleanFlags where   (<>) = gmappend@@ -1464,8 +1647,8 @@     buildArgs        = []   } -buildCommand :: ProgramConfiguration -> CommandUI BuildFlags-buildCommand progConf = CommandUI+buildCommand :: ProgramDb -> CommandUI BuildFlags+buildCommand progDb = CommandUI   { commandName         = "build"   , commandSynopsis     = "Compile all/specific components."   , commandDescription  = Just $ \_ -> wrapText $@@ -1478,7 +1661,7 @@         ++ "    All the components in the package\n"         ++ "  " ++ pname ++ " build foo       "         ++ "    A component (i.e. lib, exe, test suite)\n\n"-        ++ programFlagsDescription progConf+        ++ programFlagsDescription progDb --TODO: re-enable once we have support for module/file targets --        ++ "  " ++ pname ++ " build Foo.Bar   " --        ++ "    A module\n"@@ -1500,23 +1683,23 @@       , optionDistPref         buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs       ]-      ++ buildOptions progConf showOrParseArgs+      ++ buildOptions progDb showOrParseArgs   } -buildOptions :: ProgramConfiguration -> ShowOrParseArgs+buildOptions :: ProgramDb -> ShowOrParseArgs                 -> [OptionField BuildFlags]-buildOptions progConf showOrParseArgs =+buildOptions progDb showOrParseArgs =   [ optionNumJobs       buildNumJobs (\v flags -> flags { buildNumJobs = v })   ] -  ++ programConfigurationPaths progConf showOrParseArgs+  ++ programDbPaths progDb showOrParseArgs        buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) -  ++ programConfigurationOption progConf showOrParseArgs+  ++ programDbOption progDb showOrParseArgs        buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) -  ++ programConfigurationOptions progConf showOrParseArgs+  ++ programDbOptions progDb showOrParseArgs        buildProgramArgs (\v flags -> flags { buildProgramArgs = v})  emptyBuildFlags :: BuildFlags@@ -1524,7 +1707,7 @@  instance Monoid BuildFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup BuildFlags where   (<>) = gmappend@@ -1553,13 +1736,13 @@  instance Monoid ReplFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup ReplFlags where   (<>) = gmappend -replCommand :: ProgramConfiguration -> CommandUI ReplFlags-replCommand progConf = CommandUI+replCommand :: ProgramDb -> CommandUI ReplFlags+replCommand progDb = CommandUI   { commandName         = "repl"   , commandSynopsis     =       "Open an interpreter session for the given component."@@ -1607,13 +1790,13 @@           replDistPref (\d flags -> flags { replDistPref = d })           showOrParseArgs -      : programConfigurationPaths   progConf showOrParseArgs+      : programDbPaths   progDb showOrParseArgs           replProgramPaths (\v flags -> flags { replProgramPaths = v}) -     ++ programConfigurationOption progConf showOrParseArgs+     ++ programDbOption progDb showOrParseArgs           replProgramArgs (\v flags -> flags { replProgramArgs = v}) -     ++ programConfigurationOptions progConf showOrParseArgs+     ++ programDbOptions progDb showOrParseArgs           replProgramArgs (\v flags -> flags { replProgramArgs = v})       ++ case showOrParseArgs of@@ -1650,7 +1833,7 @@ --TODO: do we need this instance? instance Monoid TestShowDetails where     mempty = Never-    mappend = (Semi.<>)+    mappend = (<>)  instance Semigroup TestShowDetails where     a <> b = if a < b then b else a@@ -1757,7 +1940,7 @@  instance Monoid TestFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup TestFlags where   (<>) = gmappend@@ -1830,7 +2013,7 @@  instance Monoid BenchmarkFlags where   mempty = gmempty-  mappend = (Semi.<>)+  mappend = (<>)  instance Semigroup BenchmarkFlags where   (<>) = gmappend@@ -1839,39 +2022,44 @@ -- * Shared options utils -- ------------------------------------------------------------ -programFlagsDescription :: ProgramConfiguration -> String-programFlagsDescription progConf =+programFlagsDescription :: ProgramDb -> String+programFlagsDescription progDb =      "The flags --with-PROG and --PROG-option(s) can be used with"   ++ " the following programs:"   ++ (concatMap (\line -> "\n  " ++ unwords line) . wrapLine 77 . sort)-     [ programName prog | (prog, _) <- knownPrograms progConf ]+     [ programName prog | (prog, _) <- knownPrograms progDb ]   ++ "\n" --- | For each known program @PROG@ in 'progConf', produce a @with-PROG@+-- | For each known program @PROG@ in 'progDb', produce a @with-PROG@ -- 'OptionField'.-programConfigurationPaths-  :: ProgramConfiguration+programDbPaths+  :: ProgramDb   -> ShowOrParseArgs   -> (flags -> [(String, FilePath)])   -> ([(String, FilePath)] -> (flags -> flags))   -> [OptionField flags]-programConfigurationPaths progConf showOrParseArgs get set =-  programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set+programDbPaths progDb showOrParseArgs get set =+  programDbPaths' ("with-" ++) progDb showOrParseArgs get set --- | Like 'programConfigurationPaths', but allows to customise the option name.-programConfigurationPaths'+{-# DEPRECATED programConfigurationPaths' "Use programDbPaths' instead" #-}++-- | Like 'programDbPaths', but allows to customise the option name.+programDbPaths', programConfigurationPaths'   :: (String -> String)-  -> ProgramConfiguration+  -> ProgramDb   -> ShowOrParseArgs   -> (flags -> [(String, FilePath)])   -> ([(String, FilePath)] -> (flags -> flags))   -> [OptionField flags]-programConfigurationPaths' mkName progConf showOrParseArgs get set =++programConfigurationPaths' = programDbPaths'++programDbPaths' mkName progDb showOrParseArgs get set =   case showOrParseArgs of     -- we don't want a verbose help text list so we just show a generic one:     ShowArgs  -> [withProgramPath "PROG"]     ParseArgs -> map (withProgramPath . programName . fst)-                 (knownPrograms progConf)+                 (knownPrograms progDb)   where     withProgramPath prog =       option "" [mkName prog]@@ -1880,20 +2068,20 @@         (reqArg' "PATH" (\path -> [(prog, path)])           (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) --- | For each known program @PROG@ in 'progConf', produce a @PROG-option@+-- | For each known program @PROG@ in 'progDb', produce a @PROG-option@ -- 'OptionField'.-programConfigurationOption-  :: ProgramConfiguration+programDbOption+  :: ProgramDb   -> ShowOrParseArgs   -> (flags -> [(String, [String])])   -> ([(String, [String])] -> (flags -> flags))   -> [OptionField flags]-programConfigurationOption progConf showOrParseArgs get set =+programDbOption progDb showOrParseArgs get set =   case showOrParseArgs of     -- we don't want a verbose help text list so we just show a generic one:     ShowArgs  -> [programOption "PROG"]     ParseArgs -> map (programOption  . programName . fst)-                 (knownPrograms progConf)+                 (knownPrograms progDb)   where     programOption prog =       option "" [prog ++ "-option"]@@ -1904,20 +2092,25 @@            (\progArgs -> concat [ args                                 | (prog', args) <- progArgs, prog==prog' ])) --- | For each known program @PROG@ in 'progConf', produce a @PROG-options@+{-# DEPRECATED programConfigurationOptions "Use programDbOptions instead" #-}++-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ -- 'OptionField'.-programConfigurationOptions-  :: ProgramConfiguration+programDbOptions, programConfigurationOptions+  :: ProgramDb   -> ShowOrParseArgs   -> (flags -> [(String, [String])])   -> ([(String, [String])] -> (flags -> flags))   -> [OptionField flags]-programConfigurationOptions progConf showOrParseArgs get set =++programConfigurationOptions = programDbOptions++programDbOptions progDb showOrParseArgs get set =   case showOrParseArgs of     -- we don't want a verbose help text list so we just show a generic one:     ShowArgs  -> [programOptions  "PROG"]     ParseArgs -> map (programOptions . programName . fst)-                 (knownPrograms progConf)+                 (knownPrograms progDb)   where     programOptions prog =       option "" [prog ++ "-options"]@@ -2028,17 +2221,17 @@                                                  . config_field                                                  . configInstallDirs) -configureCCompiler :: Verbosity -> ProgramConfiguration+configureCCompiler :: Verbosity -> ProgramDb                       -> IO (FilePath, [String])-configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram+configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram -configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String])-configureLinker verbosity lbi = configureProg verbosity lbi ldProgram+configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String])+configureLinker verbosity progdb = configureProg verbosity progdb ldProgram -configureProg :: Verbosity -> ProgramConfiguration -> Program+configureProg :: Verbosity -> ProgramDb -> Program                  -> IO (FilePath, [String])-configureProg verbosity programConfig prog = do-    (p, _) <- requireProgram verbosity prog programConfig+configureProg verbosity programDb prog = do+    (p, _) <- requireProgram verbosity prog programDb     let pInv = programInvocation p []     return (progInvokePath pInv, progInvokeArgs pInv)
cabal/Cabal/Distribution/Simple/SrcDist.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.SrcDist@@ -40,6 +43,9 @@    )  where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.PackageDescription hiding (Flag) import Distribution.PackageDescription.Check hiding (doesFileExist) import Distribution.Package@@ -53,18 +59,16 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Program import Distribution.Text+import Distribution.Types.ForeignLib import Distribution.Verbosity -import Control.Monad(when, unless, forM)-import Data.Char (toLower)-import Data.List (partition, isPrefixOf)+import Data.List (partition) import qualified Data.Map as Map-import Data.Maybe (isNothing, catMaybes) import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) import System.Directory ( doesFileExist ) import System.IO (IOMode(WriteMode), hPutStrLn, withFile)-import System.FilePath-         ( (</>), (<.>), dropExtension, isAbsolute )+import System.FilePath ((</>), (<.>), dropExtension, isRelative)+import Control.Monad  -- |Create a source distribution. sdist :: PackageDescription     -- ^information from the tarball@@ -79,8 +83,8 @@   case (sDistListSources flags) of     Flag path -> withFile path WriteMode $ \outHandle -> do       (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps-      mapM_ (hPutStrLn outHandle) ordinary-      mapM_ (hPutStrLn outHandle) maybeExecutable+      traverse_ (hPutStrLn outHandle) ordinary+      traverse_ (hPutStrLn outHandle) maybeExecutable       notice verbosity $ "List of package sources written to file '"                          ++ path ++ "'"     NoFlag    -> do@@ -136,13 +140,13 @@   maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr   return (ordinary, maybeExecutable)   where-    pkg_descr = filterAutogenModule pkg_descr0+    pkg_descr = filterAutogenModules pkg_descr0  -- | List those source files that may be executable (e.g. the configure script). listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath] listPackageSourcesMaybeExecutable pkg_descr =   -- Extra source files.-  fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath+  fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath  -- | List those source files that should be copied with ordinary permissions. listPackageSourcesOrdinary :: Verbosity@@ -150,12 +154,16 @@                            -> [PPSuffixHandler]                            -> IO [FilePath] listPackageSourcesOrdinary verbosity pkg_descr pps =-  fmap concat . sequence $+  fmap concat . sequenceA $   [     -- Library sources.     fmap concat-    . withAllLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->-     allSourcesBuildInfo libBi pps modules+    . withAllLib $ \Library {+                      exposedModules = modules,+                      signatures     = sigs,+                      libBuildInfo   = libBi+                    } ->+     allSourcesBuildInfo libBi pps (modules ++ sigs)      -- Executables sources.   , fmap concat@@ -164,6 +172,13 @@        mainSrc <- findMainExeFile exeBi pps mainPath        return (mainSrc:biSrcs) +    -- Foreign library sources+  , fmap concat+    . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do+       biSrcs   <- allSourcesBuildInfo flibBi pps []+       defFiles <- mapM (findModDefFile flibBi pps) (foreignLibModDefFile flib)+       return (defFiles ++ biSrcs)+     -- Test suites sources.   , fmap concat     . withAllTest $ \t -> do@@ -171,12 +186,7 @@        case testInterface t of          TestSuiteExeV10 _ mainPath -> do            biSrcs <- allSourcesBuildInfo bi pps []-           srcMainFile <- do-             ppFile <- findFileWithExtension (ppSuffixes pps)-                       (hsSourceDirs bi) (dropExtension mainPath)-             case ppFile of-               Nothing -> findFile (hsSourceDirs bi) mainPath-               Just pp -> return pp+           srcMainFile <- findMainExeFile bi pps mainPath            return (srcMainFile:biSrcs)          TestSuiteLibV09 _ m ->            allSourcesBuildInfo bi pps [m]@@ -190,24 +200,19 @@        case benchmarkInterface bm of          BenchmarkExeV10 _ mainPath -> do            biSrcs <- allSourcesBuildInfo bi pps []-           srcMainFile <- do-             ppFile <- findFileWithExtension (ppSuffixes pps)-                       (hsSourceDirs bi) (dropExtension mainPath)-             case ppFile of-               Nothing -> findFile (hsSourceDirs bi) mainPath-               Just pp -> return pp+           srcMainFile <- findMainExeFile bi pps mainPath            return (srcMainFile:biSrcs)          BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: "                                     ++ show tp      -- Data files.   , fmap concat-    . forM (dataFiles pkg_descr) $ \filename ->+    . for (dataFiles pkg_descr) $ \filename ->        matchFileGlob (dataDir pkg_descr </> filename)      -- Extra doc files.   , fmap concat-    . forM (extraDocFiles pkg_descr) $ \ filename ->+    . for (extraDocFiles pkg_descr) $ \ filename ->       matchFileGlob filename      -- License file(s).@@ -217,8 +222,8 @@   , fmap concat     . withAllLib $ \ l -> do        let lbi = libBuildInfo l-           relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)-       mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi)+           relincdirs = "." : filter isRelative (includeDirs lbi)+       traverse (fmap snd . findIncludeFile relincdirs) (installIncludes lbi)      -- Setup script, if it exists.   , fmap (maybe [] (\f -> [f])) $ findSetupFile ""@@ -230,10 +235,11 @@   where     -- We have to deal with all libs and executables, so we have local     -- versions of these functions that ignore the 'buildable' attribute:-    withAllLib       action = mapM action (libraries pkg_descr)-    withAllExe       action = mapM action (executables pkg_descr)-    withAllTest      action = mapM action (testSuites pkg_descr)-    withAllBenchmark action = mapM action (benchmarks pkg_descr)+    withAllLib       action = traverse action (allLibraries pkg_descr)+    withAllFLib      action = traverse action (foreignLibs pkg_descr)+    withAllExe       action = traverse action (executables pkg_descr)+    withAllTest      action = traverse action (testSuites pkg_descr)+    withAllBenchmark action = traverse action (benchmarks pkg_descr)   -- |Prepare a directory tree of source files.@@ -259,10 +265,10 @@   maybeCreateDefaultSetupScript targetDir    where-    pkg_descr = filterAutogenModule pkg_descr0+    pkg_descr = filterAutogenModules pkg_descr0  -- | Find the setup script file, if it exists.-findSetupFile :: FilePath -> IO (Maybe FilePath)+findSetupFile :: FilePath -> NoCallStackIO (Maybe FilePath) findSetupFile targetDir = do   hsExists  <- doesFileExist setupHs   lhsExists <- doesFileExist setupLhs@@ -276,7 +282,7 @@       setupLhs = targetDir </> "Setup.lhs"  -- | Create a default setup script in the target directory, if it doesn't exist.-maybeCreateDefaultSetupScript :: FilePath -> IO ()+maybeCreateDefaultSetupScript :: FilePath -> NoCallStackIO () maybeCreateDefaultSetupScript targetDir = do   mSetupFile <- findSetupFile targetDir   case mSetupFile of@@ -295,6 +301,13 @@     Nothing -> findFile (hsSourceDirs exeBi) mainPath     Just pp -> return pp +-- | Find a module definition file+--+-- TODO: I don't know if this is right+findModDefFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath+findModDefFile flibBi _pps modDefPath =+    findFile (".":hsSourceDirs flibBi) modDefPath+ -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file.@@ -305,20 +318,24 @@   b <- doesFileExist path   if b then return (f,path) else findIncludeFile ds f --- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and--- 'other-modules'.-filterAutogenModule :: PackageDescription -> PackageDescription-filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $+-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' +-- and 'other-modules'.+filterAutogenModules :: PackageDescription -> PackageDescription+filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $                                  mapAllBuildInfo filterAutogenModuleBI pkg_descr0   where-    mapLib f pkg = pkg { libraries = map f (libraries pkg) }+    mapLib f pkg = pkg { library      = fmap f (library pkg)+                       , subLibraries = map f (subLibraries pkg) }     filterAutogenModuleLib lib = lib {-      exposedModules = filter (/=autogenModule) (exposedModules lib)+      exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)     }     filterAutogenModuleBI bi = bi {-      otherModules   = filter (/=autogenModule) (otherModules bi)+      otherModules   = filter (filterFunction bi) (otherModules bi)     }-    autogenModule = autogenModuleName pkg_descr0+    pathsModule = autogenPathsModuleName pkg_descr0+    filterFunction bi = \mn ->+                                   mn /= pathsModule+                                && not (elem mn (autogenModules bi))  -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set@@ -368,10 +385,7 @@ -- to the given date. -- snapshotVersion :: UTCTime -> Version -> Version-snapshotVersion date version = version {-    versionBranch = versionBranch version-                 ++ [dateToSnapshotNumber date]-  }+snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date])  -- | Given a date produce a corresponding integer representation. -- For example given a date @18/03/2008@ produce the number @20080318@.@@ -397,7 +411,7 @@   let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"    (tarProg, _) <- requireProgram verbosity tarProgram-                    (maybe defaultProgramConfiguration withPrograms mb_lbi)+                    (maybe defaultProgramDb withPrograms mb_lbi)   let formatOptSupported = maybe False (== "YES") $                            Map.lookup "Supports --format"                            (programProperties tarProg)@@ -418,12 +432,15 @@                        -> IO [FilePath] allSourcesBuildInfo bi pps modules = do   let searchDirs = hsSourceDirs bi-  sources <- fmap concat $ sequence $+  sources <- fmap concat $ sequenceA $     [ let file = ModuleName.toFilePath module_+      -- NB: *Not* findFileWithExtension, because the same source+      -- file may show up in multiple paths due to a conditional;+      -- we need to package all of them.  See #367.       in findAllFilesWithExtension suffixes searchDirs file          >>= nonEmpty (notFound module_) return     | module_ <- modules ++ otherModules bi ]-  bootFiles <- sequence+  bootFiles <- sequenceA     [ let file = ModuleName.toFilePath module_           fileExts = ["hs-boot", "lhs-boot"]       in findFileWithExtension fileExts (hsSourceDirs bi) file@@ -434,9 +451,10 @@   where     nonEmpty x _ [] = x     nonEmpty _ f xs = f xs-    suffixes = ppSuffixes pps ++ ["hs", "lhs"]+    suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"]     notFound m = die $ "Error: Could not find module: " ++ display m-                 ++ " with any suffix: " ++ show suffixes+                 ++ " with any suffix: " ++ show suffixes ++ ". If the module "+                 ++ "is autogenerated it should be added to 'autogen-modules'."   printPackageProblems :: Verbosity -> PackageDescription -> IO ()@@ -467,13 +485,16 @@ mapAllBuildInfo :: (BuildInfo -> BuildInfo)                 -> (PackageDescription -> PackageDescription) mapAllBuildInfo f pkg = pkg {-    libraries   = fmap mapLibBi (libraries pkg),+    library     = fmap mapLibBi (library pkg),+    subLibraries = fmap mapLibBi (subLibraries pkg),+    foreignLibs = fmap mapFLibBi (foreignLibs pkg),     executables = fmap mapExeBi (executables pkg),     testSuites  = fmap mapTestBi (testSuites pkg),     benchmarks  = fmap mapBenchBi (benchmarks pkg)   }   where-    mapLibBi lib  = lib { libBuildInfo       = f (libBuildInfo lib) }-    mapExeBi exe  = exe { buildInfo          = f (buildInfo exe) }-    mapTestBi t   = t   { testBuildInfo      = f (testBuildInfo t) }-    mapBenchBi bm = bm  { benchmarkBuildInfo = f (benchmarkBuildInfo bm) }+    mapLibBi   lib  = lib  { libBuildInfo        = f (libBuildInfo lib) }+    mapFLibBi  flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) }+    mapExeBi   exe  = exe  { buildInfo           = f (buildInfo exe) }+    mapTestBi  tst  = tst  { testBuildInfo       = f (testBuildInfo tst) }+    mapBenchBi bm   = bm   { benchmarkBuildInfo  = f (benchmarkBuildInfo bm) }
cabal/Cabal/Distribution/Simple/Test.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Test@@ -15,11 +18,16 @@     ( test     ) where +import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.Simple.Compiler import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI+import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Simple.Setup import Distribution.Simple.UserHooks import qualified Distribution.Simple.Test.ExeV10 as ExeV10@@ -29,7 +37,6 @@ import Distribution.TestSuite import Distribution.Text -import Control.Monad ( when, unless, filterM ) import System.Directory     ( createDirectoryIfMissing, doesFileExist, getDirectoryContents     , removeFile )@@ -49,23 +56,22 @@         testLogDir = distPref </> "test"         testNames = args         pkgTests = PD.testSuites pkg_descr-        enabledTests = [ t | t <- pkgTests-                           , PD.testEnabled t-                           , PD.buildable (PD.testBuildInfo t) ]+        enabledTests = LBI.enabledTestLBIs pkg_descr lbi -        doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog-        doTest (suite, _) =+        doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo),+                    Maybe TestSuiteLog) -> IO TestSuiteLog+        doTest ((suite, clbi), _) =             case PD.testInterface suite of               PD.TestSuiteExeV10 _ _ ->-                  ExeV10.runTest pkg_descr lbi flags suite+                  ExeV10.runTest pkg_descr lbi clbi flags suite                PD.TestSuiteLibV09 _ _ ->-                  LibV09.runTest pkg_descr lbi flags suite+                  LibV09.runTest pkg_descr lbi clbi flags suite                _ -> return TestSuiteLog                   { testSuiteName = PD.testName suite                   , testLogs = TestLog-                      { testName = PD.testName suite+                      { testName = unUnqualComponentName $ PD.testName suite                       , testOptionsReturned = []                       , testResult =                           Error $ "No support for running test suite type: "@@ -84,13 +90,14 @@      testsToRun <- case testNames of             [] -> return $ zip enabledTests $ repeat Nothing-            names -> flip mapM names $ \tName ->+            names -> flip traverse names $ \tName ->                 let testMap = zip enabledNames enabledTests-                    enabledNames = map PD.testName enabledTests+                    enabledNames = map (PD.testName . fst) enabledTests                     allNames = map PD.testName pkgTests-                in case lookup tName testMap of+                    tCompName = mkUnqualComponentName tName+                in case lookup tCompName testMap of                     Just t -> return (t, Nothing)-                    _ | tName `elem` allNames ->+                    _ | tCompName `elem` allNames ->                           die $ "Package configured with test suite "                                 ++ tName ++ " disabled."                       | otherwise -> die $ "no such test: " ++ tName@@ -100,21 +107,20 @@     -- Delete ordinary files from test log directory.     getDirectoryContents testLogDir         >>= filterM doesFileExist . map (testLogDir </>)-        >>= mapM_ removeFile+        >>= traverse_ removeFile      let totalSuites = length testsToRun     notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."-    suites <- mapM doTest testsToRun+    suites <- traverse doTest testsToRun     let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites }         packageLogFile = (</>) testLogDir             $ packageLogPath machineTemplate pkg_descr lbi     allOk <- summarizePackage verbosity packageLog     writeFile packageLogFile $ show packageLog -    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi-    when isCoverageEnabled $+    when (LBI.testCoverage lbi) $         markupPackage verbosity lbi distPref (display $ PD.package pkg_descr) $-            map fst testsToRun+            map (fst . fst) testsToRun      unless allOk exitFailure
cabal/Cabal/Distribution/Simple/Test/ExeV10.hs view
@@ -1,7 +1,14 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ module Distribution.Simple.Test.ExeV10        ( runTest        ) where +import Prelude ()+import Distribution.Package+import Distribution.Compat.Prelude+ import Distribution.Compat.CreatePipe import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD@@ -11,6 +18,7 @@ import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI+import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Simple.Setup import Distribution.Simple.Test.Log import Distribution.Simple.Utils@@ -20,7 +28,6 @@ import Distribution.Verbosity  import Control.Concurrent (forkIO)-import Control.Monad ( unless, void, when ) import System.Directory     ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist     , getCurrentDirectory, removeDirectoryRecursive )@@ -30,19 +37,20 @@  runTest :: PD.PackageDescription         -> LBI.LocalBuildInfo+        -> LBI.ComponentLocalBuildInfo         -> TestFlags         -> PD.TestSuite         -> IO TestSuiteLog-runTest pkg_descr lbi flags suite = do-    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi+runTest pkg_descr lbi clbi flags suite = do+    let isCoverageEnabled = LBI.testCoverage lbi         way = guessWay lbi-        tixDir_ = tixDir distPref way $ PD.testName suite+        tixDir_ = tixDir distPref way testName'      pwd <- getCurrentDirectory     existingEnv <- getEnvironment -    let cmd = LBI.buildDir lbi </> PD.testName suite-                  </> PD.testName suite <.> exeExtension+    let cmd = LBI.buildDir lbi </> testName'+                  </> testName' <.> exeExtension     -- Check that the test executable exists.     exists <- doesFileExist cmd     unless exists $ die $ "Error: Could not find test program \"" ++ cmd@@ -57,7 +65,7 @@     createDirectoryIfMissing True tixDir_      -- Write summary notices indicating start of test suite-    notice verbosity $ summarizeSuiteStart $ PD.testName suite+    notice verbosity $ summarizeSuiteStart $ testName'      (wOut, wErr, logText) <- case details of         Direct -> return (stdout, stderr, "")@@ -78,7 +86,7 @@     let opts = map (testOption pkg_descr lbi suite)                    (testOptions flags)         dataDirPath = pwd </> PD.dataDir pkg_descr-        tixFile = pwd </> tixFilePath distPref way (PD.testName suite)+        tixFile = pwd </> tixFilePath distPref way (testName')         pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)                    : existingEnv         shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv@@ -86,8 +94,6 @@     -- Add (DY)LD_LIBRARY_PATH if needed     shellEnv' <- if LBI.withDynExe lbi                     then do let (Platform _ os) = LBI.hostPlatform lbi-                                clbi = LBI.getComponentLocalBuildInfo lbi-                                         (LBI.CTestName (PD.testName suite))                             paths <- LBI.depLibraryPaths True False lbi clbi                             return (addLibraryPath os paths shellEnv)                     else return shellEnv@@ -101,7 +107,7 @@     let suiteLog = buildLog exit      -- Write summary notice to log file indicating start of test suite-    appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite+    appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName'      -- Append contents of temporary log file to the final human-     -- readable log file@@ -127,6 +133,8 @@      return suiteLog   where+    testName' = unUnqualComponentName $ PD.testName suite+     distPref = fromFlag $ testDistPref flags     verbosity = fromFlag $ testVerbosity flags     details = fromFlag $ testShowDetails flags@@ -136,19 +144,19 @@         let r = case exit of                     ExitSuccess -> Pass                     ExitFailure c -> Fail $ "exit code: " ++ show c-            n = PD.testName suite+            --n = unUnqualComponentName $ PD.testName suite             l = TestLog-                { testName = n+                { testName = testName'                 , testOptionsReturned = []                 , testResult = r                 }         in TestSuiteLog-                { testSuiteName = n+                { testSuiteName = PD.testName suite                 , testLogs = l                 , logFile =                     testLogDir                     </> testSuiteLogPath (fromFlag $ testHumanLog flags)-                                         pkg_descr lbi n l+                                         pkg_descr lbi testName' l                 }  -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't@@ -164,4 +172,4 @@     env = initialPathTemplateEnv           (PD.package pkg_descr) (LBI.localUnitId lbi)           (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]+          [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]
cabal/Cabal/Distribution/Simple/Test/LibV09.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ module Distribution.Simple.Test.LibV09        ( runTest          -- Test stub@@ -6,6 +9,10 @@        , writeSimpleTestStub        ) where +import Prelude ()+import Distribution.Package+import Distribution.Compat.Prelude+ import Distribution.Compat.CreatePipe import Distribution.Compat.Environment import Distribution.Compat.Internal.TempFile@@ -17,6 +24,7 @@ import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI+import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Simple.Setup import Distribution.Simple.Test.Log import Distribution.Simple.Utils@@ -25,9 +33,7 @@ import Distribution.Text import Distribution.Verbosity -import Control.Exception ( bracket )-import Control.Monad ( when, unless )-import Data.Maybe ( mapMaybe )+import qualified Control.Exception as CE import System.Directory     ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist     , getCurrentDirectory, removeDirectoryRecursive, removeFile@@ -39,11 +45,12 @@  runTest :: PD.PackageDescription         -> LBI.LocalBuildInfo+        -> LBI.ComponentLocalBuildInfo         -> TestFlags         -> PD.TestSuite         -> IO TestSuiteLog-runTest pkg_descr lbi flags suite = do-    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi+runTest pkg_descr lbi clbi flags suite = do+    let isCoverageEnabled = LBI.testCoverage lbi         way = guessWay lbi      pwd <- getCurrentDirectory@@ -58,17 +65,17 @@      -- Remove old .tix files if appropriate.     unless (fromFlag $ testKeepTix flags) $ do-        let tDir = tixDir distPref way $ PD.testName suite+        let tDir = tixDir distPref way testName'         exists' <- doesDirectoryExist tDir         when exists' $ removeDirectoryRecursive tDir      -- Create directory for HPC files.-    createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite+    createDirectoryIfMissing True $ tixDir distPref way testName'      -- Write summary notices indicating start of test suite-    notice verbosity $ summarizeSuiteStart $ PD.testName suite+    notice verbosity $ summarizeSuiteStart testName' -    suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do+    suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do          (rOut, wOut) <- createPipe @@ -76,7 +83,7 @@         (Just wIn, _, _, process) <- do                 let opts = map (testOption pkg_descr lbi suite) $ testOptions flags                     dataDirPath = pwd </> PD.dataDir pkg_descr-                    tixFile = pwd </> tixFilePath distPref way (PD.testName suite)+                    tixFile = pwd </> tixFilePath distPref way testName'                     pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)                                : existingEnv                     shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]@@ -85,10 +92,6 @@                 shellEnv' <- if LBI.withDynExe lbi                                 then do                                   let (Platform _ os) = LBI.hostPlatform lbi-                                      clbi = LBI.getComponentLocalBuildInfo-                                                   lbi-                                                   (LBI.CTestName-                                                      (PD.testName suite))                                   paths <- LBI.depLibraryPaths                                              True False lbi clbi                                   return (addLibraryPath os paths shellEnv)@@ -114,14 +117,14 @@         let finalLogName l = testLogDir                              </> testSuiteLogPath                                  (fromFlag $ testHumanLog flags) pkg_descr lbi-                                 (testSuiteName l) (testLogs l)+                                 (unUnqualComponentName $ testSuiteName l) (testLogs l)         -- Generate TestSuiteLog from executable exit code and a machine-         -- readable test log-        suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read)+        suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read) -- TODO: eradicateNoParse                     $ readFile tempLog          -- Write summary notice to log file indicating start of test suite-        appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite+        appendFile (logFile suiteLog) $ summarizeSuiteStart testName'          appendFile (logFile suiteLog) logText @@ -146,6 +149,8 @@      return suiteLog   where+    testName' = unUnqualComponentName $ PD.testName suite+         deleteIfExists file = do         exists <- doesFileExist file         when exists $ removeFile file@@ -171,13 +176,13 @@     env = initialPathTemplateEnv           (PD.package pkg_descr) (LBI.localUnitId lbi)           (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]+          [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]  -- Test stub ----------  -- | The name of the stub executable associated with a library 'TestSuite'. stubName :: PD.TestSuite -> FilePath-stubName t = PD.testName t ++ "Stub"+stubName t = unUnqualComponentName (PD.testName t) ++ "Stub"  -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'.@@ -189,7 +194,7 @@                                     -- is being created                     -> FilePath     -- ^ path to directory where stub source                                     -- should be located-                    -> IO ()+                    -> NoCallStackIO () writeSimpleTestStub t dir = do     createDirectoryIfMissing True dir     let filename = dir </> stubFilePath t@@ -211,11 +216,18 @@ -- of detectable errors when Cabal is compiled. stubMain :: IO [Test] -> IO () stubMain tests = do-    (f, n) <- fmap read getContents+    (f, n) <- fmap read getContents -- TODO: eradicateNoParse     dir <- getCurrentDirectory-    results <- tests >>= stubRunTests+    results <- (tests >>= stubRunTests) `CE.catch` errHandler     setCurrentDirectory dir     stubWriteLog f n results+  where+    errHandler :: CE.SomeException -> NoCallStackIO TestLogs+    errHandler e = case CE.fromException e of+        Just CE.UserInterrupt -> CE.throwIO e+        _ -> return $ TestLog { testName = "Cabal test suite exception",+                                testOptionsReturned = [],+                                testResult = Error $ show e }  -- | The test runner used in library "TestSuite" stub executables.  Runs a list -- of 'Test's.  An executable calling this function is meant to be invoked as@@ -226,7 +238,7 @@ -- by the calling Cabal process. stubRunTests :: [Test] -> IO TestLogs stubRunTests tests = do-    logs <- mapM stubRunTests' tests+    logs <- traverse stubRunTests' tests     return $ GroupLogs "Default" logs   where     stubRunTests' (Test t) = do@@ -242,7 +254,7 @@                 }         finish (Progress _ next) = next >>= finish     stubRunTests' g@(Group {}) = do-        logs <- mapM stubRunTests' $ groupTests g+        logs <- traverse stubRunTests' $ groupTests g         return $ GroupLogs (groupName g) logs     stubRunTests' (ExtraOptions _ t) = stubRunTests' t     maybeDefaultOption opt =@@ -251,7 +263,7 @@  -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling -- Cabal process to read.-stubWriteLog :: FilePath -> String -> TestLogs -> IO ()+stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> NoCallStackIO () stubWriteLog f n logs = do     let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }     writeFile (logFile testLog) $ show testLog
cabal/Cabal/Distribution/Simple/Test/Log.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ module Distribution.Simple.Test.Log        ( PackageLog(..)        , TestLogs(..)@@ -11,6 +14,9 @@        , testSuiteLogPath        ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.Simple.Compiler@@ -21,9 +27,7 @@ import Distribution.System import Distribution.TestSuite import Distribution.Verbosity--import Control.Monad ( when )-import Data.Char ( toUpper )+import Distribution.Text  -- | Logs all test results for a package, broken down first by test suite and -- then by test case.@@ -46,7 +50,7 @@  -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog-    { testSuiteName :: String+    { testSuiteName :: UnqualComponentName     , testLogs :: TestLogs     , logFile :: FilePath    -- path to human-readable log file     }@@ -150,7 +154,7 @@ -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String summarizeSuiteFinish testLog = unlines-    [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr+    [ "Test suite " ++ display (testSuiteName testLog) ++ ": " ++ resStr     , "Test suite logged to: " ++ logFile testLog     ]     where resStr = map toUpper (resultString $ testLogs testLog)
cabal/Cabal/Distribution/Simple/UHC.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.UHC@@ -19,6 +22,9 @@     buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Compat.ReadP import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId)@@ -35,9 +41,7 @@ import Distribution.System import Language.Haskell.Extension -import Control.Monad-import Data.List-import qualified Data.Map as M ( empty )+import qualified Data.Map as Map ( empty ) import System.Directory import System.FilePath @@ -45,13 +49,13 @@ -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do+          -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)+configure verbosity hcPath _hcPkgPath progdb = do -  (_uhcProg, uhcVersion, conf') <-+  (_uhcProg, uhcVersion, progdb') <-     requireProgramVersion verbosity uhcProgram-    (orLaterVersion (Version [1,0,2] []))-    (userMaybeSpecifyPath "uhc" hcPath conf)+    (orLaterVersion (mkVersion [1,0,2]))+    (userMaybeSpecifyPath "uhc" hcPath progdb)    let comp = Compiler {                compilerId         =  CompilerId UHC uhcVersion,@@ -59,10 +63,10 @@                compilerCompat     =  [],                compilerLanguages  =  uhcLanguages,                compilerExtensions =  uhcLanguageExtensions,-               compilerProperties =  M.empty+               compilerProperties =  Map.empty              }       compPlatform = Nothing-  return (comp, compPlatform, conf')+  return (comp, compPlatform, progdb')  uhcLanguages :: [(Language, C.Flag)] uhcLanguages = [(Haskell98, "")]@@ -88,16 +92,16 @@      (OverlappingInstances,         alwaysOn),      (FlexibleInstances,            alwaysOn)] -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration+getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb                      -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packagedbs conf = do+getInstalledPackages verbosity comp packagedbs progdb = do   let compilerid = compilerId comp-  systemPkgDir <- getGlobalPackageDir verbosity conf+  systemPkgDir <- getGlobalPackageDir verbosity progdb   userPkgDir   <- getUserPackageDir   let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)   -- putStrLn $ "pkgdirs: " ++ show pkgDirs   pkgs <- liftM (map addBuiltinVersions . concat) $-          mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d))+          traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d))           pkgDirs   -- putStrLn $ "pkgs: " ++ show pkgs   let iPkgs =@@ -107,15 +111,15 @@   -- putStrLn $ "installed pkgs: " ++ show iPkgs   return (fromList iPkgs) -getGlobalPackageDir :: Verbosity -> ProgramConfiguration -> IO FilePath-getGlobalPackageDir verbosity conf = do-    output <- rawSystemProgramStdoutConf verbosity-                uhcProgram conf ["--meta-pkgdir-system"]+getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath+getGlobalPackageDir verbosity progdb = do+    output <- getDbProgramOutput verbosity+                uhcProgram progdb ["--meta-pkgdir-system"]     -- call to "lines" necessary, because pkgdir contains an extra newline at the end     let [pkgdir] = lines output     return pkgdir -getUserPackageDir :: IO FilePath+getUserPackageDir :: NoCallStackIO FilePath getUserPackageDir = do     homeDir <- getHomeDirectory     return $ homeDir </> ".cabal" </> "lib"  -- TODO: determine in some other way@@ -144,7 +148,7 @@ -- | Check if a certain dir contains a valid package. Currently, we are -- looking only for the presence of an installed package configuration. -- TODO: Actually make use of the information provided in the file.-isPkgDir :: String -> String -> String -> IO Bool+isPkgDir :: String -> String -> String -> NoCallStackIO Bool isPkgDir _ _   ('.' : _)  = return False  -- ignore files starting with a . isPkgDir c dir xs         = do                               let candidate = dir </> uhcPackageDir xs c@@ -170,7 +174,7 @@    systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)   userPkgDir   <- getUserPackageDir-  let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi)+  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)   let uhcArgs =    -- set package name                    ["--pkg-build=" ++ display (packageId pkg_descr)]                    -- common flags lib/exe@@ -181,10 +185,10 @@                    -- suboptimal: UHC does not understand module names, so                    -- we replace periods by path separators                 ++ map (map (\ c -> if c == '.' then pathSeparator else c))-                       (map display (libModules lib))+                       (map display (allLibModules lib clbi))    runUhcProg uhcArgs-  +   return ()  buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo@@ -192,13 +196,13 @@ buildExe verbosity _pkg_descr lbi exe clbi = do   systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)   userPkgDir   <- getUserPackageDir-  let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi)+  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)   let uhcArgs =    -- common flags lib/exe                    constructUHCCmdLine userPkgDir systemPkgDir                                        lbi (buildInfo exe) clbi                                        (buildDir lbi) verbosity                    -- output file-                ++ ["--output", buildDir lbi </> exeName exe]+                ++ ["--output", buildDir lbi </> display (exeName exe)]                    -- main source module                 ++ [modulePath exe]   runUhcProg uhcArgs@@ -223,7 +227,8 @@      -- search paths   ++ ["-i" ++ odir]   ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]-  ++ ["-i" ++ autogenModulesDir lbi clbi]+  ++ ["-i" ++ autogenComponentModulesDir lbi clbi]+  ++ ["-i" ++ autogenPackageModulesDir lbi]      -- cpp options   ++ ["--optP=" ++ opt | opt <- cppOptions bi]      -- output path@@ -266,7 +271,7 @@ registerPackage   :: Verbosity   -> Compiler-  -> ProgramConfiguration+  -> ProgramDb   -> PackageDBStack   -> InstalledPackageInfo   -> IO ()
cabal/Cabal/Distribution/Simple/UserHooks.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.UserHooks@@ -28,6 +31,9 @@         emptyUserHooks,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.PackageDescription import Distribution.Simple.Program import Distribution.Simple.Command@@ -161,7 +167,7 @@       readDesc  = return Nothing,       hookedPreProcessors = [],       hookedPrograms      = [],-      preConf   = rn,+      preConf   = rn',       confHook  = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),       postConf  = ru,       preBuild  = rn',@@ -182,7 +188,7 @@       preSDist  = rn,       sDistHook = ru,       postSDist = ru,-      preReg    = rn,+      preReg    = rn',       regHook   = ru,       postReg   = ru,       preUnreg  = rn,
cabal/Cabal/Distribution/Simple/Utils.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Utils@@ -21,8 +26,9 @@         -- * logging and errors         die,         dieWithLocation,+        dieMsg, dieMsgNoWrap,         topHandler, topHandlerWith,-        warn, notice, setupMessage, info, debug,+        warn, notice, noticeNoWrap, setupMessage, info, debug,         debugNoWrap, chattyTry,         printRawCommandAndArgs, printRawCommandAndArgsAndEnv, @@ -114,6 +120,8 @@          -- * Unicode         fromUTF8,+        fromUTF8BS,+        fromUTF8LBS,         toUTF8,         readUTF8File,         withUTF8FileContents,@@ -138,11 +146,20 @@         ordNub,         ordNubRight,         safeTail,+        unintersperse,         wrapText,         wrapLine,++        -- * FilePath stuff+        isAbsoluteOnAnyPlatform,+        isRelativeOnAnyPlatform,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Text+import Distribution.Utils.String import Distribution.Package import Distribution.ModuleName as ModuleName import Distribution.System@@ -150,6 +167,7 @@ import Distribution.Compat.CopyFile import Distribution.Compat.Internal.TempFile import Distribution.Compat.Exception+import Distribution.Compat.Stack import Distribution.Verbosity  #if __GLASGOW_HASKELL__ < 711@@ -166,18 +184,12 @@ import qualified Paths_Cabal (version) #endif -import Control.Monad-    ( when, unless, filterM ) import Control.Concurrent.MVar     ( newEmptyMVar, putMVar, takeMVar ) import Data.Bits     ( Bits((.|.), (.&.), shiftL, shiftR) )-import Data.Char as Char-    ( isDigit, toLower, chr, ord )-import Data.Foldable-    ( traverse_ ) import Data.List-    ( nub, unfoldr, intercalate, isInfixOf )+    ( isInfixOf ) import Data.Typeable     ( cast ) import Data.Ord@@ -186,6 +198,8 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.Set as Set +import qualified Data.ByteString as SBS+ import System.Directory     ( Permissions(executable), getDirectoryContents, getPermissions     , doesDirectoryExist, doesFileExist, removeFile, findExecutable@@ -225,11 +239,11 @@ -- We only get our own version number when we're building with ourselves cabalVersion :: Version #if defined(BOOTSTRAPPED_CABAL)-cabalVersion = Paths_Cabal.version+cabalVersion = mkVersion' Paths_Cabal.version #elif defined(CABAL_VERSION)-cabalVersion = Version [CABAL_VERSION] []+cabalVersion = mkVersion [CABAL_VERSION] #else-cabalVersion = Version [1,9999] []  --used when bootstrapping+cabalVersion = mkVersion [1,9999]  --used when bootstrapping #endif  -- ----------------------------------------------------------------------------@@ -243,9 +257,12 @@   where     setLocation Nothing  err = err     setLocation (Just n) err = ioeSetLocation err (show n)+    _ = callStack -- TODO: Attach CallStack to exception  die :: String -> IO a die msg = ioError (userError msg)+  where+    _ = callStack -- TODO: Attach CallStack to exception  topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a topHandlerWith cont prog =@@ -256,15 +273,15 @@       ]   where     -- Let async exceptions rise to the top for the default top-handler-    rethrowAsyncExceptions :: Exception.AsyncException -> IO a-    rethrowAsyncExceptions = throwIO+    rethrowAsyncExceptions :: Exception.AsyncException -> NoCallStackIO a+    rethrowAsyncExceptions a = throwIO a      -- ExitCode gets thrown asynchronously too, and we don't want to print it-    rethrowExitStatus :: ExitCode -> IO a+    rethrowExitStatus :: ExitCode -> NoCallStackIO a     rethrowExitStatus = throwIO      -- Print all other exceptions-    handle :: Exception.SomeException -> IO a+    handle :: Exception.SomeException -> NoCallStackIO a     handle se = do       hFlush stdout       pname <- getProgName@@ -279,7 +296,7 @@                                Nothing   -> ""                                Just path -> path ++ location ++ ": "               location     = case ioeGetLocation ioe of-                               l@(n:_) | Char.isDigit n -> ':' : l+                               l@(n:_) | isDigit n -> ':' : l                                _                        -> ""               detail       = ioeGetErrorString ioe           in pname ++ ": " ++ file ++ detail@@ -293,15 +310,47 @@ topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog +-- | Print out a call site/stack according to 'Verbosity'.+hPutCallStackPrefix :: Handle -> Verbosity -> IO ()+hPutCallStackPrefix h verbosity = withFrozenCallStack $ do+  when (isVerboseCallSite verbosity) $+    hPutStr h parentSrcLocPrefix+  when (isVerboseCallStack verbosity) $+    hPutStr h ("----\n" ++ prettyCallStack callStack ++ "\n")++-- | This can be used to help produce formatted messages as part of a fatal+-- error condition, prior to using 'die' or 'exitFailure'.+--+-- For fatal conditions we normally simply use 'die' which throws an+-- exception. Sometimes however 'die' is not sufficiently flexible to+-- produce the desired output.+--+-- Like 'die', these messages are always displayed on @stderr@, irrespective+-- of the 'Verbosity' level. The 'Verbosity' parameter is needed though to+-- decide how to format the output (e.g. line-wrapping).+--+dieMsg :: Verbosity -> String -> NoCallStackIO ()+dieMsg verbosity msg = do+    hFlush stdout+    hPutStr stderr (wrapTextVerbosity verbosity msg)++-- | As 'dieMsg' but with pre-formatted text.+--+dieMsgNoWrap :: String -> NoCallStackIO ()+dieMsgNoWrap msg = do+    hFlush stdout+    hPutStr stderr msg+ -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. -- warn :: Verbosity -> String -> IO ()-warn verbosity msg =+warn verbosity msg = withFrozenCallStack $ do   when (verbosity >= normal) $ do     hFlush stdout-    hPutStr stderr (wrapText ("Warning: " ++ msg))+    hPutCallStackPrefix stderr verbosity+    hPutStr stderr (wrapTextVerbosity verbosity ("Warning: " ++ msg))  -- | Useful status messages. --@@ -311,12 +360,19 @@ -- enough information to know that things are working but not floods of detail. -- notice :: Verbosity -> String -> IO ()-notice verbosity msg =-  when (verbosity >= normal) $-    putStr (wrapText msg)+notice verbosity msg = withFrozenCallStack $ do+  when (verbosity >= normal) $ do+    hPutCallStackPrefix stdout verbosity+    putStr (wrapTextVerbosity verbosity msg) +noticeNoWrap :: Verbosity -> String -> IO ()+noticeNoWrap verbosity msg = withFrozenCallStack $ do+  when (verbosity >= normal) $ do+    hPutCallStackPrefix stdout verbosity+    putStr msg+ setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()-setupMessage verbosity msg pkgid =+setupMessage verbosity msg pkgid = withFrozenCallStack $ do     notice verbosity (msg ++ ' ': display pkgid ++ "...")  -- | More detail on the operation of some action.@@ -324,25 +380,28 @@ -- We display these messages when the verbosity level is 'verbose' -- info :: Verbosity -> String -> IO ()-info verbosity msg =-  when (verbosity >= verbose) $-    putStr (wrapText msg)+info verbosity msg = withFrozenCallStack $+  when (verbosity >= verbose) $ do+    hPutCallStackPrefix stdout verbosity+    putStr (wrapTextVerbosity verbosity msg)  -- | Detailed internal debugging information -- -- We display these messages when the verbosity level is 'deafening' -- debug :: Verbosity -> String -> IO ()-debug verbosity msg =+debug verbosity msg = withFrozenCallStack $   when (verbosity >= deafening) $ do-    putStr (wrapText msg)+    hPutCallStackPrefix stdout verbosity+    putStr (wrapTextVerbosity verbosity msg)     hFlush stdout  -- | A variant of 'debug' that doesn't perform the automatic line -- wrapping. Produces better output in some cases. debugNoWrap :: Verbosity -> String -> IO ()-debugNoWrap verbosity msg =+debugNoWrap verbosity msg = withFrozenCallStack $   when (verbosity >= deafening) $ do+    hPutCallStackPrefix stdout verbosity     putStrLn msg     hFlush stdout @@ -357,7 +416,7 @@  -- | Run an IO computation, returning @e@ if it raises a "file -- does not exist" error.-handleDoesNotExist :: a -> IO a -> IO a+handleDoesNotExist :: a -> NoCallStackIO a -> NoCallStackIO a handleDoesNotExist e =     Exception.handleJust       (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)@@ -375,6 +434,12 @@               . words)          . lines +-- | Wraps text unless the @+nowrap@ verbosity flag is active+wrapTextVerbosity :: Verbosity -> String -> String+wrapTextVerbosity verb+  | isVerboseNoWrap verb = unlines . lines -- makes sure there's a trailing LF+  | otherwise            = wrapText+ -- | Wraps a list of words to a list of lines of words of a particular width. wrapLine :: Int -> [String] -> [[String]] wrapLine width = wrap 0 []@@ -399,7 +464,7 @@   unless (res == ExitSuccess) $ exitWith res  printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()-printRawCommandAndArgs verbosity path args =+printRawCommandAndArgs verbosity path args = withFrozenCallStack $     printRawCommandAndArgsAndEnv verbosity path args Nothing  printRawCommandAndArgsAndEnv :: Verbosity@@ -410,14 +475,17 @@ printRawCommandAndArgsAndEnv verbosity path args menv  | verbosity >= deafening = do        traverse_ (putStrLn . ("Environment: " ++) . show) menv+       hPutCallStackPrefix stdout verbosity        print (path, args)- | verbosity >= verbose   = putStrLn $ showCommandForUser path args+ | verbosity >= verbose   = do+    hPutCallStackPrefix stdout verbosity+    putStrLn $ showCommandForUser path args  | otherwise              = return ()   -- Exit with the same exit code if the subcommand fails rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()-rawSystemExit verbosity path args = do+rawSystemExit verbosity path args = withFrozenCallStack $ do   printRawCommandAndArgs verbosity path args   hFlush stdout   exitcode <- rawSystem path args@@ -426,7 +494,7 @@     exitWith exitcode  rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode-rawSystemExitCode verbosity path args = do+rawSystemExitCode verbosity path args = withFrozenCallStack $ do   printRawCommandAndArgs verbosity path args   hFlush stdout   exitcode <- rawSystem path args@@ -439,7 +507,7 @@                      -> [String]                      -> [(String, String)]                      -> IO ()-rawSystemExitWithEnv verbosity path args env = do+rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do     printRawCommandAndArgsAndEnv verbosity path args (Just env)     hFlush stdout     (_,_,_,ph) <- createProcess $@@ -467,7 +535,7 @@                    -> Maybe Handle  -- ^ stdout                    -> Maybe Handle  -- ^ stderr                    -> IO ExitCode-rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do+rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do     (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv                                        (mbToStd inp) (mbToStd out) (mbToStd err)     exitcode <- waitForProcess ph@@ -479,7 +547,7 @@     mbToStd = maybe Process.Inherit Process.UseHandle  createProcessWithEnv ::-  Verbosity+     Verbosity   -> FilePath   -> [String]   -> Maybe FilePath           -- ^ New working dir or inherit@@ -490,7 +558,7 @@   -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)   -- ^ Any handles created for stdin, stdout, or stderr   -- with 'CreateProcess', and a handle to the process.-createProcessWithEnv verbosity path args mcwd menv inp out err = do+createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do     printRawCommandAndArgsAndEnv verbosity path args menv     hFlush stdout     (inp', out', err', ph) <- createProcess $@@ -515,7 +583,7 @@ -- The output is assumed to be text in the locale encoding. -- rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String-rawSystemStdout verbosity path args = do+rawSystemStdout verbosity path args = withFrozenCallStack $ do   (output, errors, exitCode) <- rawSystemStdInOut verbosity path args                                                   Nothing Nothing                                                   Nothing False@@ -535,7 +603,7 @@                   -> Maybe (String, Bool)     -- ^ input text and binary mode                   -> Bool                     -- ^ output in binary mode                   -> IO (String, String, ExitCode) -- ^ output, errors, exit-rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do+rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenCallStack $ do   printRawCommandAndArgs verbosity path args    Exception.bracket@@ -555,9 +623,9 @@       out <- hGetContents outh        mv <- newEmptyMVar-      let force str = (evaluate (length str) >> return ())-            `Exception.finally` putMVar mv ()-          --TODO: handle exceptions like text decoding.+      let force str = do+            mberr <- Exception.try (evaluate (length str) >> return ())+            putMVar mv (mberr :: Either IOError ())       _ <- forkIO $ force out       _ <- forkIO $ force err @@ -573,8 +641,8 @@           -- or if it closes stdin (eg if it exits)        -- wait for both to finish, in either order-      takeMVar mv-      takeMVar mv+      mberr1 <- takeMVar mv+      mberr2 <- takeMVar mv        -- wait for the program to terminate       exitcode <- waitForProcess pid@@ -587,14 +655,24 @@                             Just ("",  _) -> ""                             Just (inp, _) -> "\nstdin input:\n" ++ inp +      -- Check if we we hit an exception while consuming the output+      -- (e.g. a text decoding error)+      reportOutputIOError mberr1+      reportOutputIOError mberr2+       return (out, err, exitcode)+  where+    reportOutputIOError :: Either IOError () -> NoCallStackIO ()+    reportOutputIOError =+      either (\e -> throwIO (ioeSetFileName e ("output of " ++ path)))+             return   {-# DEPRECATED findProgramLocation     "No longer used within Cabal, try findProgramOnSearchPath" #-} -- | Look for a program on the path. findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)-findProgramLocation verbosity prog = do+findProgramLocation verbosity prog = withFrozenCallStack $ do   debug verbosity $ "searching for " ++ prog ++ " in path."   res <- findExecutable prog   case res of@@ -613,7 +691,7 @@                    -> Verbosity                    -> FilePath           -- ^ location                    -> IO (Maybe Version)-findProgramVersion versionArg selectVersion verbosity path = do+findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do   str <- rawSystemStdout verbosity path [versionArg]          `catchIO`   (\_ -> return "")          `catchExit` (\_ -> return "")@@ -639,7 +717,7 @@ xargs maxSize rawSystemFun fixedArgs bigArgs =   let fixedArgSize = sum (map length fixedArgs) + length fixedArgs       chunkSize = maxSize - fixedArgSize-   in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)+   in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)    where chunks len = unfoldr $ \s ->           if null s then Nothing@@ -676,7 +754,7 @@ findFileWithExtension :: [String]                       -> [FilePath]                       -> FilePath-                      -> IO (Maybe FilePath)+                      -> NoCallStackIO (Maybe FilePath) findFileWithExtension extensions searchPath baseName =   findFirstFile id     [ path </> baseName <.> ext@@ -686,7 +764,7 @@ findAllFilesWithExtension :: [String]                           -> [FilePath]                           -> FilePath-                          -> IO [FilePath]+                          -> NoCallStackIO [FilePath] findAllFilesWithExtension extensions searchPath basename =   findAllFiles id     [ path </> basename <.> ext@@ -699,14 +777,14 @@ findFileWithExtension' :: [String]                        -> [FilePath]                        -> FilePath-                       -> IO (Maybe (FilePath, FilePath))+                       -> NoCallStackIO (Maybe (FilePath, FilePath)) findFileWithExtension' extensions searchPath baseName =   findFirstFile (uncurry (</>))     [ (path, baseName <.> ext)     | path <- nub searchPath     , ext <- nub extensions ] -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)+findFirstFile :: (a -> FilePath) -> [a] -> NoCallStackIO (Maybe a) findFirstFile file = findFirst   where findFirst []     = return Nothing         findFirst (x:xs) = do exists <- doesFileExist (file x)@@ -714,7 +792,7 @@                                 then return (Just x)                                 else findFirst xs -findAllFiles :: (a -> FilePath) -> [a] -> IO [a]+findAllFiles :: (a -> FilePath) -> [a] -> NoCallStackIO [a] findAllFiles file = filterM (doesFileExist . file)  -- | Finds the files corresponding to a list of Haskell module names.@@ -726,7 +804,7 @@                 -> [ModuleName] -- ^ modules                 -> IO [(FilePath, FilePath)] findModuleFiles searchPath extensions moduleNames =-  mapM (findModuleFile searchPath extensions) moduleNames+  traverse (findModuleFile searchPath extensions) moduleNames  -- | Find the file corresponding to a Haskell module name. --@@ -782,7 +860,7 @@ -- Environment variables  -- | Is this directory in the system search path?-isInSearchPath :: FilePath -> IO Bool+isInSearchPath :: FilePath -> NoCallStackIO Bool isInSearchPath path = fmap (elem path) getSearchPath  addLibraryPath :: OS@@ -854,7 +932,7 @@ -- The expected use case is when the second file is generated using the first. -- In this use case, if the result is True then the second file is out of date. ---moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile :: FilePath -> FilePath -> NoCallStackIO Bool moreRecentFile a b = do   exists <- doesFileExist b   if not exists@@ -864,7 +942,7 @@             return (ta > tb)  -- | Like 'moreRecentFile', but also checks that the first file exists.-existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool+existsAndIsMoreRecentThan :: FilePath -> FilePath -> NoCallStackIO Bool existsAndIsMoreRecentThan a b = do   exists <- doesFileExist a   if not exists@@ -881,8 +959,8 @@                                 -> FilePath                                 -> IO () createDirectoryIfMissingVerbose verbosity create_parents path0-  | create_parents = createDirs (parents path0)-  | otherwise      = createDirs (take 1 (parents path0))+  | create_parents = withFrozenCallStack $ createDirs (parents path0)+  | otherwise      = withFrozenCallStack $ createDirs (take 1 (parents path0))   where     parents = reverse . scanl1 (</>) . splitDirectories . normalise @@ -915,7 +993,7 @@           | otherwise              -> throwIO e  createDirectoryVerbose :: Verbosity -> FilePath -> IO ()-createDirectoryVerbose verbosity dir = do+createDirectoryVerbose verbosity dir = withFrozenCallStack $ do   info verbosity $ "creating " ++ dir   createDirectory dir   setDirOrdinary dir@@ -926,7 +1004,7 @@ -- At higher verbosity levels it logs an info message. -- copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()-copyFileVerbose verbosity src dest = do+copyFileVerbose verbosity src dest = withFrozenCallStack $ do   info verbosity ("copy " ++ src ++ " to " ++ dest)   copyFile src dest @@ -935,7 +1013,7 @@ -- while on Windows it uses the default permissions for the target directory. -- installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()-installOrdinaryFile verbosity src dest = do+installOrdinaryFile verbosity src dest = withFrozenCallStack $ do   info verbosity ("Installing " ++ src ++ " to " ++ dest)   copyOrdinaryFile src dest @@ -944,13 +1022,13 @@ -- while on Windows it uses the default permissions for the target directory. -- installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()-installExecutableFile verbosity src dest = do+installExecutableFile verbosity src dest = withFrozenCallStack $ do   info verbosity ("Installing executable " ++ src ++ " to " ++ dest)   copyExecutableFile src dest  -- | Install a file that may or not be executable, preserving permissions. installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()-installMaybeExecutableFile verbosity src dest = do+installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do   perms <- getPermissions src   if (executable perms) --only checks user x bit     then installExecutableFile verbosity src dest@@ -959,7 +1037,7 @@ -- | Given a relative path to a file, copy it to the given directory, preserving -- the relative path and creating the parent directories if needed. copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()-copyFileTo verbosity dir file = do+copyFileTo verbosity dir file = withFrozenCallStack $ do   let targetFile = dir </> file   createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)   installOrdinaryFile verbosity file targetFile@@ -968,11 +1046,11 @@ -- 'installExecutableFiles' and 'installMaybeExecutableFiles'. copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())               -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-copyFilesWith doCopy verbosity targetDir srcFiles = do+copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do    -- Create parent directories for everything   let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles-  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs+  traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs    -- Copy all the files   sequence_ [ let src  = srcBase   </> srcFile@@ -1002,38 +1080,38 @@ -- anything goes wrong. -- copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-copyFiles = copyFilesWith copyFileVerbose+copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)  -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. -- installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-installOrdinaryFiles = copyFilesWith installOrdinaryFile+installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)  -- | This is like 'copyFiles' but uses 'installExecutableFile'. -- installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]                           -> IO ()-installExecutableFiles = copyFilesWith installExecutableFile+installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs)  -- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. -- installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]                                -> IO ()-installMaybeExecutableFiles = copyFilesWith installMaybeExecutableFile+installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs)  -- | This installs all the files in a directory to a target location, -- preserving the directory layout. All the files are assumed to be ordinary -- rather than executable files. -- installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()-installDirectoryContents verbosity srcDir destDir = do+installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do   info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")   srcFiles <- getDirectoryContentsRecursive srcDir   installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]  -- | Recursively copy the contents of one directory to another path. copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()-copyDirectoryRecursive verbosity srcDir destDir = do+copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do   info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")   srcFiles <- getDirectoryContentsRecursive srcDir   copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f)@@ -1043,7 +1121,7 @@ -- File permissions  -- | Like 'doesFileExist', but also checks that the file is executable.-doesExecutableExist :: FilePath -> IO Bool+doesExecutableExist :: FilePath -> NoCallStackIO Bool doesExecutableExist f = do   exists <- doesFileExist f   if exists@@ -1058,14 +1136,14 @@       "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} smartCopySources :: Verbosity -> [FilePath] -> FilePath                  -> [ModuleName] -> [String] -> IO ()-smartCopySources verbosity searchPath targetDir moduleNames extensions =+smartCopySources verbosity searchPath targetDir moduleNames extensions = withFrozenCallStack $       findModuleFiles searchPath extensions moduleNames   >>= copyFiles verbosity targetDir  {-# DEPRECATED copyDirectoryRecursiveVerbose       "You probably want installDirectoryContents instead" #-} copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()-copyDirectoryRecursiveVerbose verbosity srcDir destDir = do+copyDirectoryRecursiveVerbose verbosity srcDir destDir = withFrozenCallStack $ do   info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")   srcFiles <- getDirectoryContentsRecursive srcDir   copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]@@ -1101,7 +1179,7 @@     (\(name, handle) -> do hClose handle                            unless (optKeepTempFiles opts) $                              handleDoesNotExist () . removeFile $ name)-    (uncurry action)+    (withLexicalCallStack (uncurry action))  -- | Create and use a temporary directory. --@@ -1113,21 +1191,21 @@ -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. ---withTempDirectory :: Verbosity-                     -> FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectory verbosity targetDir template =+withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectory verbosity targetDir template f = withFrozenCallStack $   withTempDirectoryEx verbosity defaultTempFileOptions targetDir template+    (withLexicalCallStack f)  -- | A version of 'withTempDirectory' that additionally takes a -- 'TempFileOptions' argument.-withTempDirectoryEx :: Verbosity-                       -> TempFileOptions+withTempDirectoryEx :: Verbosity -> TempFileOptions                        -> FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectoryEx _verbosity opts targetDir template =+withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $   Exception.bracket     (createTempDirectory targetDir template)     (unless (optKeepTempFiles opts)      . handleDoesNotExist () . removeDirectoryRecursive)+    (withLexicalCallStack f)  ----------------------------------- -- Safely reading and writing files@@ -1137,7 +1215,7 @@ -- The file is read lazily but if it is not fully consumed by the action then -- the remaining input is truncated and the file is closed. ---withFileContents :: FilePath -> (String -> IO a) -> IO a+withFileContents :: FilePath -> (String -> NoCallStackIO a) -> NoCallStackIO a withFileContents name action =   Exception.bracket (openFile name ReadMode) hClose                     (\hnd -> hGetContents hnd >>= action)@@ -1150,7 +1228,7 @@ -- On windows it is not possible to delete a file that is open by a process. -- This case will give an IO exception but the atomic property is not affected. ---writeFileAtomic :: FilePath -> BS.ByteString -> IO ()+writeFileAtomic :: FilePath -> BS.ByteString -> NoCallStackIO () writeFileAtomic targetPath content = do   let (targetDir, targetFile) = splitFileName targetPath   Exception.bracketOnError@@ -1177,6 +1255,7 @@     mightNotExist e | isDoesNotExistError e = writeFileAtomic path                                               (BS.Char8.pack newContent)                     | otherwise             = ioError e+    _ = callStack -- TODO: attach call stack to exception  -- | The path name that represents the current directory. -- In Unix, it's @\".\"@, but this is system-specific.@@ -1223,7 +1302,7 @@ -- |Find a package description file in the given directory.  Looks for -- @.cabal@ files. findPackageDesc :: FilePath                    -- ^Where to look-                -> IO (Either String FilePath) -- ^<pkgname>.cabal+                -> NoCallStackIO (Either String FilePath) -- ^<pkgname>.cabal findPackageDesc dir  = do files <- getDirectoryContents dir       -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal@@ -1324,6 +1403,12 @@      replacementChar = '\xfffd' +fromUTF8BS :: SBS.ByteString -> String+fromUTF8BS = decodeStringUtf8 . SBS.unpack++fromUTF8LBS :: BS.ByteString -> String+fromUTF8LBS = decodeStringUtf8 . BS.unpack+ toUTF8 :: String -> String toUTF8 []        = [] toUTF8 (c:cs)@@ -1349,7 +1434,7 @@ startsWithBOM _            = False  -- | Check whether a file has Unicode byte order mark (BOM).-fileHasBOM :: FilePath -> IO Bool+fileHasBOM :: FilePath -> NoCallStackIO Bool fileHasBOM f = fmap (startsWithBOM . fromUTF8)              . hGetContents =<< openBinaryFile f ReadMode @@ -1363,7 +1448,7 @@ -- -- Reads lazily using ordinary 'readFile'. ---readUTF8File :: FilePath -> IO String+readUTF8File :: FilePath -> NoCallStackIO String readUTF8File f = fmap (ignoreBOM . fromUTF8)                . hGetContents =<< openBinaryFile f ReadMode @@ -1382,8 +1467,8 @@ -- -- Uses 'writeFileAtomic', so provides the same guarantees. ---writeUTF8File :: FilePath -> String -> IO ()-writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8+writeUTF8File :: FilePath -> String -> NoCallStackIO ()+writeUTF8File path = writeFileAtomic path . BS.pack . encodeStringUtf8  -- | Fix different systems silly line ending conventions normaliseLineEndings :: String -> String@@ -1483,4 +1568,48 @@ equating p x y = p x == p y  lowercase :: String -> String-lowercase = map Char.toLower+lowercase = map toLower++unintersperse :: Char -> String -> [String]+unintersperse mark = unfoldr unintersperse1 where+  unintersperse1 str+    | null str = Nothing+    | otherwise =+        let (this, rest) = break (== mark) str in+        Just (this, safeTail rest)++-- ------------------------------------------------------------+-- * FilePath stuff+-- ------------------------------------------------------------++-- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like+-- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have+-- platform independent heuristics.+-- The System.FilePath exists in two versions, Windows and Posix. The two+-- versions don't agree on what is a relative path and we don't know if we're+-- given Windows or Posix paths.+-- This results in false positives when running on Posix and inspecting+-- Windows paths, like the hackage server does.+-- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False+-- System.FilePath.Windows.isAbsolute \"/hello\" == False+-- This means that we would treat paths that start with \"/\" to be absolute.+-- On Posix they are indeed absolute, while on Windows they are not.+--+-- The portable versions should be used when we might deal with paths that+-- are from another OS than the host OS. For example, the Hackage Server+-- deals with both Windows and Posix paths while performing the+-- PackageDescription checks. In contrast, when we run 'cabal configure' we+-- do expect the paths to be correct for our OS and we should not have to use+-- the platform independent heuristics.+isAbsoluteOnAnyPlatform :: FilePath -> Bool+-- C:\\directory+isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive+-- UNC+isAbsoluteOnAnyPlatform ('\\':'\\':_) = True+-- Posix root+isAbsoluteOnAnyPlatform ('/':_) = True+isAbsoluteOnAnyPlatform _ = False++-- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@+isRelativeOnAnyPlatform :: FilePath -> Bool+isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform
cabal/Cabal/Distribution/System.hs view
@@ -32,23 +32,23 @@    -- * Internal   knownOSs,-  knownArches+  knownArches,++  -- * Classification+  ClassificationStrictness (..),+  classifyOS,+  classifyArch,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import qualified System.Info (os, arch)-import qualified Data.Char as Char (toLower, isAlphaNum, isAlpha) -import Distribution.Compat.Binary import Distribution.Text import qualified Distribution.Compat.ReadP as Parse -import Control.Monad (liftM2)-import Data.Data (Data)-import Data.Typeable (Typeable)-import Data.Maybe (fromMaybe, listToMaybe)-import GHC.Generics (Generic) import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>))  -- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. --@@ -73,6 +73,18 @@ -- * Operating System -- ------------------------------------------------------------ +-- | These are the known OS names: Linux, Windows, OSX+--  ,FreeBSD, OpenBSD, NetBSD, DragonFly+--  ,Solaris, AIX, HPUX, IRIX+--  ,HaLVM ,Hurd ,IOS, Android,Ghcjs+--+-- The following aliases can also be used:,+--    * Windows aliases: mingw32, win32, cygwin32+--    * OSX alias: darwin+--    * Hurd alias: gnu+--    * FreeBSD alias: kfreebsdgnu+--    * Solaris alias: solaris2+-- data OS = Linux | Windows | OSX        -- tier 1 desktop OSs         | FreeBSD | OpenBSD | NetBSD   -- other free Unix OSs         | DragonFly@@ -127,6 +139,17 @@ -- * Machine Architecture -- ------------------------------------------------------------ +-- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc+-- ,Arm, Mips, SH, IA64, S39, Alpha, Hppa, Rs6000, M68k, Vax+-- and JavaScript.+--+-- The following aliases can also be used:+--    * PPC alias: powerpc+--    * PPC64 alias : powerpc64+--    * Sparc aliases: sparc64, sun4+--    * Mips aliases: mipsel, mipseb+--    * Arm aliases: armeb, armel+-- data Arch = I386  | X86_64 | PPC | PPC64 | Sparc           | Arm   | Mips   | SH           | IA64  | S390@@ -183,7 +206,7 @@ instance Binary Platform  instance Text Platform where-  disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os+  disp (Platform arch os) = disp arch <<>> Disp.char '-' <<>> disp os   -- TODO: there are ambigious platforms like: `arch-word-os`   -- which could be parsed as   --   * Platform "arch-word" "os"@@ -209,22 +232,22 @@ -- Utils:  ident :: Parse.ReadP r String-ident = liftM2 (:) first rest-  where first = Parse.satisfy Char.isAlpha-        rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_' || c == '-')+ident = liftM2 (:) firstChar rest+  where firstChar = Parse.satisfy isAlpha+        rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-')  dashlessIdent :: Parse.ReadP r String-dashlessIdent = liftM2 (:) first rest-  where first = Parse.satisfy Char.isAlpha-        rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_')+dashlessIdent = liftM2 (:) firstChar rest+  where firstChar = Parse.satisfy isAlpha+        rest = Parse.munch (\c -> isAlphaNum c || c == '_')  lowercase :: String -> String-lowercase = map Char.toLower+lowercase = map toLower  platformFromTriple :: String -> Maybe Platform platformFromTriple triple =   fmap fst (listToMaybe $ Parse.readP_to_S parseTriple triple)-  where parseWord = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_')+  where parseWord = Parse.munch1 (\c -> isAlphaNum c || c == '_')         parseTriple = do           arch <- fmap (classifyArch Permissive) parseWord           _ <- Parse.char '-'
cabal/Cabal/Distribution/TestSuite.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.TestSuite@@ -20,6 +23,9 @@     , Result(..)     , testGroup     ) where++import Prelude ()+import Distribution.Compat.Prelude  data TestInstance = TestInstance     { run       :: IO Progress      -- ^ Perform the test.
cabal/Cabal/Distribution/Text.hs view
@@ -16,13 +16,16 @@   defaultStyle,   display,   simpleParse,+  stdParse,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint          as Disp  import Data.Version (Version(Version))-import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace)  class Text a where   disp  :: a -> Disp.Doc@@ -40,10 +43,27 @@  simpleParse :: Text a => String -> Maybe a simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str-                       , all Char.isSpace s ] of+                       , all isSpace s ] of   []    -> Nothing   (p:_) -> Just p +stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res+stdParse f = do+  cs   <- Parse.sepBy1 component (Parse.char '-')+  _    <- Parse.char '-'+  ver  <- parse+  let name = intercalate "-" cs+  return $! f ver (lowercase name)+  where+    component = do+      cs <- Parse.munch1 isAlphaNum+      if all isDigit cs then Parse.pfail else return cs+      -- each component must contain an alphabetic character, to avoid+      -- ambiguity in identifiers like foo-1 (the 1 is the version number).++lowercase :: String -> String+lowercase = map toLower+ -- ----------------------------------------------------------------------------- -- Instances for types from the base package @@ -60,8 +80,9 @@  -- | Parser for non-negative integers. parseNat :: Parse.ReadP r Int-parseNat = read `fmap` Parse.munch1 Char.isDigit+parseNat = read `fmap` Parse.munch1 isDigit -- TODO: eradicateNoParse + instance Text Version where   disp (Version branch _tags)     -- Death to version tags!!     = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))@@ -69,5 +90,5 @@   parse = do       branch <- Parse.sepBy1 parseNat (Parse.char '.')                 -- allow but ignore tags:-      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum)+      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)       return (Version branch [])
+ cabal/Cabal/Distribution/Types/Benchmark.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}++module Distribution.Types.Benchmark (+    Benchmark(..),+    emptyBenchmark,+    benchmarkType,+    benchmarkModules,+    benchmarkModulesAutogen+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.BuildInfo+import Distribution.Types.BenchmarkType+import Distribution.Types.BenchmarkInterface++import Distribution.ModuleName+import Distribution.Package++-- | A \"benchmark\" stanza in a cabal file.+--+data Benchmark = Benchmark {+        benchmarkName      :: UnqualComponentName,+        benchmarkInterface :: BenchmarkInterface,+        benchmarkBuildInfo :: BuildInfo+    }+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary Benchmark++instance Monoid Benchmark where+    mempty = Benchmark {+        benchmarkName      = mempty,+        benchmarkInterface = mempty,+        benchmarkBuildInfo = mempty+    }+    mappend = (<>)++instance Semigroup Benchmark where+    a <> b = Benchmark {+        benchmarkName      = combine' benchmarkName,+        benchmarkInterface = combine  benchmarkInterface,+        benchmarkBuildInfo = combine  benchmarkBuildInfo+    }+        where combine  field = field a `mappend` field b+              combine' field = case ( unUnqualComponentName $ field a+                                    , unUnqualComponentName $ field b) of+                        ("", _) -> field b+                        (_, "") -> field a+                        (x, y) -> error $ "Ambiguous values for test field: '"+                            ++ x ++ "' and '" ++ y ++ "'"++emptyBenchmark :: Benchmark+emptyBenchmark = mempty++benchmarkType :: Benchmark -> BenchmarkType+benchmarkType benchmark = case benchmarkInterface benchmark of+  BenchmarkExeV10 ver _              -> BenchmarkTypeExe ver+  BenchmarkUnsupported benchmarktype -> benchmarktype++-- | Get all the module names from a benchmark.+benchmarkModules :: Benchmark -> [ModuleName]+benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)++-- | Get all the auto generated module names from a benchmark.+-- This are a subset of 'benchmarkModules'.+benchmarkModulesAutogen :: Benchmark -> [ModuleName]+benchmarkModulesAutogen benchmark = autogenModules (benchmarkBuildInfo benchmark)
+ cabal/Cabal/Distribution/Types/BenchmarkInterface.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.BenchmarkInterface (+    BenchmarkInterface(..),+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.BenchmarkType+import Distribution.Version++-- | The benchmark interfaces that are currently defined. Each+-- benchmark must specify which interface it supports.+--+-- More interfaces may be defined in future, either new revisions or+-- totally new interfaces.+--+data BenchmarkInterface =++     -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark+     -- takes the form of an executable. It returns a zero exit code+     -- for success, non-zero for failure. The stdout and stderr+     -- channels may be logged. It takes no command line parameters+     -- and nothing on stdin.+     --+     BenchmarkExeV10 Version FilePath++     -- | A benchmark that does not conform to one of the above+     -- interfaces for the given reason (e.g. unknown benchmark type).+     --+   | BenchmarkUnsupported BenchmarkType+   deriving (Eq, Generic, Read, Show, Typeable, Data)++instance Binary BenchmarkInterface++instance Monoid BenchmarkInterface where+    mempty  =  BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion)+    mappend = (<>)++instance Semigroup BenchmarkInterface where+    a <> (BenchmarkUnsupported _) = a+    _ <> b                        = b
+ cabal/Cabal/Distribution/Types/BenchmarkType.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.BenchmarkType (+    BenchmarkType(..),+    knownBenchmarkTypes,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Version+import Distribution.Text++import Text.PrettyPrint as Disp++-- | The \"benchmark-type\" field in the benchmark stanza.+--+data BenchmarkType = BenchmarkTypeExe Version+                     -- ^ \"type: exitcode-stdio-x.y\"+                   | BenchmarkTypeUnknown String Version+                     -- ^ Some unknown benchmark type e.g. \"type: foo\"+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary BenchmarkType++knownBenchmarkTypes :: [BenchmarkType]+knownBenchmarkTypes = [ BenchmarkTypeExe (mkVersion [1,0]) ]++instance Text BenchmarkType where+  disp (BenchmarkTypeExe ver)          = text "exitcode-stdio-" <<>> disp ver+  disp (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> disp ver++  parse = stdParse $ \ver name -> case name of+    "exitcode-stdio" -> BenchmarkTypeExe ver+    _                -> BenchmarkTypeUnknown name ver++
+ cabal/Cabal/Distribution/Types/BuildInfo.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}++module Distribution.Types.BuildInfo (+    BuildInfo(..),++    emptyBuildInfo,+    allLanguages,+    allExtensions,+    usedExtensions,++    hcOptions,+    hcProfOptions,+    hcSharedOptions,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.Mixin++import Distribution.Package+import Distribution.ModuleName+import Distribution.Compiler+import Language.Haskell.Extension++-- Consider refactoring into executable and library versions.+data BuildInfo = BuildInfo {+        buildable         :: Bool,      -- ^ component is buildable here+        buildTools        :: [LegacyExeDependency], -- ^ tools needed to build this bit+        cppOptions        :: [String],  -- ^ options for pre-processing Haskell code+        ccOptions         :: [String],  -- ^ options for C compiler+        ldOptions         :: [String],  -- ^ options for linker+        pkgconfigDepends  :: [PkgconfigDependency], -- ^ pkg-config packages that are used+        frameworks        :: [String], -- ^support frameworks for Mac OS X+        extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks.+        cSources          :: [FilePath],+        jsSources         :: [FilePath],+        hsSourceDirs      :: [FilePath], -- ^ where to look for the Haskell module hierarchy+        otherModules      :: [ModuleName], -- ^ non-exposed or non-main modules+        autogenModules    :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs++        defaultLanguage   :: Maybe Language,-- ^ language used when not explicitly specified+        otherLanguages    :: [Language],    -- ^ other languages used within the package+        defaultExtensions :: [Extension],   -- ^ language extensions used by all modules+        otherExtensions   :: [Extension],   -- ^ other language extensions used within the package+        oldExtensions     :: [Extension],   -- ^ the old extensions field, treated same as 'defaultExtensions'++        extraLibs         :: [String], -- ^ what libraries to link with when compiling a program that uses your package+        extraGHCiLibs     :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi.+        extraLibDirs      :: [String],+        includeDirs       :: [FilePath], -- ^directories to find .h files+        includes          :: [FilePath], -- ^ The .h files to be found in includeDirs+        installIncludes   :: [FilePath], -- ^ .h files to install with the package+        options           :: [(CompilerFlavor,[String])],+        profOptions       :: [(CompilerFlavor,[String])],+        sharedOptions     :: [(CompilerFlavor,[String])],+        customFieldsBI    :: [(String,String)], -- ^Custom fields starting+                                                -- with x-, stored in a+                                                -- simple assoc-list.+        targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target+        mixins :: [Mixin]+    }+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary BuildInfo++instance Monoid BuildInfo where+  mempty = BuildInfo {+    buildable           = True,+    buildTools          = [],+    cppOptions          = [],+    ccOptions           = [],+    ldOptions           = [],+    pkgconfigDepends    = [],+    frameworks          = [],+    extraFrameworkDirs  = [],+    cSources            = [],+    jsSources           = [],+    hsSourceDirs        = [],+    otherModules        = [],+    autogenModules      = [],+    defaultLanguage     = Nothing,+    otherLanguages      = [],+    defaultExtensions   = [],+    otherExtensions     = [],+    oldExtensions       = [],+    extraLibs           = [],+    extraGHCiLibs       = [],+    extraLibDirs        = [],+    includeDirs         = [],+    includes            = [],+    installIncludes     = [],+    options             = [],+    profOptions         = [],+    sharedOptions       = [],+    customFieldsBI      = [],+    targetBuildDepends  = [],+    mixins    = []+  }+  mappend = (<>)++instance Semigroup BuildInfo where+  a <> b = BuildInfo {+    buildable           = buildable a && buildable b,+    buildTools          = combine    buildTools,+    cppOptions          = combine    cppOptions,+    ccOptions           = combine    ccOptions,+    ldOptions           = combine    ldOptions,+    pkgconfigDepends    = combine    pkgconfigDepends,+    frameworks          = combineNub frameworks,+    extraFrameworkDirs  = combineNub extraFrameworkDirs,+    cSources            = combineNub cSources,+    jsSources           = combineNub jsSources,+    hsSourceDirs        = combineNub hsSourceDirs,+    otherModules        = combineNub otherModules,+    autogenModules      = combineNub autogenModules,+    defaultLanguage     = combineMby defaultLanguage,+    otherLanguages      = combineNub otherLanguages,+    defaultExtensions   = combineNub defaultExtensions,+    otherExtensions     = combineNub otherExtensions,+    oldExtensions       = combineNub oldExtensions,+    extraLibs           = combine    extraLibs,+    extraGHCiLibs       = combine    extraGHCiLibs,+    extraLibDirs        = combineNub extraLibDirs,+    includeDirs         = combineNub includeDirs,+    includes            = combineNub includes,+    installIncludes     = combineNub installIncludes,+    options             = combine    options,+    profOptions         = combine    profOptions,+    sharedOptions       = combine    sharedOptions,+    customFieldsBI      = combine    customFieldsBI,+    targetBuildDepends  = combineNub targetBuildDepends,+    mixins    = combine mixins+  }+    where+      combine    field = field a `mappend` field b+      combineNub field = nub (combine field)+      combineMby field = field b `mplus` field a++emptyBuildInfo :: BuildInfo+emptyBuildInfo = mempty++-- | The 'Language's used by this component+--+allLanguages :: BuildInfo -> [Language]+allLanguages bi = maybeToList (defaultLanguage bi)+               ++ otherLanguages bi++-- | The 'Extension's that are used somewhere by this component+--+allExtensions :: BuildInfo -> [Extension]+allExtensions bi = usedExtensions bi+                ++ otherExtensions bi++-- | The 'Extensions' that are used by all modules in this component+--+usedExtensions :: BuildInfo -> [Extension]+usedExtensions bi = oldExtensions bi+                 ++ defaultExtensions bi++-- |Select options for a particular Haskell compiler.+hcOptions :: CompilerFlavor -> BuildInfo -> [String]+hcOptions = lookupHcOptions options++hcProfOptions :: CompilerFlavor -> BuildInfo -> [String]+hcProfOptions = lookupHcOptions profOptions++hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String]+hcSharedOptions = lookupHcOptions sharedOptions++lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])])+                -> CompilerFlavor -> BuildInfo -> [String]+lookupHcOptions f hc bi = [ opt | (hc',opts) <- f bi+                          , hc' == hc+                          , opt <- opts ]+
+ cabal/Cabal/Distribution/Types/BuildType.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.BuildType (+    BuildType(..),+    knownBuildTypes,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Text+import qualified Distribution.Compat.ReadP as Parse++import Text.PrettyPrint as Disp++-- | The type of build system used by this package.+data BuildType+  = Simple      -- ^ calls @Distribution.Simple.defaultMain@+  | Configure   -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,+                -- which invokes @configure@ to generate additional build+                -- information used by later phases.+  | Make        -- ^ calls @Distribution.Make.defaultMain@+  | Custom      -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)+  | UnknownBuildType String+                -- ^ a package that uses an unknown build type cannot actually+                --   be built. Doing it this way rather than just giving a+                --   parse error means we get better error messages and allows+                --   you to inspect the rest of the package description.+                deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary BuildType++knownBuildTypes :: [BuildType]+knownBuildTypes = [Simple, Configure, Make, Custom]++instance Text BuildType where+  disp (UnknownBuildType other) = Disp.text other+  disp other                    = Disp.text (show other)++  parse = do+    name <- Parse.munch1 isAlphaNum+    return $ case name of+      "Simple"    -> Simple+      "Configure" -> Configure+      "Custom"    -> Custom+      "Make"      -> Make+      _           -> UnknownBuildType name
+ cabal/Cabal/Distribution/Types/Component.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.Component (+    Component(..),+    foldComponent,+    componentBuildInfo,+    componentBuildable,+    componentName,+    partitionComponents,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.Library+import Distribution.Types.ForeignLib+import Distribution.Types.Executable+import Distribution.Types.TestSuite+import Distribution.Types.Benchmark++import Distribution.Types.ComponentName+import Distribution.Types.BuildInfo++data Component = CLib   Library+               | CFLib  ForeignLib+               | CExe   Executable+               | CTest  TestSuite+               | CBench Benchmark+               deriving (Show, Eq, Read)++instance Semigroup Component where+    CLib   l <> CLib   l' = CLib   (l <> l')+    CFLib  l <> CFLib  l' = CFLib  (l <> l')+    CExe   e <> CExe   e' = CExe   (e <> e')+    CTest  t <> CTest  t' = CTest  (t <> t')+    CBench b <> CBench b' = CBench (b <> b')+    _        <> _         = error "Cannot merge Component"++foldComponent :: (Library -> a)+              -> (ForeignLib -> a)+              -> (Executable -> a)+              -> (TestSuite -> a)+              -> (Benchmark -> a)+              -> Component+              -> a+foldComponent f _ _ _ _ (CLib   lib) = f lib+foldComponent _ f _ _ _ (CFLib  flib)= f flib+foldComponent _ _ f _ _ (CExe   exe) = f exe+foldComponent _ _ _ f _ (CTest  tst) = f tst+foldComponent _ _ _ _ f (CBench bch) = f bch++componentBuildInfo :: Component -> BuildInfo+componentBuildInfo =+  foldComponent libBuildInfo foreignLibBuildInfo buildInfo testBuildInfo benchmarkBuildInfo++-- | Is a component buildable (i.e., not marked with @buildable: False@)?+-- See also this note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".+--+-- @since 2.0.0.0+--+componentBuildable :: Component -> Bool+componentBuildable = buildable . componentBuildInfo++componentName :: Component -> ComponentName+componentName =+  foldComponent getLibName+                (CFLibName  . foreignLibName)+                (CExeName   . exeName)+                (CTestName  . testName)+                (CBenchName . benchmarkName)+ where+  getLibName lib = case libName lib of+                    Nothing -> CLibName+                    Just n -> CSubLibName n++partitionComponents+    :: [Component]+    -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark])+partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[])+  where+    fa x ~(a,b,c,d,e) = (x:a,b,c,d,e)+    fb x ~(a,b,c,d,e) = (a,x:b,c,d,e)+    fc x ~(a,b,c,d,e) = (a,b,x:c,d,e)+    fd x ~(a,b,c,d,e) = (a,b,c,x:d,e)+    fe x ~(a,b,c,d,e) = (a,b,c,d,x:e)
+ cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module Distribution.Types.ComponentLocalBuildInfo (+  ComponentLocalBuildInfo(..),+  componentIsIndefinite,+  ) where++import Prelude ()+import Distribution.Compat.Prelude+import Distribution.ModuleName++import Distribution.Backpack+import Distribution.Compat.Graph+import Distribution.Types.ComponentName++import Distribution.PackageDescription+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.Package++-- | The first five fields are common across all algebraic variants.+data ComponentLocalBuildInfo+  = LibComponentLocalBuildInfo {+    -- | It would be very convenient to store the literal Library here,+    -- but if we do that, it will get serialized (via the Binary)+    -- instance twice.  So instead we just provide the ComponentName,+    -- which can be used to find the Component in the+    -- PackageDescription.  NB: eventually, this will NOT uniquely+    -- identify the ComponentLocalBuildInfo.+    componentLocalName :: ComponentName,+    -- | The computed 'ComponentId' of this component.+    componentComponentId :: ComponentId,+    -- | The computed 'UnitId' which uniquely identifies this+    -- component.  Might be hashed.+    componentUnitId :: UnitId,+    -- | Is this an indefinite component (i.e. has unfilled holes)?+    componentIsIndefinite_ :: Bool,+    -- | How the component was instantiated+    componentInstantiatedWith :: [(ModuleName, OpenModule)],+    -- | Resolved internal and external package dependencies for this component.+    -- The 'BuildInfo' specifies a set of build dependencies that must be+    -- satisfied in terms of version ranges. This field fixes those dependencies+    -- to the specific versions available on this machine for this compiler.+    componentPackageDeps :: [(UnitId, PackageId)],+    -- | The set of packages that are brought into scope during+    -- compilation, including a 'ModuleRenaming' which may used+    -- to hide or rename modules.  This is what gets translated into+    -- @-package-id@ arguments.  This is a modernized version of+    -- 'componentPackageDeps', which is kept around for BC purposes.+    componentIncludes :: [(OpenUnitId, ModuleRenaming)],+    componentExeDeps :: [UnitId],+    -- | The internal dependencies which induce a graph on the+    -- 'ComponentLocalBuildInfo' of this package.  This does NOT+    -- coincide with 'componentPackageDeps' because it ALSO records+    -- 'build-tool' dependencies on executables.  Maybe one day+    -- @cabal-install@ will also handle these correctly too!+    componentInternalDeps :: [UnitId],+    -- | Compatibility "package key" that we pass to older versions of GHC.+    componentCompatPackageKey :: String,+    -- | Compatability "package name" that we register this component as.+    componentCompatPackageName :: PackageName,+    -- | A list of exposed modules (either defined in this component,+    -- or reexported from another component.)+    componentExposedModules :: [Installed.ExposedModule],+    -- | Convenience field, specifying whether or not this is the+    -- "public library" that has the same name as the package.+    componentIsPublic :: Bool+  }+  -- TODO: refactor all these duplicates+  | FLibComponentLocalBuildInfo {+    componentLocalName :: ComponentName,+    componentComponentId :: ComponentId,+    componentUnitId :: UnitId,+    componentPackageDeps :: [(UnitId, PackageId)],+    componentIncludes :: [(OpenUnitId, ModuleRenaming)],+    componentExeDeps :: [UnitId],+    componentInternalDeps :: [UnitId]+  }+  | ExeComponentLocalBuildInfo {+    componentLocalName :: ComponentName,+    componentComponentId :: ComponentId,+    componentUnitId :: UnitId,+    componentPackageDeps :: [(UnitId, PackageId)],+    componentIncludes :: [(OpenUnitId, ModuleRenaming)],+    componentExeDeps :: [UnitId],+    componentInternalDeps :: [UnitId]+  }+  | TestComponentLocalBuildInfo {+    componentLocalName :: ComponentName,+    componentComponentId :: ComponentId,+    componentUnitId :: UnitId,+    componentPackageDeps :: [(UnitId, PackageId)],+    componentIncludes :: [(OpenUnitId, ModuleRenaming)],+    componentExeDeps :: [UnitId],+    componentInternalDeps :: [UnitId]++  }+  | BenchComponentLocalBuildInfo {+    componentLocalName :: ComponentName,+    componentComponentId :: ComponentId,+    componentUnitId :: UnitId,+    componentPackageDeps :: [(UnitId, PackageId)],+    componentIncludes :: [(OpenUnitId, ModuleRenaming)],+    componentExeDeps :: [UnitId],+    componentInternalDeps :: [UnitId]+  }+  deriving (Generic, Read, Show)++instance Binary ComponentLocalBuildInfo++instance IsNode ComponentLocalBuildInfo where+    type Key ComponentLocalBuildInfo = UnitId+    nodeKey = componentUnitId+    nodeNeighbors = componentInternalDeps++componentIsIndefinite :: ComponentLocalBuildInfo -> Bool+componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b+componentIsIndefinite _ = False
+ cabal/Cabal/Distribution/Types/ComponentName.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.ComponentName (+  ComponentName(..),+  defaultLibName,+  showComponentName,+  componentNameString,+  ) where++import Prelude ()+import Distribution.Compat.Prelude++import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP   ((<++))+import Distribution.Package+import Distribution.Text++import Text.PrettyPrint as Disp++-- Libraries live in a separate namespace, so must distinguish+data ComponentName = CLibName+                   | CSubLibName UnqualComponentName+                   | CFLibName  UnqualComponentName+                   | CExeName   UnqualComponentName+                   | CTestName  UnqualComponentName+                   | CBenchName UnqualComponentName+                   deriving (Eq, Generic, Ord, Read, Show, Typeable)++instance Binary ComponentName++-- Build-target-ish syntax+instance Text ComponentName where+    disp CLibName = Disp.text "lib"+    disp (CSubLibName str) = Disp.text "lib:" <<>> disp str+    disp (CFLibName str)   = Disp.text "flib:" <<>> disp str+    disp (CExeName str)    = Disp.text "exe:" <<>> disp str+    disp (CTestName str)   = Disp.text "test:" <<>> disp str+    disp (CBenchName str)  = Disp.text "bench:" <<>> disp str++    parse = parseComposite <++ parseSingle+     where+      parseSingle = Parse.string "lib" >> return CLibName+      parseComposite = do+        ctor <- Parse.choice [ Parse.string "lib:" >> return CSubLibName+                             , Parse.string "flib:" >> return CFLibName+                             , Parse.string "exe:" >> return CExeName+                             , Parse.string "bench:" >> return CBenchName+                             , Parse.string "test:" >> return CTestName ]+        ctor <$> parse++defaultLibName :: ComponentName+defaultLibName = CLibName++showComponentName :: ComponentName -> String+showComponentName CLibName          = "library"+showComponentName (CSubLibName name) = "library '" ++ display name ++ "'"+showComponentName (CFLibName  name) = "foreign library '" ++ display name ++ "'"+showComponentName (CExeName   name) = "executable '" ++ display name ++ "'"+showComponentName (CTestName  name) = "test suite '" ++ display name ++ "'"+showComponentName (CBenchName name) = "benchmark '" ++ display name ++ "'"++-- | This gets the underlying unqualified component name. In fact, it is+-- guaranteed to uniquely identify a component, returning+-- @Nothing@ if the 'ComponentName' was for the public+-- library.+componentNameString :: ComponentName -> Maybe UnqualComponentName+componentNameString CLibName = Nothing+componentNameString (CSubLibName n) = Just n+componentNameString (CFLibName  n) = Just n+componentNameString (CExeName   n) = Just n+componentNameString (CTestName  n) = Just n+componentNameString (CBenchName n) = Just n
+ cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Types.ComponentRequestedSpec (+    -- $buildable_vs_enabled_components++    ComponentRequestedSpec(..),+    ComponentDisabledReason(..),++    defaultComponentRequestedSpec,+    componentNameRequested,++    componentEnabled,+    componentDisabledReason,+) where++import Prelude ()+import Distribution.Compat.Prelude+import Distribution.Text++import Distribution.Types.Component -- TODO: maybe remove me?+import Distribution.Types.ComponentName++-- $buildable_vs_enabled_components+-- #buildable_vs_enabled_components#+--+-- = Note: Buildable versus requested versus enabled components+-- What's the difference between a buildable component (ala+-- 'componentBuildable'), a requested component+-- (ala 'componentNameRequested'), and an enabled component (ala+-- 'componentEnabled')?+--+-- A component is __buildable__ if, after resolving flags and+-- conditionals, there is no @buildable: False@ property in it.+-- This is a /static/ property that arises from the+-- Cabal file and the package description flattening; once we have+-- a 'PackageDescription' buildability is known.+--+-- A component is __requested__ if a user specified, via a+-- the flags and arguments passed to configure, that it should be+-- built.  E.g., @--enable-tests@ or @--enable-benchmarks@ request+-- all tests and benchmarks, if they are provided.  What is requested+-- can be read off directly from 'ComponentRequestedSpec'.  A requested+-- component is not always buildable; e.g., a user may @--enable-tests@+-- but one of the test suites may have @buildable: False@.+--+-- A component is __enabled__ if it is BOTH buildable+-- and requested.  Once we have a 'LocalBuildInfo', whether or not a+-- component is enabled is known.+--+-- Generally speaking, most Cabal API code cares if a component+-- is enabled. (For example, if you want to run a preprocessor on each+-- component prior to building them, you want to run this on each+-- /enabled/ component.)+--+-- Note that post-configuration, you will generally not see a+-- non-buildable 'Component'.  This is because 'flattenPD' will drop+-- any such components from 'PackageDescription'.  See #3858 for+-- an example where this causes problems.++-- | Describes what components are enabled by user-interaction.+-- See also this note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".+--+-- @since 2.0.0.0+data ComponentRequestedSpec+    = ComponentRequestedSpec { testsRequested      :: Bool+                             , benchmarksRequested :: Bool }+    | OneComponentRequestedSpec ComponentName+  deriving (Generic, Read, Show, Eq)+instance Binary ComponentRequestedSpec++-- | The default set of enabled components.  Historically tests and+-- benchmarks are NOT enabled by default.+--+-- @since 2.0.0.0+defaultComponentRequestedSpec :: ComponentRequestedSpec+defaultComponentRequestedSpec = ComponentRequestedSpec False False++-- | Is this component enabled?  See also this note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".+--+-- @since 2.0.0.0+componentEnabled :: ComponentRequestedSpec -> Component -> Bool+componentEnabled enabled = isNothing . componentDisabledReason enabled++-- | Is this component name enabled?  See also this note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".+--+-- @since 2.0.0.0+componentNameRequested :: ComponentRequestedSpec -> ComponentName -> Bool+componentNameRequested enabled = isNothing . componentNameNotRequestedReason enabled++-- | Is this component disabled, and if so, why?+--+-- @since 2.0.0.0+componentDisabledReason :: ComponentRequestedSpec -> Component+                        -> Maybe ComponentDisabledReason+componentDisabledReason enabled comp+    | not (componentBuildable comp) = Just DisabledComponent+    | otherwise = componentNameNotRequestedReason enabled (componentName comp)++-- | Is this component name disabled, and if so, why?+--+-- @since 2.0.0.0+componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName+                            -> Maybe ComponentDisabledReason+componentNameNotRequestedReason+    ComponentRequestedSpec{ testsRequested      = False } (CTestName _)+    = Just DisabledAllTests+componentNameNotRequestedReason+    ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _)+    = Just DisabledAllBenchmarks+componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing+componentNameNotRequestedReason (OneComponentRequestedSpec cname) c+    | c == cname = Nothing+    | otherwise = Just (DisabledAllButOne (display cname))++-- | A reason explaining why a component is disabled.+--+-- @since 2.0.0.0+data ComponentDisabledReason = DisabledComponent+                             | DisabledAllTests+                             | DisabledAllBenchmarks+                             | DisabledAllButOne String
+ cabal/Cabal/Distribution/Types/Executable.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}++module Distribution.Types.Executable (+    Executable(..),+    emptyExecutable,+    exeModules,+    exeModulesAutogen+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.BuildInfo+import Distribution.ModuleName+import Distribution.Package++data Executable = Executable {+        exeName    :: UnqualComponentName,+        modulePath :: FilePath,+        buildInfo  :: BuildInfo+    }+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary Executable++instance Monoid Executable where+  mempty = gmempty+  mappend = (<>)++instance Semigroup Executable where+  a <> b = Executable{+    exeName    = combine' exeName,+    modulePath = combine modulePath,+    buildInfo  = combine buildInfo+  }+    where combine field = field a `mappend` field b+          combine' field = case ( unUnqualComponentName $ field a+                                , unUnqualComponentName $ field b) of+                      ("", _) -> field b+                      (_, "") -> field a+                      (x, y) -> error $ "Ambiguous values for executable field: '"+                                  ++ x ++ "' and '" ++ y ++ "'"++emptyExecutable :: Executable+emptyExecutable = mempty++-- | Get all the module names from an exe+exeModules :: Executable -> [ModuleName]+exeModules exe = otherModules (buildInfo exe)++-- | Get all the auto generated module names from an exe+-- This are a subset of 'exeModules'.+exeModulesAutogen :: Executable -> [ModuleName]+exeModulesAutogen exe = autogenModules (buildInfo exe)
+ cabal/Cabal/Distribution/Types/ForeignLib.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}++module Distribution.Types.ForeignLib(+    ForeignLib(..),+    emptyForeignLib,+    foreignLibModules,+    foreignLibIsShared,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Package+import Distribution.ModuleName++import Distribution.Types.BuildInfo+import Distribution.Types.ForeignLibType+import Distribution.Types.ForeignLibOption++-- | A foreign library stanza is like a library stanza, except that+-- the built code is intended for consumption by a non-Haskell client.+data ForeignLib = ForeignLib {+      -- | Name of the foreign library+      foreignLibName       :: UnqualComponentName+      -- | What kind of foreign library is this (static or dynamic).+    , foreignLibType       :: ForeignLibType+      -- | What options apply to this foreign library (e.g., are we+      -- merging in all foreign dependencies.)+    , foreignLibOptions    :: [ForeignLibOption]+      -- | Build information for this foreign library.+    , foreignLibBuildInfo  :: BuildInfo++      -- | (Windows-specific) module definition files+      --+      -- This is a list rather than a maybe field so that we can flatten+      -- the condition trees (for instance, when creating an sdist)+    , foreignLibModDefFile :: [FilePath]+    }+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary ForeignLib++instance Semigroup ForeignLib where+  a <> b = ForeignLib {+      foreignLibName       = combine' foreignLibName+    , foreignLibType       = combine  foreignLibType+    , foreignLibOptions    = combine  foreignLibOptions+    , foreignLibBuildInfo  = combine  foreignLibBuildInfo+    , foreignLibModDefFile = combine  foreignLibModDefFile+    }+    where combine field = field a `mappend` field b+          combine' field = case ( unUnqualComponentName $ field a+                                , unUnqualComponentName $ field b) of+            ("", _) -> field b+            (_, "") -> field a+            (x, y) -> error $ "Ambiguous values for executable field: '"+                                  ++ x ++ "' and '" ++ y ++ "'"++instance Monoid ForeignLib where+  mempty = ForeignLib {+      foreignLibName       = mempty+    , foreignLibType       = ForeignLibTypeUnknown+    , foreignLibOptions    = []+    , foreignLibBuildInfo  = mempty+    , foreignLibModDefFile = []+    }+  mappend = (<>)++-- | An empty foreign library.+emptyForeignLib :: ForeignLib+emptyForeignLib = mempty++-- | Modules defined by a foreign library.+foreignLibModules :: ForeignLib -> [ModuleName]+foreignLibModules = otherModules . foreignLibBuildInfo++-- | Is the foreign library shared?+foreignLibIsShared :: ForeignLib -> Bool+foreignLibIsShared = foreignLibTypeIsShared . foreignLibType
+ cabal/Cabal/Distribution/Types/ForeignLibOption.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.ForeignLibOption(+    ForeignLibOption(..)+) where++import Prelude ()+import Distribution.Compat.Prelude++import Text.PrettyPrint+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Text++data ForeignLibOption =+     -- | Merge in all dependent libraries (i.e., use+     -- @ghc -shared -static@ rather than just record+     -- the dependencies, ala @ghc -shared -dynamic@).+     -- This option is compulsory on Windows and unsupported+     -- on other platforms.+     ForeignLibStandalone+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Text ForeignLibOption where+  disp ForeignLibStandalone = text "standalone"++  parse = Parse.choice [+      do _ <- Parse.string "standalone" ; return ForeignLibStandalone+    ]++instance Binary ForeignLibOption+
+ cabal/Cabal/Distribution/Types/ForeignLibType.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.ForeignLibType(+    ForeignLibType(..),+    knownForeignLibTypes,+    foreignLibTypeIsShared,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Text.PrettyPrint hiding ((<>))+import Distribution.Text+import qualified Distribution.Compat.ReadP as Parse+import Distribution.PackageDescription.Utils++-- | What kind of foreign library is to be built?+data ForeignLibType =+      -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or+      -- @.dll@ on Windows).+      ForeignLibNativeShared+      -- | A native static library (not currently supported.)+    | ForeignLibNativeStatic+      -- TODO: Maybe this should record a string?+    | ForeignLibTypeUnknown+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Text ForeignLibType where+  disp ForeignLibNativeShared = text "native-shared"+  disp ForeignLibNativeStatic = text "native-static"+  disp ForeignLibTypeUnknown  = text "unknown"++  parse = Parse.choice [+      do _ <- Parse.string "native-shared" ; return ForeignLibNativeShared+    , do _ <- Parse.string "native-static" ; return ForeignLibNativeStatic+    ]++instance Binary ForeignLibType++instance Semigroup ForeignLibType where+  ForeignLibTypeUnknown <> b = b+  a <> ForeignLibTypeUnknown = a+  _ <> _ = error "Ambiguous foreign library type"++instance Monoid ForeignLibType where+  mempty = ForeignLibTypeUnknown+  mappend = (<>)++knownForeignLibTypes :: [ForeignLibType]+knownForeignLibTypes = [+      ForeignLibNativeShared+    , ForeignLibNativeStatic+    ]++foreignLibTypeIsShared :: ForeignLibType -> Bool+foreignLibTypeIsShared t =+    case t of+      ForeignLibNativeShared -> True+      ForeignLibNativeStatic -> False+      ForeignLibTypeUnknown  -> cabalBug "Unknown foreign library type"
+ cabal/Cabal/Distribution/Types/GenericPackageDescription.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}++module Distribution.Types.GenericPackageDescription (+    GenericPackageDescription(..),+    Flag(..),+    emptyFlag,+    FlagName,+    mkFlagName,+    unFlagName,+    FlagAssignment,+    ConfVar(..),+    Condition(..),+    CondTree(..),+    cOr,+    cAnd,+    cNot,+) where++import Prelude ()+import Distribution.Compat.Prelude+import Distribution.Utils.ShortText++import Distribution.Types.PackageDescription++import Distribution.Types.Library+import Distribution.Types.ForeignLib+import Distribution.Types.Executable+import Distribution.Types.TestSuite+import Distribution.Types.Benchmark++import Distribution.Package+import Distribution.Version+import Distribution.Compiler+import Distribution.System++-- ---------------------------------------------------------------------------+-- The GenericPackageDescription type++data GenericPackageDescription =+    GenericPackageDescription {+        packageDescription :: PackageDescription,+        genPackageFlags    :: [Flag],+        condLibrary        :: Maybe (CondTree ConfVar [Dependency] Library),+        condSubLibraries   :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)],+        condForeignLibs    :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)],+        condExecutables    :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)],+        condTestSuites     :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)],+        condBenchmarks     :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]+      }+    deriving (Show, Eq, Typeable, Data, Generic)++instance Package GenericPackageDescription where+  packageId = packageId . packageDescription++instance Binary GenericPackageDescription++-- | A flag can represent a feature to be included, or a way of linking+--   a target against its dependencies, or in fact whatever you can think of.+data Flag = MkFlag+    { flagName        :: FlagName+    , flagDescription :: String+    , flagDefault     :: Bool+    , flagManual      :: Bool+    }+    deriving (Show, Eq, Typeable, Data, Generic)++instance Binary Flag++-- | A 'Flag' initialized with default parameters.+emptyFlag :: FlagName -> Flag+emptyFlag name = MkFlag+    { flagName        = name+    , flagDescription = ""+    , flagDefault     = True+    , flagManual      = False+    }++-- | A 'FlagName' is the name of a user-defined configuration flag+--+-- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'.+--+-- This type is opaque since @Cabal-2.0@+--+-- @since 2.0+newtype FlagName = FlagName ShortText+    deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)++-- | Construct a 'FlagName' from a 'String'+--+-- 'mkFlagName' is the inverse to 'unFlagName'+--+-- Note: No validations are performed to ensure that the resulting+-- 'FlagName' is valid+--+-- @since 2.0+mkFlagName :: String -> FlagName+mkFlagName = FlagName . toShortText++-- | Convert 'FlagName' to 'String'+--+-- @since 2.0+unFlagName :: FlagName -> String+unFlagName (FlagName s) = fromShortText s++instance Binary FlagName++-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to+-- 'Bool' flag values. It represents the flags chosen by the user or+-- discovered during configuration. For example @--flags=foo --flags=-bar@+-- becomes @[("foo", True), ("bar", False)]@+--+type FlagAssignment = [(FlagName, Bool)]++-- | A @ConfVar@ represents the variable type used.+data ConfVar = OS OS+             | Arch Arch+             | Flag FlagName+             | Impl CompilerFlavor VersionRange+    deriving (Eq, Show, Typeable, Data, Generic)++instance Binary ConfVar++-- | A boolean expression parameterized over the variable type used.+data Condition c = Var c+                 | Lit Bool+                 | CNot (Condition c)+                 | COr (Condition c) (Condition c)+                 | CAnd (Condition c) (Condition c)+    deriving (Show, Eq, Typeable, Data, Generic)++-- | Boolean negation of a 'Condition' value.+cNot :: Condition a -> Condition a+cNot (Lit b)  = Lit (not b)+cNot (CNot c) = c+cNot c        = CNot c++-- | Boolean AND of two 'Condtion' values.+cAnd :: Condition a -> Condition a -> Condition a+cAnd (Lit False) _           = Lit False+cAnd _           (Lit False) = Lit False+cAnd (Lit True)  x           = x+cAnd x           (Lit True)  = x+cAnd x           y           = CAnd x y++-- | Boolean OR of two 'Condition' values.+cOr :: Eq v => Condition v -> Condition v -> Condition v+cOr  (Lit True)  _           = Lit True+cOr  _           (Lit True)  = Lit True+cOr  (Lit False) x           = x+cOr  x           (Lit False) = x+cOr  c           (CNot d)+  | c == d                   = Lit True+cOr  (CNot c)    d+  | c == d                   = Lit True+cOr  x           y           = COr x y++instance Functor Condition where+  f `fmap` Var c    = Var (f c)+  _ `fmap` Lit c    = Lit c+  f `fmap` CNot c   = CNot (fmap f c)+  f `fmap` COr c d  = COr  (fmap f c) (fmap f d)+  f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d)++instance Foldable Condition where+  f `foldMap` Var c    = f c+  _ `foldMap` Lit _    = mempty+  f `foldMap` CNot c   = foldMap f c+  f `foldMap` COr c d  = foldMap f c `mappend` foldMap f d+  f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d++instance Traversable Condition where+  f `traverse` Var c    = Var `fmap` f c+  _ `traverse` Lit c    = pure $ Lit c+  f `traverse` CNot c   = CNot `fmap` traverse f c+  f `traverse` COr c d  = COr  `fmap` traverse f c <*> traverse f d+  f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d++instance Applicative Condition where+  pure  = Var+  (<*>) = ap++instance Monad Condition where+  return = pure+  -- Terminating cases+  (>>=) (Lit x) _ = Lit x+  (>>=) (Var x) f = f x+  -- Recursing cases+  (>>=) (CNot  x  ) f = CNot (x >>= f)+  (>>=) (COr   x y) f = COr  (x >>= f) (y >>= f)+  (>>=) (CAnd  x y) f = CAnd (x >>= f) (y >>= f)++instance Monoid (Condition a) where+  mempty = Lit False+  mappend = (<>)++instance Semigroup (Condition a) where+  (<>) = COr++instance Alternative Condition where+  empty = mempty+  (<|>) = mappend++instance MonadPlus Condition where+  mzero = mempty+  mplus = mappend++instance Binary c => Binary (Condition c)++data CondTree v c a = CondNode+    { condTreeData        :: a+    , condTreeConstraints :: c+    , condTreeComponents  :: [( Condition v+                              , CondTree v c a+                              , Maybe (CondTree v c a))]+    }+    deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)++instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)
+ cabal/Cabal/Distribution/Types/HookedBuildInfo.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.HookedBuildInfo (+    HookedBuildInfo,+    emptyHookedBuildInfo,+  ) where++-- import Distribution.Compat.Prelude+import Distribution.Types.BuildInfo+import Distribution.Package++-- | 'HookedBuildInfo' is mechanism that hooks can use to+-- override the 'BuildInfo's inside packages.  One example+-- use-case (which is used in core libraries today) is as+-- a way of passing flags which are computed by a configure+-- script into Cabal.  In this case, the autoconf build type adds+-- hooks to read in a textual 'HookedBuildInfo' format prior+-- to doing any operations.+--+-- Quite honestly, this mechanism is a massive hack since we shouldn't+-- be editing the 'PackageDescription' data structure (it's easy+-- to assume that this data structure shouldn't change and+-- run into bugs, see for example 1c20a6328579af9e37677d507e2e9836ef70ab9d).+-- But it's a bit convenient, because there isn't another data+-- structure that allows adding extra 'BuildInfo' style things.+--+-- In any case, a lot of care has to be taken to make sure the+-- 'HookedBuildInfo' is applied to the 'PackageDescription'.  In+-- general this process occurs in "Distribution.Simple", which is+-- responsible for orchestrating the hooks mechanism.  The+-- general strategy:+--+--      1. We run the pre-hook, which produces a 'HookedBuildInfo'+--         (e.g., in the Autoconf case, it reads it out from a file).+--      2. We sanity-check the hooked build info with+--         'sanityCheckHookedBuildInfo'.+--      3. We update our 'PackageDescription' (either freshly read+--         or cached from 'LocalBuildInfo') with 'updatePackageDescription'.+--+--         In principle, we are also supposed to update the copy of+--         the 'PackageDescription' stored in 'LocalBuildInfo'+--         at 'localPkgDescr'.  Unfortunately, in practice, there+--         are lots of Custom setup scripts which fail to update+--         'localPkgDescr' so you really shouldn't rely on it.+--         It's not DEPRECATED because there are legitimate uses+--         for it, but... yeah.  Sharp knife.  See+--         <https://github.com/haskell/cabal/issues/3606>+--         for more information on the issue.+--+-- It is not well-specified whether or not a 'HookedBuildInfo' applied+-- at configure time is persistent to the 'LocalBuildInfo'.  The+-- fact that 'HookedBuildInfo' is passed to 'confHook' MIGHT SUGGEST+-- that the 'HookedBuildInfo' is applied at this time, but actually+-- since 9317b67e6122ab14e53f81b573bd0ecb388eca5a it has been ONLY used+-- to create a modified package description that we check for problems:+-- it is never actually saved to the LBI.  Since 'HookedBuildInfo' is+-- applied monoidally to the existing build infos (and it is not an+-- idempotent monoid), it could break things to save it, since we+-- are obligated to apply any new 'HookedBuildInfo' and then we'd+-- get the effect twice.  But this does mean we have to re-apply+-- it every time. Hey, it's more flexibility.+type HookedBuildInfo = (Maybe BuildInfo, [(UnqualComponentName, BuildInfo)])++emptyHookedBuildInfo :: HookedBuildInfo+emptyHookedBuildInfo = (Nothing, [])
+ cabal/Cabal/Distribution/Types/IncludeRenaming.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.IncludeRenaming (+    IncludeRenaming(..),+    defaultIncludeRenaming,+    isDefaultIncludeRenaming,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.ModuleRenaming++import Distribution.Text++import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<+>), text)+import Distribution.Compat.ReadP++-- ---------------------------------------------------------------------------+-- Module renaming++-- | A renaming on an include: (provides renaming, requires renaming)+data IncludeRenaming+    = IncludeRenaming {+        includeProvidesRn :: ModuleRenaming,+        includeRequiresRn :: ModuleRenaming+    }+    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)++instance Binary IncludeRenaming++-- | The 'defaultIncludeRenaming' applied when you only @build-depends@+-- on a package.+defaultIncludeRenaming :: IncludeRenaming+defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming++-- | Is an 'IncludeRenaming' the default one?+isDefaultIncludeRenaming :: IncludeRenaming -> Bool+isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r++instance Text IncludeRenaming where+    disp (IncludeRenaming prov_rn req_rn) =+        disp prov_rn+          <+> (if isDefaultRenaming req_rn+                then Disp.empty+                else text "requires" <+> disp req_rn)+    parse = do+        prov_rn <- parse+        req_rn <- (string "requires" >> skipSpaces >> parse) <++ return defaultRenaming+        -- Requirements don't really care if they're mentioned+        -- or not (since you can't thin a requirement.)  But+        -- we have a little hack in Configure to combine+        -- the provisions and requirements together before passing+        -- them to GHC, and so the most neutral choice for a requirement+        -- is for the "with" field to be False, so we correctly+        -- thin provisions.+        return (IncludeRenaming prov_rn req_rn)
+ cabal/Cabal/Distribution/Types/Library.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}++module Distribution.Types.Library (+    Library(..),+    emptyLibrary,+    explicitLibModules,+    libModulesAutogen,+    libModules,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.BuildInfo+import Distribution.Types.ModuleReexport+import Distribution.ModuleName+import Distribution.Package++data Library = Library {+        libName :: Maybe UnqualComponentName,+        exposedModules    :: [ModuleName],+        reexportedModules :: [ModuleReexport],+        signatures:: [ModuleName], -- ^ What sigs need implementations?+        libExposed        :: Bool, -- ^ Is the lib to be exposed by default?+        libBuildInfo      :: BuildInfo+    }+    deriving (Generic, Show, Eq, Read, Typeable, Data)++instance Binary Library++instance Monoid Library where+  mempty = Library {+    libName = mempty,+    exposedModules = mempty,+    reexportedModules = mempty,+    signatures = mempty,+    libExposed     = True,+    libBuildInfo   = mempty+  }+  mappend = (<>)++instance Semigroup Library where+  a <> b = Library {+    libName = combine libName,+    exposedModules = combine exposedModules,+    reexportedModules = combine reexportedModules,+    signatures = combine signatures,+    libExposed     = libExposed a && libExposed b, -- so False propagates+    libBuildInfo   = combine libBuildInfo+  }+    where combine field = field a `mappend` field b++emptyLibrary :: Library+emptyLibrary = mempty++-- | Get all the module names from the library (exposed and internal modules)+-- which are explicitly listed in the package description which would+-- need to be compiled.  (This does not include reexports, which+-- do not need to be compiled.)  This may not include all modules for which+-- GHC generated interface files (i.e., implicit modules.)+explicitLibModules :: Library -> [ModuleName]+explicitLibModules lib = exposedModules lib+              ++ otherModules (libBuildInfo lib)+              ++ signatures lib++-- | Get all the auto generated module names from the library, exposed or not.+-- This are a subset of 'libModules'.+libModulesAutogen :: Library -> [ModuleName]+libModulesAutogen lib = autogenModules (libBuildInfo lib)++-- | Backwards-compatibility shim for 'explicitLibModules'.  In most cases,+-- you actually want 'allLibModules', which returns all modules that will+-- actually be compiled, as opposed to those which are explicitly listed+-- in the package description ('explicitLibModules'); unfortunately, the+-- type signature for 'allLibModules' is incompatible since we need a+-- 'ComponentLocalBuildInfo'.+{-# DEPRECATED libModules "If you want all modules that are built with a library, use 'allLibModules'.  Otherwise, use 'explicitLibModules' for ONLY the modules explicitly mentioned in the package description." #-}+libModules :: Library -> [ModuleName]+libModules = explicitLibModules
+ cabal/Cabal/Distribution/Types/LocalBuildInfo.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Types.LocalBuildInfo (+    -- * The type++    LocalBuildInfo(..),++    -- * Convenience accessors++    localComponentId,+    localUnitId,+    localCompatPackageKey,+    localPackage,++    -- * Build targets of the 'LocalBuildInfo'.++    componentNameCLBIs,++    -- NB: the primes mean that they take a 'PackageDescription'+    -- which may not match 'localPkgDescr' in 'LocalBuildInfo'.+    -- More logical types would drop this argument, but+    -- at the moment, this is the ONLY supported function, because+    -- 'localPkgDescr' is not guaranteed to match.  At some point+    -- we will fix it and then we can use the (free) unprimed+    -- namespace for the correct commands.+    --+    -- See https://github.com/haskell/cabal/issues/3606 for more+    -- details.++    componentNameTargets',+    unitIdTarget',+    allTargetsInBuildOrder',+    withAllTargetsInBuildOrder',+    neededTargetsInBuildOrder',+    withNeededTargetsInBuildOrder',+    testCoverage,++    -- * Functions you SHOULD NOT USE (yet), but are defined here to+    -- prevent someone from accidentally defining them++    componentNameTargets,+    unitIdTarget,+    allTargetsInBuildOrder,+    withAllTargetsInBuildOrder,+    neededTargetsInBuildOrder,+    withNeededTargetsInBuildOrder,++    -- * Backwards compatibility.++    componentsConfigs,+    externalPackageDeps,+  ) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.PackageDescription+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.TargetInfo++import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,+                                               prefixRelativeInstallDirs,+                                               substPathTemplate, )+import Distribution.Simple.Program+import Distribution.PackageDescription+import Distribution.Package+import Distribution.Simple.Compiler+import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup+import Distribution.Text+import Distribution.System++import Distribution.Compat.Graph (Graph)+import qualified Distribution.Compat.Graph as Graph+import qualified Data.Map as Map++-- | Data cached after configuration step.  See also+-- 'Distribution.Simple.Setup.ConfigFlags'.+data LocalBuildInfo = LocalBuildInfo {+        configFlags   :: ConfigFlags,+        -- ^ Options passed to the configuration step.+        -- Needed to re-run configuration when .cabal is out of date+        flagAssignment :: FlagAssignment,+        -- ^ The final set of flags which were picked for this package+        componentEnabledSpec :: ComponentRequestedSpec,+        -- ^ What components were enabled during configuration, and why.+        extraConfigArgs     :: [String],+        -- ^ Extra args on the command line for the configuration step.+        -- Needed to re-run configuration when .cabal is out of date+        installDirTemplates :: InstallDirTemplates,+                -- ^ The installation directories for the various different+                -- kinds of files+        --TODO: inplaceDirTemplates :: InstallDirs FilePath+        compiler      :: Compiler,+                -- ^ The compiler we're building with+        hostPlatform  :: Platform,+                -- ^ The platform we're building for+        buildDir      :: FilePath,+                -- ^ Where to build the package.+        componentGraph :: Graph ComponentLocalBuildInfo,+                -- ^ All the components to build, ordered by topological+                -- sort, and with their INTERNAL dependencies over the+                -- intrapackage dependency graph.+                -- TODO: this is assumed to be short; otherwise we want+                -- some sort of ordered map.+        componentNameMap :: Map ComponentName [ComponentLocalBuildInfo],+                -- ^ A map from component name to all matching+                -- components.  These coincide with 'componentGraph'+        installedPkgs :: InstalledPackageIndex,+                -- ^ All the info about the installed packages that the+                -- current package depends on (directly or indirectly).+                -- The copy saved on disk does NOT include internal+                -- dependencies (because we just don't have enough+                -- information at this point to have an+                -- 'InstalledPackageInfo' for an internal dep), but we+                -- will often update it with the internal dependencies;+                -- see for example 'Distribution.Simple.Build.build'.+                -- (This admonition doesn't apply for per-component builds.)+        pkgDescrFile  :: Maybe FilePath,+                -- ^ the filename containing the .cabal file, if available+        localPkgDescr :: PackageDescription,+                -- ^ WARNING WARNING WARNING Be VERY careful about using+                -- this function; we haven't deprecated it but using it+                -- could introduce subtle bugs related to+                -- 'HookedBuildInfo'.+                --+                -- In principle, this is supposed to contain the+                -- resolved package description, that does not contain+                -- any conditionals.  However, it MAY NOT contain+                -- the description wtih a 'HookedBuildInfo' applied+                -- to it; see 'HookedBuildInfo' for the whole sordid saga.+                -- As much as possible, Cabal library should avoid using+                -- this parameter.+        withPrograms  :: ProgramDb, -- ^Location and args for all programs+        withPackageDB :: PackageDBStack,  -- ^What package database to use, global\/user+        withVanillaLib:: Bool,  -- ^Whether to build normal libs.+        withProfLib   :: Bool,  -- ^Whether to build profiling versions of libs.+        withSharedLib :: Bool,  -- ^Whether to build shared versions of libs.+        withDynExe    :: Bool,  -- ^Whether to link executables dynamically+        withProfExe   :: Bool,  -- ^Whether to build executables for profiling.+        withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.+        withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.+        withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available).+        withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available).+        withGHCiLib   :: Bool,  -- ^Whether to build libs suitable for use with GHCi.+        splitObjs     :: Bool,  -- ^Use -split-objs with GHC, if available+        stripExes     :: Bool,  -- ^Whether to strip executables during install+        stripLibs     :: Bool,  -- ^Whether to strip libraries during install+        exeCoverage :: Bool,  -- ^Whether to enable executable program coverage+        libCoverage :: Bool,  -- ^Whether to enable library program coverage+        progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables+        progSuffix    :: PathTemplate, -- ^Suffix to be appended to installed executables+        relocatable   :: Bool --  ^Whether to build a relocatable package+  } deriving (Generic, Read, Show)++instance Binary LocalBuildInfo++-------------------------------------------------------------------------------+-- Accessor functions++-- TODO: Get rid of these functions, as much as possible.  They are+-- a bit useful in some cases, but you should be very careful!++-- | Extract the 'ComponentId' from the public library component of a+-- 'LocalBuildInfo' if it exists, or make a fake component ID based+-- on the package ID.+localComponentId :: LocalBuildInfo -> ComponentId+localComponentId lbi =+    case componentNameCLBIs lbi CLibName of+        [LibComponentLocalBuildInfo { componentComponentId = cid }]+          -> cid+        _ -> mkComponentId (display (localPackage lbi))++-- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'.+-- This is a "safe" use of 'localPkgDescr'+localPackage :: LocalBuildInfo -> PackageId+localPackage lbi = package (localPkgDescr lbi)++-- | Extract the 'UnitId' from the library component of a+-- 'LocalBuildInfo' if it exists, or make a fake unit ID based on+-- the package ID.+localUnitId :: LocalBuildInfo -> UnitId+localUnitId lbi =+    case componentNameCLBIs lbi CLibName of+        [LibComponentLocalBuildInfo { componentUnitId = uid }]+          -> uid+        _ -> mkLegacyUnitId (localPackage lbi)++-- | Extract the compatibility package key from the public library component of a+-- 'LocalBuildInfo' if it exists, or make a fake package key based+-- on the package ID.+localCompatPackageKey :: LocalBuildInfo -> String+localCompatPackageKey lbi =+    case componentNameCLBIs lbi CLibName of+        [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }]+          -> pk+        _ -> display (localPackage lbi)++-- | Convenience function to generate a default 'TargetInfo' from a+-- 'ComponentLocalBuildInfo'.  The idea is to call this once, and then+-- use 'TargetInfo' everywhere else.  Private to this module.+mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo+mkTargetInfo pkg_descr _lbi clbi =+    TargetInfo {+        targetCLBI = clbi,+        -- NB: @pkg_descr@, not @localPkgDescr lbi@!+        targetComponent = getComponent pkg_descr+                                       (componentLocalName clbi)+     }++-- | Return all 'TargetInfo's associated with 'ComponentName'.+-- In the presence of Backpack there may be more than one!+-- Has a prime because it takes a 'PackageDescription' argument+-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.+componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo]+componentNameTargets' pkg_descr lbi cname =+    case Map.lookup cname (componentNameMap lbi) of+        Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis+        Nothing -> []++unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo+unitIdTarget' pkg_descr lbi uid =+    case Graph.lookup uid (componentGraph lbi) of+        Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi)+        Nothing -> Nothing++-- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'.+-- In the presence of Backpack there may be more than one!+componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo]+componentNameCLBIs lbi cname =+    case Map.lookup cname (componentNameMap lbi) of+        Just clbis -> clbis+        Nothing -> []++-- TODO: Maybe cache topsort (Graph can do this)++-- | Return the list of default 'TargetInfo's associated with a+-- configured package, in the order they need to be built.+-- Has a prime because it takes a 'PackageDescription' argument+-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.+allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo]+allTargetsInBuildOrder' pkg_descr lbi+    = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi))++-- | Execute @f@ for every 'TargetInfo' in the package, respecting the+-- build dependency order.  (TODO: We should use Shake!)+-- Has a prime because it takes a 'PackageDescription' argument+-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.+withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()+withAllTargetsInBuildOrder' pkg_descr lbi f+    = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ]++-- | Return the list of all targets needed to build the @uids@, in+-- the order they need to be built.+-- Has a prime because it takes a 'PackageDescription' argument+-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.+neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo]+neededTargetsInBuildOrder' pkg_descr lbi uids =+  case Graph.closure (componentGraph lbi) uids of+    Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map display uids)+    Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromList clos))++-- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting+-- the build dependency order.+-- Has a prime because it takes a 'PackageDescription' argument+-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.+withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()+withNeededTargetsInBuildOrder' pkg_descr lbi uids f+    = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ]++-- | Is coverage enabled for test suites? In practice, this requires library+-- and executable profiling to be enabled.+testCoverage :: LocalBuildInfo -> Bool+testCoverage lbi = exeCoverage lbi && libCoverage lbi++-------------------------------------------------------------------------------+-- Stub functions to prevent someone from accidentally defining them++{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it.  See the documentation for 'HookedBuildInfo' for an explanation of the issue.  If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-}++componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo]+componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi++unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo+unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi++allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo]+allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi++withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()+withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi++neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo]+neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi++withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()+withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi++-------------------------------------------------------------------------------+-- Backwards compatibility++{-# DEPRECATED componentsConfigs "Use 'componentGraph' instead; you can get a list of 'ComponentLocalBuildInfo' with 'Distribution.Compat.Graph.toList'. There's not a good way to get the list of 'ComponentName's the 'ComponentLocalBuildInfo' depends on because this query doesn't make sense; the graph is indexed by 'UnitId' not 'ComponentName'.  Given a 'UnitId' you can lookup the 'ComponentLocalBuildInfo' ('getCLBI') and then get the 'ComponentName' ('componentLocalName]). To be removed in Cabal 2.2" #-}+componentsConfigs :: LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]+componentsConfigs lbi =+    [ (componentLocalName clbi,+       clbi,+       mapMaybe (fmap componentLocalName . flip Graph.lookup g)+                (componentInternalDeps clbi))+    | clbi <- Graph.toList g ]+  where+    g = componentGraph lbi++-- | External package dependencies for the package as a whole. This is the+-- union of the individual 'componentPackageDeps', less any internal deps.+{-# DEPRECATED externalPackageDeps "You almost certainly don't want this function, which agglomerates the dependencies of ALL enabled components.  If you're using this to write out information on your dependencies, read off the dependencies directly from the actual component in question.  To be removed in Cabal 2.2" #-}+externalPackageDeps :: LocalBuildInfo -> [(UnitId, PackageId)]+externalPackageDeps lbi =+    -- TODO:  what about non-buildable components?+    nub [ (ipkgid, pkgid)+        | clbi            <- Graph.toList (componentGraph lbi)+        , (ipkgid, pkgid) <- componentPackageDeps clbi+        , not (internal ipkgid) ]+  where+    -- True if this dependency is an internal one (depends on the library+    -- defined in the same package).+    internal ipkgid = any ((==ipkgid) . componentUnitId) (Graph.toList (componentGraph lbi))
+ cabal/Cabal/Distribution/Types/Mixin.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.Mixin (+    Mixin(..),+) where++import Prelude ()+import Distribution.Compat.Prelude++import Text.PrettyPrint ((<+>))+import Distribution.Compat.ReadP+import Distribution.Text++import Distribution.Package+import Distribution.Types.IncludeRenaming++data Mixin = Mixin { mixinPackageName :: PackageName+                   , mixinIncludeRenaming :: IncludeRenaming }+    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)++instance Binary Mixin++instance Text Mixin where+    disp (Mixin pkg_name incl) =+        disp pkg_name <+> disp incl++    parse = do+        pkg_name <- parse+        skipSpaces+        incl <- parse+        return (Mixin pkg_name incl)
+ cabal/Cabal/Distribution/Types/ModuleReexport.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.ModuleReexport (+    ModuleReexport(..)+) where++import Prelude ()+import Distribution.Compat.Prelude++import qualified Distribution.Compat.ReadP as Parse+import Distribution.Package+import Distribution.ModuleName+import Distribution.Text++import Text.PrettyPrint as Disp++-- -----------------------------------------------------------------------------+-- Module re-exports++data ModuleReexport = ModuleReexport {+       moduleReexportOriginalPackage :: Maybe PackageName,+       moduleReexportOriginalName    :: ModuleName,+       moduleReexportName            :: ModuleName+    }+    deriving (Eq, Generic, Read, Show, Typeable, Data)++instance Binary ModuleReexport++instance Text ModuleReexport where+    disp (ModuleReexport mpkgname origname newname) =+          maybe Disp.empty (\pkgname -> disp pkgname <<>> Disp.char ':') mpkgname+       <<>> disp origname+      <+> if newname == origname+            then Disp.empty+            else Disp.text "as" <+> disp newname++    parse = do+      mpkgname <- Parse.option Nothing $ do+                    pkgname <- parse+                    _       <- Parse.char ':'+                    return (Just pkgname)+      origname <- parse+      newname  <- Parse.option origname $ do+                    Parse.skipSpaces+                    _ <- Parse.string "as"+                    Parse.skipSpaces+                    parse+      return (ModuleReexport mpkgname origname newname)
+ cabal/Cabal/Distribution/Types/ModuleRenaming.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.ModuleRenaming (+    ModuleRenaming(..),+    defaultRenaming,+    isDefaultRenaming,+) where++import Prelude ()+import Distribution.Compat.Prelude hiding (empty)++import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP   ((<++))+import Distribution.ModuleName+import Distribution.Text++import Text.PrettyPrint++-- | Renaming applied to the modules provided by a package.+-- The boolean indicates whether or not to also include all of the+-- original names of modules.  Thus, @ModuleRenaming False []@ is+-- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@+-- is, "expose all modules, but also expose @Data.Bool@ as @Bool@".+-- If a renaming is omitted you get the 'DefaultRenaming'.+--+-- (NB: This is a list not a map so that we can preserve order.)+--+data ModuleRenaming+        -- | A module renaming/thinning; e.g., @(A as B, C as C)@+        -- brings @B@ and @C@ into scope.+        = ModuleRenaming [(ModuleName, ModuleName)]+        -- | The default renaming, bringing all exported modules+        -- into scope.+        | DefaultRenaming+        -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all+        -- exported modules into scope except the hidden ones.+        | HidingRenaming [ModuleName]+    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)++-- | The default renaming, if something is specified in @build-depends@+-- only.+defaultRenaming :: ModuleRenaming+defaultRenaming = DefaultRenaming++-- | Tests if its the default renaming; we can use a more compact syntax+-- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case.+isDefaultRenaming :: ModuleRenaming -> Bool+isDefaultRenaming DefaultRenaming = True+isDefaultRenaming _ = False++instance Binary ModuleRenaming where++-- NB: parentheses are mandatory, because later we may extend this syntax+-- to allow "hiding (A, B)" or other modifier words.+instance Text ModuleRenaming where+  disp DefaultRenaming = empty+  disp (HidingRenaming hides)+        = text "hiding" <+> parens (hsep (punctuate comma (map disp hides)))+  disp (ModuleRenaming rns)+        = parens . hsep $ punctuate comma (map dispEntry rns)+    where dispEntry (orig, new)+            | orig == new = disp orig+            | otherwise = disp orig <+> text "as" <+> disp new++  parse = do fmap ModuleRenaming parseRns+             <++ parseHidingRenaming+             <++ return DefaultRenaming+    where parseRns = do+             rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList+             Parse.skipSpaces+             return rns+          parseHidingRenaming = do+            _ <- Parse.string "hiding"+            Parse.skipSpaces+            hides <- Parse.between (Parse.char '(') (Parse.char ')')+                        (Parse.sepBy parse (Parse.char ',' >> Parse.skipSpaces))+            return (HidingRenaming hides)+          parseList =+            Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces)+          parseEntry :: Parse.ReadP r (ModuleName, ModuleName)+          parseEntry = do+            orig <- parse+            Parse.skipSpaces+            (do _ <- Parse.string "as"+                Parse.skipSpaces+                new <- parse+                Parse.skipSpaces+                return (orig, new)+             <+++                return (orig, orig))
+ cabal/Cabal/Distribution/Types/PackageDescription.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Types.PackageDescription+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This defines the data structure for the @.cabal@ file format. There are+-- several parts to this structure. It has top level info and then 'Library',+-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have+-- associated 'BuildInfo' data that's used to build the library, exe, test, or+-- benchmark.  To further complicate things there is both a 'PackageDescription'+-- and a 'GenericPackageDescription'. This distinction relates to cabal+-- configurations. When we initially read a @.cabal@ file we get a+-- 'GenericPackageDescription' which has all the conditional sections.+-- Before actually building a package we have to decide+-- on each conditional. Once we've done that we get a 'PackageDescription'.+-- It was done this way initially to avoid breaking too much stuff when the+-- feature was introduced. It could probably do with being rationalised at some+-- point to make it simpler.++module Distribution.Types.PackageDescription (+    PackageDescription(..),+    specVersion,+    descCabalVersion,+    emptyPackageDescription,+    hasPublicLib,+    hasLibs,+    allLibraries,+    withLib,+    hasExes,+    withExe,+    hasTests,+    withTest,+    hasBenchmarks,+    withBenchmark,+    hasForeignLibs,+    withForeignLib,+    allBuildInfo,+    enabledBuildInfos,+    updatePackageDescription,+    pkgComponents,+    pkgBuildableComponents,+    enabledComponents,+    lookupComponent,+    getComponent,+  ) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.Library+import Distribution.Types.TestSuite+import Distribution.Types.Executable+import Distribution.Types.Benchmark+import Distribution.Types.ForeignLib++import Distribution.Types.Component+import Distribution.Types.ComponentName+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.SetupBuildInfo+import Distribution.Types.BuildInfo+import Distribution.Types.BuildType+import Distribution.Types.SourceRepo+import Distribution.Types.HookedBuildInfo++import Distribution.Package+import Distribution.Version+import Distribution.License+import Distribution.Compiler++-- -----------------------------------------------------------------------------+-- The PackageDescription type++-- | This data type is the internal representation of the file @pkg.cabal@.+-- It contains two kinds of information about the package: information+-- which is needed for all packages, such as the package name and version, and+-- information which is needed for the simple build system only, such as+-- the compiler options and library name.+--+data PackageDescription+    =  PackageDescription {+        -- the following are required by all packages:+        package        :: PackageIdentifier,+        license        :: License,+        licenseFiles   :: [FilePath],+        copyright      :: String,+        maintainer     :: String,+        author         :: String,+        stability      :: String,+        testedWith     :: [(CompilerFlavor,VersionRange)],+        homepage       :: String,+        pkgUrl         :: String,+        bugReports     :: String,+        sourceRepos    :: [SourceRepo],+        synopsis       :: String, -- ^A one-line summary of this package+        description    :: String, -- ^A more verbose description of this package+        category       :: String,+        customFieldsPD :: [(String,String)], -- ^Custom fields starting+                                             -- with x-, stored in a+                                             -- simple assoc-list.++        -- | YOU PROBABLY DON'T WANT TO USE THIS FIELD. This field is+        -- special! Depending on how far along processing the+        -- PackageDescription we are, the contents of this field are+        -- either nonsense, or the collected dependencies of *all* the+        -- components in this package.  buildDepends is initialized by+        -- 'finalizePD' and 'flattenPackageDescription';+        -- prior to that, dependency info is stored in the 'CondTree'+        -- built around a 'GenericPackageDescription'.  When this+        -- resolution is done, dependency info is written to the inner+        -- 'BuildInfo' and this field.  This is all horrible, and #2066+        -- tracks progress to get rid of this field.+        buildDepends   :: [Dependency],+        -- | The version of the Cabal spec that this package description uses.+        -- For historical reasons this is specified with a version range but+        -- only ranges of the form @>= v@ make sense. We are in the process of+        -- transitioning to specifying just a single version, not a range.+        specVersionRaw :: Either Version VersionRange,+        buildType      :: Maybe BuildType,+        setupBuildInfo :: Maybe SetupBuildInfo,+        -- components+        library        :: Maybe Library,+        subLibraries   :: [Library],+        executables    :: [Executable],+        foreignLibs    :: [ForeignLib],+        testSuites     :: [TestSuite],+        benchmarks     :: [Benchmark],+        dataFiles      :: [FilePath],+        dataDir        :: FilePath,+        extraSrcFiles  :: [FilePath],+        extraTmpFiles  :: [FilePath],+        extraDocFiles  :: [FilePath]+    }+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary PackageDescription++instance Package PackageDescription where+  packageId = package++-- | The version of the Cabal spec that this package should be interpreted+-- against.+--+-- Historically we used a version range but we are switching to using a single+-- version. Currently we accept either. This function converts into a single+-- version by ignoring upper bounds in the version range.+--+specVersion :: PackageDescription -> Version+specVersion pkg = case specVersionRaw pkg of+  Left  version      -> version+  Right versionRange -> case asVersionIntervals versionRange of+                          []                            -> mkVersion [0]+                          ((LowerBound version _, _):_) -> version++-- | The range of versions of the Cabal tools that this package is intended to+-- work with.+--+-- This function is deprecated and should not be used for new purposes, only to+-- support old packages that rely on the old interpretation.+--+descCabalVersion :: PackageDescription -> VersionRange+descCabalVersion pkg = case specVersionRaw pkg of+  Left  version      -> orLaterVersion version+  Right versionRange -> versionRange+{-# DEPRECATED descCabalVersion "Use specVersion instead" #-}++emptyPackageDescription :: PackageDescription+emptyPackageDescription+    =  PackageDescription {+                      package      = PackageIdentifier (mkPackageName "")+                                                       nullVersion,+                      license      = UnspecifiedLicense,+                      licenseFiles = [],+                      specVersionRaw = Right anyVersion,+                      buildType    = Nothing,+                      copyright    = "",+                      maintainer   = "",+                      author       = "",+                      stability    = "",+                      testedWith   = [],+                      buildDepends = [],+                      homepage     = "",+                      pkgUrl       = "",+                      bugReports   = "",+                      sourceRepos  = [],+                      synopsis     = "",+                      description  = "",+                      category     = "",+                      customFieldsPD = [],+                      setupBuildInfo = Nothing,+                      library      = Nothing,+                      subLibraries = [],+                      foreignLibs  = [],+                      executables  = [],+                      testSuites   = [],+                      benchmarks   = [],+                      dataFiles    = [],+                      dataDir      = "",+                      extraSrcFiles = [],+                      extraTmpFiles = [],+                      extraDocFiles = []+                     }++-- ---------------------------------------------------------------------------+-- The Library type++-- | Does this package have a buildable PUBLIC library?+hasPublicLib :: PackageDescription -> Bool+hasPublicLib p =+    case library p of+        Just lib -> buildable (libBuildInfo lib)+        Nothing  -> False++-- | Does this package have any libraries?+hasLibs :: PackageDescription -> Bool+hasLibs p = any (buildable . libBuildInfo) (allLibraries p)++allLibraries :: PackageDescription -> [Library]+allLibraries p = maybeToList (library p) ++ subLibraries p++-- | If the package description has a buildable library section,+-- call the given function with the library build info as argument.+-- You probably want 'withLibLBI' if you have a 'LocalBuildInfo',+-- see the note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"+-- for more information.+withLib :: PackageDescription -> (Library -> IO ()) -> IO ()+withLib pkg_descr f =+   sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)]++-- ---------------------------------------------------------------------------+-- The Executable type++-- |does this package have any executables?+hasExes :: PackageDescription -> Bool+hasExes p = any (buildable . buildInfo) (executables p)++-- | Perform the action on each buildable 'Executable' in the package+-- description.  You probably want 'withExeLBI' if you have a+-- 'LocalBuildInfo', see the note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"+-- for more information.+withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()+withExe pkg_descr f =+  sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]++-- ---------------------------------------------------------------------------+-- The TestSuite type++-- | Does this package have any test suites?+hasTests :: PackageDescription -> Bool+hasTests = any (buildable . testBuildInfo) . testSuites++-- | Perform an action on each buildable 'TestSuite' in a package.+-- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"+-- for more information.++withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()+withTest pkg_descr f =+    sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ]++-- ---------------------------------------------------------------------------+-- The Benchmark type++-- | Does this package have any benchmarks?+hasBenchmarks :: PackageDescription -> Bool+hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks++-- | Perform an action on each buildable 'Benchmark' in a package.+-- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in+-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"+-- for more information.++withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()+withBenchmark pkg_descr f =+    sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)]++-- ---------------------------------------------------------------------------+-- The ForeignLib type++-- | Does this package have any foreign libraries?+hasForeignLibs :: PackageDescription -> Bool+hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p)++-- | Perform the action on each buildable 'ForeignLib' in the package+-- description.+withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO ()+withForeignLib pkg_descr f =+  sequence_ [ f flib+            | flib <- foreignLibs pkg_descr+            , buildable (foreignLibBuildInfo flib)+            ]++-- ---------------------------------------------------------------------------+-- The BuildInfo type++-- | The 'BuildInfo' for the library (if there is one and it's buildable), and+-- all buildable executables, test suites and benchmarks.  Useful for gathering+-- dependencies.+allBuildInfo :: PackageDescription -> [BuildInfo]+allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr+                              , let bi = libBuildInfo lib+                              , buildable bi ]+                      ++ [ bi | exe <- executables pkg_descr+                              , let bi = buildInfo exe+                              , buildable bi ]+                      ++ [ bi | tst <- testSuites pkg_descr+                              , let bi = testBuildInfo tst+                              , buildable bi ]+                      ++ [ bi | tst <- benchmarks pkg_descr+                              , let bi = benchmarkBuildInfo tst+                              , buildable bi ]+  --FIXME: many of the places where this is used, we actually want to look at+  --       unbuildable bits too, probably need separate functions++-- | Return all of the 'BuildInfo's of enabled components, i.e., all of+-- the ones that would be built if you run @./Setup build@.+enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo]+enabledBuildInfos pkg enabled =+    [ componentBuildInfo comp+    | comp <- enabledComponents pkg enabled ]+++-- ------------------------------------------------------------+-- * Utils+-- ------------------------------------------------------------++updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription+updatePackageDescription (mb_lib_bi, exe_bi) p+    = p{ executables = updateExecutables exe_bi    (executables p)+       , library     = updateLibrary     mb_lib_bi (library     p) }+    where+      updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library+      updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})+      updateLibrary Nothing   mb_lib     = mb_lib+      updateLibrary (Just _)  Nothing    = Nothing++      updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)]+        -> [Executable]                                       -- ^list of executables to update+        -> [Executable]                                       -- ^list with exeNames updated+      updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'++      updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo)+                       -> [Executable]                     -- ^list of executables to update+                       -> [Executable]                     -- ^list with exeName updated+      updateExecutable _                 []         = []+      updateExecutable exe_bi'@(name,bi) (exe:exes)+        | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes+        | otherwise           = exe : updateExecutable exe_bi' exes++-- -----------------------------------------------------------------------------+-- Source-representation of buildable components++-- | All the components in the package.+--+pkgComponents :: PackageDescription -> [Component]+pkgComponents pkg =+    [ CLib  lib | lib <- allLibraries pkg ]+ ++ [ CFLib flib | flib <- foreignLibs pkg ]+ ++ [ CExe  exe | exe <- executables pkg ]+ ++ [ CTest tst | tst <- testSuites  pkg ]+ ++ [ CBench bm | bm  <- benchmarks  pkg ]++-- | A list of all components in the package that are buildable,+-- i.e., were not marked with @buildable: False@.  This does NOT+-- indicate if we are actually going to build the component,+-- see 'enabledComponents' instead.+--+-- @since 2.0.0.0+--+pkgBuildableComponents :: PackageDescription -> [Component]+pkgBuildableComponents = filter componentBuildable . pkgComponents++-- | A list of all components in the package that are enabled.+--+-- @since 2.0.0.0+--+enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component]+enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg++lookupComponent :: PackageDescription -> ComponentName -> Maybe Component+lookupComponent pkg CLibName = fmap CLib (library pkg)+lookupComponent pkg (CSubLibName name) =+    fmap CLib $ find ((Just name ==) . libName) (subLibraries pkg)+lookupComponent pkg (CFLibName name) =+    fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg)+lookupComponent pkg (CExeName name) =+    fmap CExe $ find ((name ==) . exeName) (executables pkg)+lookupComponent pkg (CTestName name) =+    fmap CTest $ find ((name ==) . testName) (testSuites pkg)+lookupComponent pkg (CBenchName name) =+    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)++getComponent :: PackageDescription -> ComponentName -> Component+getComponent pkg cname =+    case lookupComponent pkg cname of+      Just cpnt -> cpnt+      Nothing   -> missingComponent+  where+    missingComponent =+      error $ "internal error: the package description contains no "+           ++ "component corresponding to " ++ show cname
+ cabal/Cabal/Distribution/Types/SetupBuildInfo.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.SetupBuildInfo (+    SetupBuildInfo(..)+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Package++-- ---------------------------------------------------------------------------+-- The SetupBuildInfo type++-- One can see this as a very cut-down version of BuildInfo below.+-- To keep things simple for tools that compile Setup.hs we limit the+-- options authors can specify to just Haskell package dependencies.++data SetupBuildInfo = SetupBuildInfo {+        setupDepends        :: [Dependency],+        defaultSetupDepends :: Bool+        -- ^ Is this a default 'custom-setup' section added by the cabal-install+        -- code (as opposed to user-provided)? This field is only used+        -- internally, and doesn't correspond to anything in the .cabal+        -- file. See #3199.+    }+    deriving (Generic, Show, Eq, Read, Typeable, Data)++instance Binary SetupBuildInfo++instance Monoid SetupBuildInfo where+  mempty  = SetupBuildInfo [] False+  mappend = (<>)++instance Semigroup SetupBuildInfo where+  a <> b = SetupBuildInfo (setupDepends a <> setupDepends b)+           (defaultSetupDepends a || defaultSetupDepends b)
+ cabal/Cabal/Distribution/Types/SourceRepo.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.SourceRepo (+    SourceRepo(..),+    RepoKind(..),+    RepoType(..),+    knownRepoTypes,+    emptySourceRepo,+    classifyRepoType,+    classifyRepoKind,+  ) where++import Prelude ()+import Distribution.Compat.Prelude++import qualified Distribution.Compat.ReadP as Parse+import Distribution.Text++import Text.PrettyPrint as Disp++-- ------------------------------------------------------------+-- * Source repos+-- ------------------------------------------------------------++-- | Information about the source revision control system for a package.+--+-- When specifying a repo it is useful to know the meaning or intention of the+-- information as doing so enables automation. There are two obvious common+-- purposes: one is to find the repo for the latest development version, the+-- other is to find the repo for this specific release. The 'ReopKind'+-- specifies which one we mean (or another custom one).+--+-- A package can specify one or the other kind or both. Most will specify just+-- a head repo but some may want to specify a repo to reconstruct the sources+-- for this package release.+--+-- The required information is the 'RepoType' which tells us if it's using+-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are+-- interpreted according to the repo type.+--+data SourceRepo = SourceRepo {+  -- | The kind of repo. This field is required.+  repoKind     :: RepoKind,++  -- | The type of the source repository system for this repo, eg 'Darcs' or+  -- 'Git'. This field is required.+  repoType     :: Maybe RepoType,++  -- | The location of the repository. For most 'RepoType's this is a URL.+  -- This field is required.+  repoLocation :: Maybe String,++  -- | 'CVS' can put multiple \"modules\" on one server and requires a+  -- module name in addition to the location to identify a particular repo.+  -- Logically this is part of the location but unfortunately has to be+  -- specified separately. This field is required for the 'CVS' 'RepoType' and+  -- should not be given otherwise.+  repoModule   :: Maybe String,++  -- | The name or identifier of the branch, if any. Many source control+  -- systems have the notion of multiple branches in a repo that exist in the+  -- same location. For example 'Git' and 'CVS' use this while systems like+  -- 'Darcs' use different locations for different branches. This field is+  -- optional but should be used if necessary to identify the sources,+  -- especially for the 'RepoThis' repo kind.+  repoBranch   :: Maybe String,++  -- | The tag identify a particular state of the repository. This should be+  -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.+  --+  repoTag      :: Maybe String,++  -- | Some repositories contain multiple projects in different subdirectories+  -- This field specifies the subdirectory where this packages sources can be+  -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted+  -- relative to the root of the repository. This field is optional. If not+  -- given the default is \".\" ie no subdirectory.+  repoSubdir   :: Maybe FilePath+}+  deriving (Eq, Generic, Read, Show, Typeable, Data)++emptySourceRepo :: RepoKind -> SourceRepo+emptySourceRepo kind = SourceRepo+    { repoKind     = kind+    , repoType     = Nothing+    , repoLocation = Nothing+    , repoModule   = Nothing+    , repoBranch   = Nothing+    , repoTag      = Nothing+    , repoSubdir   = Nothing+    }++instance Binary SourceRepo++-- | What this repo info is for, what it represents.+--+data RepoKind =+    -- | The repository for the \"head\" or development version of the project.+    -- This repo is where we should track the latest development activity or+    -- the usual repo people should get to contribute patches.+    RepoHead++    -- | The repository containing the sources for this exact package version+    -- or release. For this kind of repo a tag should be given to give enough+    -- information to re-create the exact sources.+  | RepoThis++  | RepoKindUnknown String+  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)++instance Binary RepoKind++-- | An enumeration of common source control systems. The fields used in the+-- 'SourceRepo' depend on the type of repo. The tools and methods used to+-- obtain and track the repo depend on the repo type.+--+data RepoType = Darcs | Git | SVN | CVS+              | Mercurial | GnuArch | Bazaar | Monotone+              | OtherRepoType String+  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)++instance Binary RepoType++knownRepoTypes :: [RepoType]+knownRepoTypes = [Darcs, Git, SVN, CVS+                 ,Mercurial, GnuArch, Bazaar, Monotone]++repoTypeAliases :: RepoType -> [String]+repoTypeAliases Bazaar    = ["bzr"]+repoTypeAliases Mercurial = ["hg"]+repoTypeAliases GnuArch   = ["arch"]+repoTypeAliases _         = []++instance Text RepoKind where+  disp RepoHead                = Disp.text "head"+  disp RepoThis                = Disp.text "this"+  disp (RepoKindUnknown other) = Disp.text other++  parse = fmap classifyRepoKind ident++classifyRepoKind :: String -> RepoKind+classifyRepoKind name = case lowercase name of+  "head" -> RepoHead+  "this" -> RepoThis+  _      -> RepoKindUnknown name++instance Text RepoType where+  disp (OtherRepoType other) = Disp.text other+  disp other                 = Disp.text (lowercase (show other))+  parse = fmap classifyRepoType ident++classifyRepoType :: String -> RepoType+classifyRepoType s =+  fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap+  where+    repoTypeMap = [ (name, repoType')+                  | repoType' <- knownRepoTypes+                  , name <- display repoType' : repoTypeAliases repoType' ]++ident :: Parse.ReadP r String+ident = Parse.munch1 (\c -> isAlphaNum c || c == '_' || c == '-')++lowercase :: String -> String+lowercase = map toLower+
+ cabal/Cabal/Distribution/Types/TargetInfo.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TypeFamilies #-}+module Distribution.Types.TargetInfo (+    TargetInfo(..)+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.Component++import Distribution.Package+import Distribution.Compat.Graph (IsNode(..))++-- | The 'TargetInfo' contains all the information necessary to build a+-- specific target (e.g., component/module/file) in a package.  In+-- principle, one can get the 'Component' from a+-- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more+-- convenient to have the component in hand.+data TargetInfo = TargetInfo {+        targetCLBI      :: ComponentLocalBuildInfo,+        targetComponent :: Component+        -- TODO: BuildTargets supporting parsing these is dumb,+        -- we don't have support for compiling single modules or+        -- file paths. Accommodating it now is premature+        -- generalization.  Figure it out later.+        -- targetSub       :: Maybe (Either ModuleName FilePath)+    }++instance IsNode TargetInfo where+    type Key TargetInfo = UnitId+    nodeKey       = nodeKey       . targetCLBI+    nodeNeighbors = nodeNeighbors . targetCLBI
+ cabal/Cabal/Distribution/Types/TestSuite.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}++module Distribution.Types.TestSuite (+    TestSuite(..),+    emptyTestSuite,+    testType,+    testModules,+    testModulesAutogen+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.BuildInfo+import Distribution.Types.TestType+import Distribution.Types.TestSuiteInterface++import Distribution.ModuleName+import Distribution.Package++-- | A \"test-suite\" stanza in a cabal file.+--+data TestSuite = TestSuite {+        testName      :: UnqualComponentName,+        testInterface :: TestSuiteInterface,+        testBuildInfo :: BuildInfo+    }+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary TestSuite++instance Monoid TestSuite where+    mempty = TestSuite {+        testName      = mempty,+        testInterface = mempty,+        testBuildInfo = mempty+    }+    mappend = (<>)++instance Semigroup TestSuite where+    a <> b = TestSuite {+        testName      = combine' testName,+        testInterface = combine  testInterface,+        testBuildInfo = combine  testBuildInfo+    }+        where combine  field = field a `mappend` field b+              combine' field = case ( unUnqualComponentName $ field a+                                    , unUnqualComponentName $ field b) of+                        ("", _) -> field b+                        (_, "") -> field a+                        (x, y) -> error $ "Ambiguous values for test field: '"+                            ++ x ++ "' and '" ++ y ++ "'"++emptyTestSuite :: TestSuite+emptyTestSuite = mempty+++testType :: TestSuite -> TestType+testType test = case testInterface test of+  TestSuiteExeV10 ver _         -> TestTypeExe ver+  TestSuiteLibV09 ver _         -> TestTypeLib ver+  TestSuiteUnsupported testtype -> testtype++-- | Get all the module names from a test suite.+testModules :: TestSuite -> [ModuleName]+testModules test = (case testInterface test of+                     TestSuiteLibV09 _ m -> [m]+                     _                   -> [])+                ++ otherModules (testBuildInfo test)++-- | Get all the auto generated module names from a test suite.+-- This are a subset of 'testModules'.+testModulesAutogen :: TestSuite -> [ModuleName]+testModulesAutogen test = autogenModules (testBuildInfo test)
+ cabal/Cabal/Distribution/Types/TestSuiteInterface.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.TestSuiteInterface (+    TestSuiteInterface(..),+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Types.TestType+import Distribution.ModuleName+import Distribution.Version++-- | The test suite interfaces that are currently defined. Each test suite must+-- specify which interface it supports.+--+-- More interfaces may be defined in future, either new revisions or totally+-- new interfaces.+--+data TestSuiteInterface =++     -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form+     -- of an executable. It returns a zero exit code for success, non-zero for+     -- failure. The stdout and stderr channels may be logged. It takes no+     -- command line parameters and nothing on stdin.+     --+     TestSuiteExeV10 Version FilePath++     -- | Test interface \"detailed-0.9\". The test-suite takes the form of a+     -- library containing a designated module that exports \"tests :: [Test]\".+     --+   | TestSuiteLibV09 Version ModuleName++     -- | A test suite that does not conform to one of the above interfaces for+     -- the given reason (e.g. unknown test type).+     --+   | TestSuiteUnsupported TestType+   deriving (Eq, Generic, Read, Show, Typeable, Data)++instance Binary TestSuiteInterface+++instance Monoid TestSuiteInterface where+    mempty  =  TestSuiteUnsupported (TestTypeUnknown mempty nullVersion)+    mappend = (<>)++instance Semigroup TestSuiteInterface where+    a <> (TestSuiteUnsupported _) = a+    _ <> b                        = b
+ cabal/Cabal/Distribution/Types/TestType.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.TestType (+    TestType(..),+    knownTestTypes,+) where++import Prelude ()+import Distribution.Compat.Prelude++import Distribution.Version+import Distribution.Text++import Text.PrettyPrint as Disp++-- | The \"test-type\" field in the test suite stanza.+--+data TestType = TestTypeExe Version     -- ^ \"type: exitcode-stdio-x.y\"+              | TestTypeLib Version     -- ^ \"type: detailed-x.y\"+              | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"+    deriving (Generic, Show, Read, Eq, Typeable, Data)++instance Binary TestType++knownTestTypes :: [TestType]+knownTestTypes = [ TestTypeExe (mkVersion [1,0])+                 , TestTypeLib (mkVersion [0,9]) ]++instance Text TestType where+  disp (TestTypeExe ver)          = text "exitcode-stdio-" <<>> disp ver+  disp (TestTypeLib ver)          = text "detailed-"       <<>> disp ver+  disp (TestTypeUnknown name ver) = text name <<>> char '-' <<>> disp ver++  parse = stdParse $ \ver name -> case name of+    "exitcode-stdio" -> TestTypeExe ver+    "detailed"       -> TestTypeLib ver+    _                -> TestTypeUnknown name ver
+ cabal/Cabal/Distribution/Utils/Base62.hs view
@@ -0,0 +1,22 @@++-- | Implementation of base-62 encoding, which we use when computing hashes+-- for fully instantiated unit ids.+module Distribution.Utils.Base62 (hashToBase62) where++import GHC.Fingerprint ( Fingerprint(..), fingerprintString )+import Numeric ( showIntAtBase )+import Data.Char ( chr )++-- | Hash a string using GHC's fingerprinting algorithm (a 128-bit+-- MD5 hash) and then encode the resulting hash in base 62.+hashToBase62 :: String -> String+hashToBase62 s = showFingerprint $ fingerprintString s+  where+    showIntAtBase62 x = showIntAtBase 62 representBase62 x ""+    representBase62 x+        | x < 10 = chr (48 + x)+        | x < 36 = chr (65 + x - 10)+        | x < 62 = chr (97 + x - 36)+        | otherwise = '@'+    showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b+
+ cabal/Cabal/Distribution/Utils/BinaryWithFingerprint.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Support for binary serialization with a fingerprint.+module Distribution.Utils.BinaryWithFingerprint (+    encodeWithFingerprint,+    decodeWithFingerprint,+    decodeWithFingerprintOrFailIO,+) where++#if MIN_VERSION_base(4,8,0)++import Distribution.Compat.Binary+import Data.ByteString.Lazy (ByteString)+import Control.Exception++import Data.Binary.Get+import Data.Binary.Put++import GHC.Generics+import GHC.Fingerprint+import Data.Typeable+import Control.Monad++-- | Private wrapper type so we can give 'Binary' instance for+-- 'Fingerprint'+newtype FP = FP Fingerprint++instance Binary FP where+    put (FP (Fingerprint a b)) = put a >> put b+    get = do+        a <- get+        b <- get+        return (FP (Fingerprint a b))++fingerprintRep :: forall a. Typeable (Rep a) => Proxy a -> Fingerprint+fingerprintRep _ = typeRepFingerprint (typeRep (Proxy :: Proxy (Rep a)))++-- | Encode a value, recording a fingerprint in the header.+--+-- The fingerprint is GHC's Typeable fingerprint associated with+-- the Generic Rep of a type: this fingerprint is better than+-- the fingerprint of the type itself, as it changes when the+-- representation changes (and thus the binary serialization format+-- changes.)+--+encodeWithFingerprint :: forall a. (Binary a, Typeable (Rep a)) => a -> ByteString+encodeWithFingerprint x = runPut $ do+    put (FP (fingerprintRep (Proxy :: Proxy a)))+    put x++-- | Decode a value, verifying the fingerprint in the header.+--+decodeWithFingerprint :: forall a. (Binary a, Typeable (Rep a)) => ByteString -> a+decodeWithFingerprint = runGet $ do+    FP fp <- get+    let expect_fp = fingerprintRep (Proxy :: Proxy a)+    when (expect_fp /= fp) $+        fail $ "Expected fingerprint " ++ show expect_fp +++               " but got " ++ show fp+    get++-- | Decode a value, forcing the decoded value to discover decoding errors+-- and report them.+--+decodeWithFingerprintOrFailIO :: (Binary a, Typeable (Rep a)) => ByteString -> IO (Either String a)+decodeWithFingerprintOrFailIO bs =+  catch (evaluate (decodeWithFingerprint bs) >>= return . Right)+  $ \(ErrorCall str) -> return $ Left str++#else++import Distribution.Compat.Binary+import Data.ByteString.Lazy (ByteString)++-- Dummy implementations that don't actually save fingerprints++encodeWithFingerprint :: Binary a => a -> ByteString+encodeWithFingerprint = encode++decodeWithFingerprint :: Binary a => ByteString -> a+decodeWithFingerprint = decode++decodeWithFingerprintOrFailIO :: Binary a => ByteString -> IO (Either String a)+decodeWithFingerprintOrFailIO = decodeOrFailIO++#endif
+ cabal/Cabal/Distribution/Utils/LogProgress.hs view
@@ -0,0 +1,41 @@+module Distribution.Utils.LogProgress (+    LogProgress,+    LogMsg(..),+    runLogProgress,+    warnProgress,+    infoProgress,+) where++import Distribution.Utils.Progress+import Distribution.Verbosity+import Distribution.Simple.Utils+import Text.PrettyPrint (Doc, (<+>), text, render)+import Control.Monad (when)++-- | The 'Progress' monad with specialized logging and+-- error messages.+type LogProgress a = Progress LogMsg Doc a++-- | A tracing message which will be output at some verbosity.+data LogMsg = LogMsg Verbosity Doc++-- | Run 'LogProgress', outputting traces according to 'Verbosity',+-- 'die' if there is an error.+runLogProgress :: Verbosity -> LogProgress a -> IO a+runLogProgress verbosity = foldProgress step_fn fail_fn return+  where+    step_fn :: LogMsg -> IO a -> IO a+    step_fn (LogMsg v doc) go = do+        when (verbosity >= v) $+            putStrLn (render doc)+        go+    fail_fn :: Doc -> IO a+    fail_fn doc = die (render doc)++-- | Output a warning trace message in 'LogProgress'.+warnProgress :: Doc -> LogProgress ()+warnProgress s  = stepProgress (LogMsg normal (text "Warning:" <+> s))++-- | Output an informational trace message in 'LogProgress'.+infoProgress :: Doc -> LogProgress ()+infoProgress s  = stepProgress (LogMsg verbose s)
+ cabal/Cabal/Distribution/Utils/MapAccum.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}+module Distribution.Utils.MapAccum (mapAccumM) where++import Distribution.Compat.Prelude+import Prelude ()++-- Like StateT but with return tuple swapped+newtype StateM s m a = StateM { runStateM :: s -> m (s, a) }++instance Functor m => Functor (StateM s m) where+    fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s)++instance+#if __GLASGOW_HASKELL__ < 709+    (Functor m, Monad m)+#else+    Monad m+#endif+    => Applicative (StateM s m) where+    pure x = StateM $ \s -> return (s, x)+    StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s+                                              (s'', x') <- x s'+                                              return (s'', f' x')++-- | Monadic variant of 'mapAccumL'.+mapAccumM ::+#if __GLASGOW_HASKELL__ < 709+    (Functor m, Monad m, Traversable t)+#else+    (Monad m, Traversable t)+#endif+          => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c)+mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s+
cabal/Cabal/Distribution/Utils/NubList.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} module Distribution.Utils.NubList     ( NubList    -- opaque     , toNubList  -- smart construtor@@ -10,8 +11,9 @@     , overNubListR     ) where -import Distribution.Compat.Semigroup as Semi-import Distribution.Compat.Binary+import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Simple.Utils  import qualified Text.Read as R@@ -19,7 +21,7 @@ -- | NubList : A de-duplicated list that maintains the original order. newtype NubList a =     NubList { fromNubList :: [a] }-    deriving Eq+    deriving (Eq, Typeable)  -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurence). Documentation for "Data.List.nub"@@ -50,7 +52,7 @@  instance Ord a => Monoid (NubList a) where     mempty = NubList []-    mappend = (Semi.<>)+    mappend = (<>)  instance Ord a => Semigroup (NubList a) where     (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys@@ -90,7 +92,7 @@  instance Ord a => Monoid (NubListR a) where   mempty = NubListR []-  mappend = (Semi.<>)+  mappend = (<>)  instance Ord a => Semigroup (NubListR a) where   (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys
+ cabal/Cabal/Distribution/Utils/Progress.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+-- Note: This module was copied from cabal-install.++-- | A progress monad, which we use to report failure and logging from+-- otherwise pure code.+module Distribution.Utils.Progress+    ( Progress+    , stepProgress+    , failProgress+    , foldProgress+    ) where++import Prelude ()+import Distribution.Compat.Prelude++import qualified Data.Monoid as Mon+++-- | A type to represent the unfolding of an expensive long running+-- calculation that may fail (or maybe not expensive, but complicated!)+-- We may get intermediate steps before the final+-- result which may be used to indicate progress and\/or logging messages.+--+-- TODO: Apply Codensity to avoid left-associativity problem.+-- See http://comonad.com/reader/2011/free-monads-for-less/ and+-- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/+--+data Progress step fail done = Step step (Progress step fail done)+                             | Fail fail+                             | Done done+  deriving (Functor)++-- | Emit a step and then continue.+--+stepProgress :: step -> Progress step fail ()+stepProgress step = Step step (Done ())++-- | Fail the computation.+failProgress :: fail -> Progress step fail done+failProgress err = Fail err++-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two+-- base cases, one for a final result and one for failure.+--+-- Eg to convert into a simple 'Either' result use:+--+-- > foldProgress (flip const) Left Right+--+foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)+             -> Progress step fail done -> a+foldProgress step err done = fold+  where fold (Step s p) = step s (fold p)+        fold (Fail f)   = err f+        fold (Done r)   = done r++instance Monad (Progress step fail) where+  return   = pure+  p >>= f  = foldProgress Step Fail f p++instance Applicative (Progress step fail) where+  pure a  = Done a+  p <*> x = foldProgress Step Fail (flip fmap x) p++instance Monoid fail => Alternative (Progress step fail) where+  empty   = Fail Mon.mempty+  p <|> q = foldProgress Step (const q) Done p
+ cabal/Cabal/Distribution/Utils/ShortText.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Utils.ShortText+    ( -- * 'ShortText' type+      ShortText+    , toShortText+    , fromShortText++      -- * internal utilities+    , decodeStringUtf8+    , encodeStringUtf8+    ) where++import Prelude ()+import Distribution.Compat.Prelude+import Distribution.Utils.String++import Data.String (IsString(..))++#if defined(MIN_VERSION_bytestring)+# if MIN_VERSION_bytestring(0,10,4)+# define HAVE_SHORTBYTESTRING 1+# endif+#endif++-- Hack for GHC bootstrapping+--+-- Currently (as of GHC 8.1), GHC bootstraps Cabal by building+-- binary and Cabal in one giant ghc --make command.  This+-- means no MIN_VERSION_binary macro is available.+--+-- We could try to cleverly figure something out in this case,+-- but there is a better plan: just use the unoptimized version+-- of the Binary instance.  We're not going to use it for anything+-- real in any case.+--+-- WARNING: Don't use MIN_VERSION_binary to smooth over a BC-break!+--+#ifndef MIN_VERSION_binary+#define MIN_VERSION_binary(x, y, z) 0+#endif++#if HAVE_SHORTBYTESTRING+import qualified Data.ByteString.Short as BS.Short+#endif++-- | Construct 'ShortText' from 'String'+toShortText :: String -> ShortText++-- | Convert 'ShortText' to 'String'+fromShortText :: ShortText -> String++-- | Compact representation of short 'Strings'+--+-- The data is stored internally as UTF8 in an+-- 'BS.Short.ShortByteString' when compiled against @bytestring >=+-- 0.10.4@, and otherwise the fallback is to use plain old non-compat+-- '[Char]'.+--+-- Note: This type is for internal uses (such as e.g. 'PackageName')+-- and shall not be exposed in Cabal's API+--+-- @since 2.0.0+#if HAVE_SHORTBYTESTRING+newtype ShortText = ST { unST :: BS.Short.ShortByteString }+                  deriving (Eq,Ord,Generic,Data,Typeable)++# if MIN_VERSION_binary(0,8,1)+instance Binary ShortText where+    put = put . unST+    get = fmap ST get+# else+instance Binary ShortText where+    put = put . BS.Short.fromShort . unST+    get = fmap (ST . BS.Short.toShort) get+# endif++toShortText = ST . BS.Short.pack . encodeStringUtf8++fromShortText = decodeStringUtf8 . BS.Short.unpack . unST+#else+newtype ShortText = ST { unST :: String }+                  deriving (Eq,Ord,Generic,Data,Typeable)++instance Binary ShortText where+    put = put . encodeStringUtf8 . unST+    get = fmap (ST . decodeStringUtf8) get++toShortText = ST++fromShortText = unST+#endif++instance NFData ShortText where+    rnf = rnf . unST++instance Show ShortText where+    show = show . fromShortText++instance Read ShortText where+    readsPrec p = map (first toShortText) . readsPrec p++instance Semigroup ShortText where+    ST a <> ST b = ST (mappend a b)++instance Monoid ShortText where+    mempty = ST mempty+    mappend = (<>)++instance IsString ShortText where+    fromString = toShortText
+ cabal/Cabal/Distribution/Utils/String.hs view
@@ -0,0 +1,85 @@+module Distribution.Utils.String+    ( -- * Encode to/from UTF8+      decodeStringUtf8+    , encodeStringUtf8+    ) where++import Data.Word+import Data.Bits+import Data.Char (chr,ord)++-- | Decode 'String' from UTF8-encoded octets.+--+-- Invalid data will be decoded as the replacement character (@U+FFFD@)+--+-- See also 'encodeStringUtf8'+decodeStringUtf8 :: [Word8] -> String+decodeStringUtf8 = go+  where+    go :: [Word8] -> String+    go []       = []+    go (c : cs)+      | c <= 0x7F = chr (fromIntegral c) : go cs+      | c <= 0xBF = replacementChar : go cs+      | c <= 0xDF = twoBytes c cs+      | c <= 0xEF = moreBytes 3 0x800     cs (fromIntegral $ c .&. 0xF)+      | c <= 0xF7 = moreBytes 4 0x10000   cs (fromIntegral $ c .&. 0x7)+      | c <= 0xFB = moreBytes 5 0x200000  cs (fromIntegral $ c .&. 0x3)+      | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1)+      | otherwise   = replacementChar : go cs++    twoBytes :: Word8 -> [Word8] -> String+    twoBytes c0 (c1:cs')+      | c1 .&. 0xC0 == 0x80+      = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6)+             .|. fromIntegral (c1 .&. 0x3F)+         in if d >= 0x80+               then  chr d                : go cs'+               else  replacementChar      : go cs'+    twoBytes _ cs' = replacementChar      : go cs'++    moreBytes :: Int -> Int -> [Word8] -> Int -> [Char]+    moreBytes 1 overlong cs' acc+      | overlong <= acc && acc <= 0x10FFFF+     && (acc < 0xD800 || 0xDFFF < acc)+     && (acc < 0xFFFE || 0xFFFF < acc)+      = chr acc : go cs'++      | otherwise+      = replacementChar : go cs'++    moreBytes byteCount overlong (cn:cs') acc+      | cn .&. 0xC0 == 0x80+      = moreBytes (byteCount-1) overlong cs'+          ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)++    moreBytes _ _ cs' _+      = replacementChar : go cs'++    replacementChar = '\xfffd'+++-- | Encode 'String' to a list of UTF8-encoded octets+--+-- See also 'decodeUtf8'+encodeStringUtf8 :: String -> [Word8]+encodeStringUtf8 []        = []+encodeStringUtf8 (c:cs)+  | c <= '\x07F' = w8+                 : encodeStringUtf8 cs+  | c <= '\x7FF' = (0xC0 .|.  w8ShiftR  6          )+                 : (0x80 .|. (w8          .&. 0x3F))+                 : encodeStringUtf8 cs+  | c <= '\xFFFF'= (0xE0 .|.  w8ShiftR 12          )+                 : (0x80 .|. (w8ShiftR  6 .&. 0x3F))+                 : (0x80 .|. (w8          .&. 0x3F))+                 : encodeStringUtf8 cs+  | otherwise    = (0xf0 .|.  w8ShiftR 18          )+                 : (0x80 .|. (w8ShiftR 12 .&. 0x3F))+                 : (0x80 .|. (w8ShiftR  6 .&. 0x3F))+                 : (0x80 .|. (w8          .&. 0x3F))+                 : encodeStringUtf8 cs+  where+    w8 = fromIntegral (ord c) :: Word8+    w8ShiftR :: Int -> Word8+    w8ShiftR = fromIntegral . shiftR (ord c)
+ cabal/Cabal/Distribution/Utils/UnionFind.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE NondecreasingIndentation #-}+-- | A simple mutable union-find data structure.+--+-- It is used in a unification algorithm for backpack mix-in linking.+--+-- This implementation is based off of the one in \"The Essence of ML Type+-- Inference\". (N.B. the union-find package is also based off of this.)+--+module Distribution.Utils.UnionFind (+    Point,+    fresh,+    find,+    union,+    equivalent,+) where++import Data.STRef+import Control.Monad+import Control.Monad.ST++-- | A variable which can be unified; alternately, this can be thought+-- of as an equivalence class with a distinguished representative.+newtype Point s a = Point (STRef s (Link s a))+    deriving (Eq)++-- | Mutable write to a 'Point'+writePoint :: Point s a -> Link s a -> ST s ()+writePoint (Point v) = writeSTRef v++-- | Read the current value of 'Point'.+readPoint :: Point s a -> ST s (Link s a)+readPoint (Point v) = readSTRef v++-- | The internal data structure for a 'Point', which either records+-- the representative element of an equivalence class, or a link to+-- the 'Point' that actually stores the representative type.+data Link s a+    -- NB: it is too bad we can't say STRef Int#; the weights remain boxed+    = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)+    | Link {-# UNPACK #-} !(Point s a)++-- | Create a fresh equivalence class with one element.+fresh :: a -> ST s (Point s a)+fresh desc = do+    weight <- newSTRef 1+    descriptor <- newSTRef desc+    Point `fmap` newSTRef (Info weight descriptor)++-- | Flatten any chains of links, returning a 'Point'+-- which points directly to the canonical representation.+repr :: Point s a -> ST s (Point s a)+repr point = readPoint point >>= \r ->+  case r of+    Link point' -> do+        point'' <- repr point'+        when (point'' /= point') $ do+            writePoint point =<< readPoint point'+        return point''+    Info _ _ -> return point++-- | Return the canonical element of an equivalence+-- class 'Point'.+find :: Point s a -> ST s a+find point =+    -- Optimize length 0 and 1 case at expense of+    -- general case+    readPoint point >>= \r ->+      case r of+        Info _ d_ref -> readSTRef d_ref+        Link point' -> readPoint point' >>= \r' ->+          case r' of+            Info _ d_ref -> readSTRef d_ref+            Link _ -> repr point >>= find++-- | Unify two equivalence classes, so that they share+-- a canonical element. Keeps the descriptor of point2.+union :: Point s a -> Point s a -> ST s ()+union refpoint1 refpoint2 = do+    point1 <- repr refpoint1+    point2 <- repr refpoint2+    when (point1 /= point2) $ do+    l1 <- readPoint point1+    l2 <- readPoint point2+    case (l1, l2) of+        (Info wref1 dref1, Info wref2 dref2) -> do+            weight1 <- readSTRef wref1+            weight2 <- readSTRef wref2+            -- Should be able to optimize the == case separately+            if weight1 >= weight2+                then do+                    writePoint point2 (Link point1)+                    -- The weight calculation here seems a bit dodgy+                    writeSTRef wref1 (weight1 + weight2)+                    writeSTRef dref1 =<< readSTRef dref2+                else do+                    writePoint point1 (Link point2)+                    writeSTRef wref2 (weight1 + weight2)+        _ -> error "UnionFind.union: repr invariant broken"++-- | Test if two points are in the same equivalence class.+equivalent :: Point s a -> Point s a -> ST s Bool+equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2)
cabal/Cabal/Distribution/Verbosity.hs view
@@ -9,9 +9,17 @@ -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable ----- A simple 'Verbosity' type with associated utilities. There are 4 standard--- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This--- is used for deciding what logging messages to print.+-- A 'Verbosity' type with associated utilities.+--+-- There are 4 standard verbosity levels from 'silent', 'normal',+-- 'verbose' up to 'deafening'. This is used for deciding what logging+-- messages to print.+--+-- Verbosity also is equipped with some internal settings which can be+-- used to control at a fine granularity the verbosity of specific+-- settings (e.g., so that you can trace only particular things you+-- are interested in.)  It's important to note that the instances+-- for 'Verbosity' assume that this does not exist.  -- Verbosity for Cabal functions. @@ -21,64 +29,132 @@   silent, normal, verbose, deafening,   moreVerbose, lessVerbose,   intToVerbosity, flagToVerbosity,-  showForCabal, showForGHC+  showForCabal, showForGHC,++  -- * Call stacks+  verboseCallSite, verboseCallStack,+  isVerboseCallSite, isVerboseCallStack,++  -- * line-wrapping+  verboseNoWrap, isVerboseNoWrap,  ) where -import Distribution.Compat.Binary+import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.ReadE+import Distribution.Compat.ReadP  import Data.List (elemIndex)-import GHC.Generics+import Data.Set (Set)+import qualified Data.Set as Set -data Verbosity = Silent | Normal | Verbose | Deafening-    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)+data Verbosity = Verbosity {+    vLevel :: VerbosityLevel,+    vFlags :: Set VerbosityFlag+  } deriving (Generic) +mkVerbosity :: VerbosityLevel -> Verbosity+mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty }++instance Show Verbosity where+    showsPrec n = showsPrec n . vLevel++instance Read Verbosity where+    readsPrec n s = map (\(x,y) -> (mkVerbosity x,y)) (readsPrec n s)++instance Eq Verbosity where+    x == y = vLevel x == vLevel y++instance Ord Verbosity where+    compare x y = compare (vLevel x) (vLevel y)++instance Enum Verbosity where+    toEnum = mkVerbosity . toEnum+    fromEnum = fromEnum . vLevel++instance Bounded Verbosity where+    minBound = mkVerbosity minBound+    maxBound = mkVerbosity maxBound+ instance Binary Verbosity +data VerbosityLevel = Silent | Normal | Verbose | Deafening+    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)++instance Binary VerbosityLevel+ -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity-silent = Silent+silent = mkVerbosity Silent  -- Print stuff we want to see by default normal :: Verbosity-normal = Normal+normal = mkVerbosity Normal  -- Be more verbose about what's going on verbose :: Verbosity-verbose = Verbose+verbose = mkVerbosity Verbose  -- Not only are we verbose ourselves (perhaps even noisier than when -- being "verbose"), but we tell everything we run to be verbose too deafening :: Verbosity-deafening = Deafening+deafening = mkVerbosity Deafening  moreVerbose :: Verbosity -> Verbosity-moreVerbose Silent    = Silent    --silent should stay silent-moreVerbose Normal    = Verbose-moreVerbose Verbose   = Deafening-moreVerbose Deafening = Deafening+moreVerbose v =+    case vLevel v of+        Silent    -> v -- silent should stay silent+        Normal    -> v { vLevel = Verbose }+        Verbose   -> v { vLevel = Deafening }+        Deafening -> v  lessVerbose :: Verbosity -> Verbosity-lessVerbose Deafening = Deafening-lessVerbose Verbose   = Normal-lessVerbose Normal    = Silent-lessVerbose Silent    = Silent+lessVerbose v =+    case vLevel v of+        Deafening -> v -- deafening stays deafening+        Verbose   -> v { vLevel = Normal }+        Normal    -> v { vLevel = Silent }+        Silent    -> v  intToVerbosity :: Int -> Maybe Verbosity-intToVerbosity 0 = Just Silent-intToVerbosity 1 = Just Normal-intToVerbosity 2 = Just Verbose-intToVerbosity 3 = Just Deafening+intToVerbosity 0 = Just (mkVerbosity Silent)+intToVerbosity 1 = Just (mkVerbosity Normal)+intToVerbosity 2 = Just (mkVerbosity Verbose)+intToVerbosity 3 = Just (mkVerbosity Deafening) intToVerbosity _ = Nothing +parseVerbosity :: ReadP r (Either Int Verbosity)+parseVerbosity = parseIntVerbosity <++ parseStringVerbosity+  where+    parseIntVerbosity = fmap Left (readS_to_P reads)+    parseStringVerbosity = fmap Right $ do+        level <- parseVerbosityLevel+        _ <- skipSpaces+        extras <- sepBy parseExtra skipSpaces+        return (foldr (.) id extras (mkVerbosity level))+    parseVerbosityLevel = choice+        [ string "silent" >> return Silent+        , string "normal" >> return Normal+        , string "verbose" >> return Verbose+        , string "debug"  >> return Deafening+        , string "deafening" >> return Deafening+        ]+    parseExtra = char '+' >> choice+        [ string "callsite"  >> return verboseCallSite+        , string "callstack" >> return verboseCallStack+        , string "nowrap"    >> return verboseNoWrap+        ]+ flagToVerbosity :: ReadE Verbosity flagToVerbosity = ReadE $ \s ->-   case reads s of-       [(i, "")] ->+   case readP_to_S (parseVerbosity >>= \r -> eof >> return r) s of+       [(Left i, "")] ->            case intToVerbosity i of                Just v -> Right v                Nothing -> Left ("Bad verbosity: " ++ show i ++                                      ". Valid values are 0..3")+       [(Right v, "")] -> Right v        _ -> Left ("Can't parse verbosity " ++ s)  showForCabal, showForGHC :: Verbosity -> String@@ -88,3 +164,35 @@ showForGHC   v = maybe (error "unknown verbosity") show $     elemIndex v [silent,normal,__,verbose,deafening]         where __ = silent -- this will be always ignored by elemIndex++data VerbosityFlag+    = VCallStack+    | VCallSite+    | VNoWrap+    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)++instance Binary VerbosityFlag++-- | Turn on verbose call-site printing when we log.+verboseCallSite :: Verbosity -> Verbosity+verboseCallSite v = v { vFlags = Set.insert VCallSite (vFlags v) }++-- | Turn on verbose call-stack printing when we log.+verboseCallStack :: Verbosity -> Verbosity+verboseCallStack v = v { vFlags = Set.insert VCallStack (vFlags v) }++-- | Test if we should output call sites when we log.+isVerboseCallSite :: Verbosity -> Bool+isVerboseCallSite = (Set.member VCallSite) . vFlags++-- | Test if we should output call stacks when we log.+isVerboseCallStack :: Verbosity -> Bool+isVerboseCallStack = (Set.member VCallStack) . vFlags++-- | Disable line-wrapping for log messages.+verboseNoWrap :: Verbosity -> Verbosity+verboseNoWrap v = v { vFlags = Set.insert VNoWrap (vFlags v) }++-- | Test if line-wrapping is disabled for log messages.+isVerboseNoWrap :: Verbosity -> Bool+isVerboseNoWrap = (Set.member VNoWrap) . vFlags
cabal/Cabal/Distribution/Version.hs view
@@ -1,31 +1,6 @@-{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-#if __GLASGOW_HASKELL__ < 707-{-# LANGUAGE StandaloneDeriving #-}-#endif --- Hack approach to support bootstrapping.--- When MIN_VERSION_binary macro is available, use it. But it's not available--- during bootstrapping (or anyone else building Setup.hs directly). If the--- builder specifies -DMIN_VERSION_binary_0_8_0=1 or =0 then we respect that.--- Otherwise we pick a default based on GHC version: assume binary <0.8 when--- GHC < 8.0, and binary >=0.8 when GHC >= 8.0.-#ifdef MIN_VERSION_binary-#define MIN_VERSION_binary_0_8_0 MIN_VERSION_binary(0,8,0)-#else-#ifndef MIN_VERSION_binary_0_8_0-#if __GLASGOW_HASKELL__ >= 800-#define MIN_VERSION_binary_0_8_0 1-#else-#define MIN_VERSION_binary_0_8_0 0-#endif-#endif-#endif--#if !MIN_VERSION_binary_0_8_0-{-# OPTIONS_GHC -fno-warn-orphans #-}-#endif- ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Version@@ -42,7 +17,12 @@  module Distribution.Version (   -- * Package versions-  Version(..),+  Version,+  mkVersion,+  mkVersion',+  versionNumbers,+  nullVersion,+  alterVersion,    -- * Version ranges   VersionRange(..),@@ -53,8 +33,10 @@   laterVersion, earlierVersion,   orLaterVersion, orEarlierVersion,   unionVersionRanges, intersectVersionRanges,+  differenceVersionRanges,   invertVersionRange,   withinVersion,+  majorBoundVersion,   betweenVersionsInclusive,    -- ** Inspection@@ -70,6 +52,7 @@    -- ** Modification   removeUpperBound,+  removeLowerBound,    -- * Version intervals view   asVersionIntervals,@@ -96,22 +79,211 @@   ) where -import Distribution.Compat.Binary ( Binary(..) )-import Data.Data        ( Data )-import Data.Typeable    ( Typeable )-import Data.Version     ( Version(..) )-import GHC.Generics     ( Generic )+import Prelude ()+import Distribution.Compat.Prelude+import qualified Data.Version as Base+import Data.Bits (shiftL, shiftR, (.|.), (.&.))  import Distribution.Text import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP hiding (get)  import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>), (<+>))-import qualified Data.Char as Char (isDigit)+import Text.PrettyPrint ((<+>)) import Control.Exception (assert) +import qualified Text.Read as Read+ -- -----------------------------------------------------------------------------+-- Versions++-- | A 'Version' represents the version of a software entity.+--+-- Instances of 'Eq' and 'Ord' are provided, which gives exact+-- equality and lexicographic ordering of the version number+-- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.).+--+-- This type is opaque and distinct from the 'Base.Version' type in+-- "Data.Version" since @Cabal-2.0@. The difference extends to the+-- 'Binary' instance using a different (and more compact) encoding.+--+-- @since 2.0+data Version = PV0 {-# UNPACK #-} !Word64+             | PV1 !Int [Int]+             -- NOTE: If a version fits into the packed Word64+             -- representation (i.e. at most four version components+             -- which all fall into the [0..0xfffe] range), then PV0+             -- MUST be used. This is essential for the 'Eq' instance+             -- to work.+             deriving (Data,Eq,Generic,Typeable)++instance Ord Version where+    compare (PV0 x)    (PV0 y)    = compare x y+    compare (PV1 x xs) (PV1 y ys) = case compare x y of+        EQ -> compare xs ys+        c  -> c+    compare (PV0 w)    (PV1 y ys) = case compare x y of+        EQ -> compare [x2,x3,x4] ys+        c  -> c+      where+        x  = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1+        x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1+        x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1+        x4 = fromIntegral               (w .&. 0xffff) - 1+    compare (PV1 x xs) (PV0 w)    = case compare x y of+        EQ -> compare xs [y2,y3,y4]+        c  -> c+      where+        y  = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1+        y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1+        y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1+        y4 = fromIntegral               (w .&. 0xffff) - 1++instance Show Version where+    showsPrec d v = showParen (d > 10)+        $ showString "mkVersion "+        . showsPrec 11 (versionNumbers v)++instance Read Version where+    readPrec = Read.parens $ do+        Read.Ident "mkVersion" <- Read.lexP+        v <- Read.step Read.readPrec+        return (mkVersion v)++instance Binary Version++instance NFData Version where+    rnf (PV0 _) = ()+    rnf (PV1 _ ns) = rnf ns++instance Text Version where+  disp ver+    = Disp.hcat (Disp.punctuate (Disp.char '.')+                                (map Disp.int $ versionNumbers ver))++  parse = do+      branch <- Parse.sepBy1 parseNat (Parse.char '.')+                -- allow but ignore tags:+      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)+      return (mkVersion branch)+    where+      parseNat = read `fmap` Parse.munch1 isDigit++-- | Construct 'Version' from list of version number components.+--+-- For instance, @mkVersion [3,2,1]@ constructs a 'Version'+-- representing the version @3.2.1@.+--+-- All version components must be non-negative. @mkVersion []@+-- currently represents the special /null/ version; see also 'nullVersion'.+--+-- @since 2.0+mkVersion :: [Int] -> Version+-- TODO: add validity check; disallow 'mkVersion []' (we have+-- 'nullVersion' for that)+mkVersion []                    = nullVersion+mkVersion (v1:[])+  | inWord16VerRep1 v1          = PV0 (mkWord64VerRep1 v1)+  | otherwise                   = PV1 v1 []+  where+    inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1))+    mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0++mkVersion (v1:vs@(v2:[]))+  | inWord16VerRep2 v1 v2       = PV0 (mkWord64VerRep2 v1 v2)+  | otherwise                   = PV1 v1 vs+  where+    inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1)+                                  .|. x2 .|. (x2+1))+    mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0++mkVersion (v1:vs@(v2:v3:[]))+  | inWord16VerRep3 v1 v2 v3    = PV0 (mkWord64VerRep3 v1 v2 v3)+  | otherwise                   = PV1 v1 vs+  where+    inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1)+                                     .|. x2 .|. (x2+1)+                                     .|. x3 .|. (x3+1))+    mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0++mkVersion (v1:vs@(v2:v3:v4:[]))+  | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4)+  | otherwise                   = PV1 v1 vs+  where+    inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1)+                                        .|. x2 .|. (x2+1)+                                        .|. x3 .|. (x3+1)+                                        .|. x4 .|. (x4+1))+    mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1)++mkVersion (v1:vs)               = PV1 v1 vs+++{-# INLINE mkWord64VerRep #-}+mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64+mkWord64VerRep v1 v2 v3 v4 =+      (fromIntegral v1 `shiftL` 48)+  .|. (fromIntegral v2 `shiftL` 32)+  .|. (fromIntegral v3 `shiftL` 16)+  .|.  fromIntegral v4++{-# INLINE inWord16 #-}+inWord16 :: Int -> Bool+inWord16 x = (fromIntegral x :: Word) <= 0xffff++-- | Variant of 'Version' which converts a "Data.Version" 'Version'+-- into Cabal's 'Version' type.+--+-- @since 2.0+mkVersion' :: Base.Version -> Version+mkVersion' = mkVersion . Base.versionBranch++-- | Unpack 'Version' into list of version number components.+--+-- This is the inverse to 'mkVersion', so the following holds:+--+-- > (versionNumbers . mkVersion) vs == vs+--+-- @since 2.0+versionNumbers :: Version -> [Int]+versionNumbers (PV1 n ns) = n:ns+versionNumbers (PV0 w)+  | v1 < 0    = []+  | v2 < 0    = [v1]+  | v3 < 0    = [v1,v2]+  | v4 < 0    = [v1,v2,v3]+  | otherwise = [v1,v2,v3,v4]+  where+    v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1+    v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1+    v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1+    v4 = fromIntegral (w .&. 0xffff) - 1+++-- | Constant representing the special /null/ 'Version'+--+-- The 'nullVersion' compares (via 'Ord') as less than every proper+-- 'Version' value.+--+-- @since 2.0+nullVersion :: Version+-- TODO: at some point, 'mkVersion' may disallow creating /null/+-- 'Version's+nullVersion = PV0 0++-- | Apply function to list of version number components+--+-- > alterVersion f == mkVersion . f . versionNumbers+--+-- @since 2.0+alterVersion :: ([Int] -> [Int]) -> Version -> Version+alterVersion f = mkVersion . f . versionNumbers++-- internal helper+validVersion :: Version -> Bool+validVersion v = v /= nullVersion && all (>=0) (versionNumbers v)++-- ----------------------------------------------------------------------------- -- Version ranges  -- Todo: maybe move this to Distribution.Package.Version?@@ -123,6 +295,7 @@   | LaterVersion           Version -- > version  (NB. not >=)   | EarlierVersion         Version -- < version   | WildcardVersion        Version -- == ver.*   (same as >= ver && < ver+1)+  | MajorBoundVersion      Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1)   | UnionVersionRanges     VersionRange VersionRange   | IntersectVersionRanges VersionRange VersionRange   | VersionRangeParens     VersionRange -- just '(exp)' parentheses syntax@@ -130,23 +303,7 @@  instance Binary VersionRange -#if __GLASGOW_HASKELL__ < 707--- starting with ghc-7.7/base-4.7 this instance is provided in "Data.Data"-deriving instance Data Version-#endif--#if !(MIN_VERSION_binary_0_8_0)--- Deriving this instance from Generic gives trouble on GHC 7.2 because the--- Generic instance has to be standalone-derived. So, we hand-roll our own.--- We can't use a generic Binary instance on later versions because we must--- maintain compatibility between compiler versions.-instance Binary Version where-    get = do-        br <- get-        tags <- get-        return $ Version br tags-    put (Version br tags) = put br >> put tags-#endif+instance NFData VersionRange where rnf = genericRnf  {-# DeprecateD AnyVersion     "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}@@ -180,7 +337,7 @@ -- noVersion :: VersionRange noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v)-  where v = Version [1] []+  where v = mkVersion [1]  -- | The version range @== v@ --@@ -240,6 +397,16 @@ intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges +-- | The difference of two version ranges+--+-- >   withinRange v' (differenceVersionRanges vr1 vr2)+-- > = withinRange v' vr1 && not (withinRange v' vr2)+--+-- @since 1.24.1.0+differenceVersionRanges :: VersionRange -> VersionRange -> VersionRange+differenceVersionRanges vr1 vr2 =+    intersectVersionRanges vr1 (invertVersionRange vr2)+ -- | The inverse of a version range -- -- >   withinRange v' (invertVersionRange vr)@@ -262,8 +429,17 @@ withinVersion :: Version -> VersionRange withinVersion = WildcardVersion --- | The version range @>= v1 && <= v2@.+-- | The version range @^>= v@. --+-- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ is the same as+-- @>= 1.2.3.4 && < 1.3@.+--+-- Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@.+--+-- @since 2.0@+majorBoundVersion :: Version -> VersionRange+majorBoundVersion = MajorBoundVersion+ -- In practice this is not very useful because we normally use inclusive lower -- bounds and exclusive upper bounds. --@@ -288,6 +464,18 @@     relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]     relaxLastInterval' (i:is)  = i : relaxLastInterval' is +-- | Given a version range, remove the lowest lower bound.+-- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to+-- @(>= 0 && < 3) || (>= 4 && < 5)@.+removeLowerBound :: VersionRange -> VersionRange+removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals+  where+    relaxHeadInterval (VersionIntervals intervals) =+      VersionIntervals (relaxHeadInterval' intervals)++    relaxHeadInterval' []         = []+    relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is+ -- | Fold over the basic syntactic structure of a 'VersionRange'. -- -- This provides a syntactic view of the expression defining the version range.@@ -310,6 +498,7 @@     fold (LaterVersion v)               = later v     fold (EarlierVersion v)             = earlier v     fold (WildcardVersion v)            = fold (wildcard v)+    fold (MajorBoundVersion v)          = fold (majorBound v)     fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)     fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)     fold (VersionRangeParens v)         = fold v@@ -318,6 +507,10 @@                    (orLaterVersion v)                    (earlierVersion (wildcardUpperBound v)) +    majorBound v = intersectVersionRanges+                     (orLaterVersion v)+                     (earlierVersion (majorUpperBound v))+ -- | An extended variant of 'foldVersionRange' that also provides a view of the -- expression in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== -- v.*\"@ is presented explicitly rather than in terms of the other basic@@ -334,12 +527,18 @@                                                -- inclusive lower bound and the                                                -- exclusive upper bounds of the                                                -- range defined by the wildcard.+                  -> (Version -> Version -> a) -- ^ @\"^>= v\"@ major upper bound+                                               -- The function is passed the+                                               -- inclusive lower bound and the+                                               -- exclusive major upper bounds+                                               -- of the range defined by this+                                               -- operator.                   -> (a -> a -> a)             -- ^ @\"_ || _\"@ union                   -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection                   -> (a -> a)                  -- ^ @\"(_)\"@ parentheses                   -> VersionRange -> a foldVersionRange' anyv this later earlier orLater orEarlier-                  wildcard union intersect parens = fold+                  wildcard major union intersect parens = fold   where     fold AnyVersion                     = anyv     fold (ThisVersion v)                = this v@@ -356,6 +555,7 @@                              (ThisVersion    v')) | v==v' = orEarlier v      fold (WildcardVersion v)            = wildcard v (wildcardUpperBound v)+    fold (MajorBoundVersion v)          = major v (majorUpperBound v)     fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)     fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)     fold (VersionRangeParens v)         = parens (fold v)@@ -368,9 +568,9 @@ withinRange :: Version -> VersionRange -> Bool withinRange v = foldVersionRange                    True-                   (\v'  -> versionBranch v == versionBranch v')-                   (\v'  -> versionBranch v >  versionBranch v')-                   (\v'  -> versionBranch v <  versionBranch v')+                   (\v'  -> v == v')+                   (\v'  -> v >  v')+                   (\v'  -> v <  v')                    (||)                    (&&) @@ -467,16 +667,25 @@ --  wildcardUpperBound :: Version -> Version-wildcardUpperBound (Version lowerBound ts) = Version upperBound ts-  where-    upperBound = init lowerBound ++ [last lowerBound + 1]+wildcardUpperBound = alterVersion $+    \lowerBound -> init lowerBound ++ [last lowerBound + 1]  isWildcardRange :: Version -> Version -> Bool-isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2+isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2)   where check (n:[]) (m:[]) | n+1 == m = True         check (n:ns) (m:ms) | n   == m = check ns ms         check _      _                 = False +-- | Compute next greater major version to be used as upper bound+--+-- Example: @0.4.1@ produces the version @0.5@ which then can be used+-- to construct a range @>= 0.4.1 && < 0.5@+majorUpperBound :: Version -> Version+majorUpperBound = alterVersion $ \numbers -> case numbers of+    []        -> [0,1] -- should not happen+    [m1]      -> [m1,1] -- e.g. version '1'+    (m1:m2:_) -> [m1,m2+1]+ ------------------ -- Intervals view --@@ -507,11 +716,10 @@ data Bound      = ExclusiveBound | InclusiveBound          deriving (Eq, Show)  minLowerBound :: LowerBound-minLowerBound = LowerBound (Version [0] []) InclusiveBound+minLowerBound = LowerBound (mkVersion [0]) InclusiveBound  isVersion0 :: Version -> Bool-isVersion0 (Version [0] _) = True-isVersion0 _               = False+isVersion0 = (== mkVersion [0])  instance Ord LowerBound where   LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of@@ -553,10 +761,6 @@   | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals)   | otherwise                              = Nothing -validVersion :: Version -> Bool-validVersion (Version [] _) = False-validVersion (Version vs _) = all (>=0) vs- validInterval :: (LowerBound, UpperBound) -> Bool validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i   where@@ -762,7 +966,7 @@       invertBound InclusiveBound = ExclusiveBound        noLowerBound :: LowerBound-      noLowerBound = LowerBound (Version [0] []) InclusiveBound+      noLowerBound = LowerBound (mkVersion [0]) InclusiveBound  ------------------------------- -- Parsing and pretty printing@@ -772,21 +976,23 @@   disp = fst        . foldVersionRange'                         -- precedence:            (         Disp.text "-any"                           , 0 :: Int)-           (\v   -> (Disp.text "==" <> disp v                   , 0))-           (\v   -> (Disp.char '>'  <> disp v                   , 0))-           (\v   -> (Disp.char '<'  <> disp v                   , 0))-           (\v   -> (Disp.text ">=" <> disp v                   , 0))-           (\v   -> (Disp.text "<=" <> disp v                   , 0))-           (\v _ -> (Disp.text "==" <> dispWild v               , 0))+           (\v   -> (Disp.text "==" <<>> disp v                   , 0))+           (\v   -> (Disp.char '>'  <<>> disp v                   , 0))+           (\v   -> (Disp.char '<'  <<>> disp v                   , 0))+           (\v   -> (Disp.text ">=" <<>> disp v                   , 0))+           (\v   -> (Disp.text "<=" <<>> disp v                   , 0))+           (\v _ -> (Disp.text "==" <<>> dispWild v               , 0))+           (\v _ -> (Disp.text "^>=" <<>> disp v                  , 0))            (\(r1, p1) (r2, p2) ->              (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))            (\(r1, p1) (r2, p2) ->              (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))            (\(r, _)   -> (Disp.parens r, 0)) -    where dispWild (Version b _) =-               Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))-            <> Disp.text ".*"+    where dispWild ver =+               Disp.hcat (Disp.punctuate (Disp.char '.')+                                         (map Disp.int $ versionNumbers ver))+            <<>> Disp.text ".*"           punct p p' | p < p'    = Disp.parens                      | otherwise = id @@ -823,7 +1029,7 @@           branch <- Parse.sepBy1 digits (Parse.char '.')           _ <- Parse.char '.'           _ <- Parse.char '*'-          return (WildcardVersion (Version branch []))+          return (WildcardVersion (mkVersion branch))          parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces)                                  (Parse.char ')' >> Parse.skipSpaces)@@ -832,17 +1038,18 @@                                      return (VersionRangeParens a))          digits = do-          first <- Parse.satisfy Char.isDigit-          if first == '0'+          firstDigit <- Parse.satisfy isDigit+          if firstDigit == '0'             then return 0-            else do rest <- Parse.munch Char.isDigit-                    return (read (first : rest))+            else do rest <- Parse.munch isDigit+                    return (read (firstDigit : rest)) -- TODO: eradicateNoParse          parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse         rangeOps = [ ("<",  EarlierVersion),                      ("<=", orEarlierVersion),                      (">",  LaterVersion),                      (">=", orLaterVersion),+                     ("^>=", MajorBoundVersion),                      ("==", ThisVersion) ]  -- | Does the version range have an upper bound?
cabal/Cabal/LICENSE view
@@ -1,8 +1,5 @@-Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren,-                         Bjorn Bringert, Krasimir Angelov,-                         Malcolm Wallace, Ross Patterson, Ian Lynagh,-                         Duncan Coutts, Thomas Schilling,-                         Johan Tibell, Mikhail Glushenkov+Copyright (c) 2003-2016, Cabal Development Team.+See the AUTHORS file for the full list of copyright holders. All rights reserved.  Redistribution and use in source and binary forms, with or without
cabal/Cabal/Language/Haskell/Extension.hs view
@@ -15,23 +15,23 @@ module Language.Haskell.Extension (         Language(..),         knownLanguages,+        classifyLanguage,          Extension(..),         KnownExtension(..),         knownExtensions,-        deprecatedExtensions+        deprecatedExtensions,+        classifyExtension,   ) where +import Prelude ()+import Distribution.Compat.Prelude+ import Distribution.Text import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.Binary  import qualified Text.PrettyPrint as Disp-import qualified Data.Char as Char (isAlphaNum) import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))-import Data.Data (Data)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)  -- ------------------------------------------------------------ -- * Language@@ -66,7 +66,7 @@   disp other                   = Disp.text (show other)    parse = do-    lang <- Parse.munch1 Char.isAlphaNum+    lang <- Parse.munch1 isAlphaNum     return (classifyLanguage lang)  classifyLanguage :: String -> Language@@ -417,7 +417,7 @@   -- | Allow default instantiation of polymorphic types in more   -- situations.   ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/interactive-evaluation.html#extended-default-rules>+  -- * <http://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html#type-defaulting-in-ghci>   | ExtendedDefaultRules    -- | Enable unboxed tuples.@@ -766,6 +766,10 @@   -- | Allows use of the @#label@ syntax.   | OverloadedLabels +  -- | Allow functional dependency annotations on type families to declare them+  -- as injective.+  | TypeFamilyDependencies+   deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data)  instance Binary KnownExtension@@ -796,14 +800,14 @@   disp (DisableExtension ke)    = Disp.text ("No" ++ show ke)    parse = do-    extension <- Parse.munch1 Char.isAlphaNum+    extension <- Parse.munch1 isAlphaNum     return (classifyExtension extension)  instance Text KnownExtension where   disp ke = Disp.text (show ke)    parse = do-    extension <- Parse.munch1 Char.isAlphaNum+    extension <- Parse.munch1 isAlphaNum     case classifyKnownExtension extension of         Just ke ->             return ke
cabal/Cabal/changelog view
@@ -2,9 +2,14 @@  1.25.x.x (current development version) 	* Dropped support for versions of GHC earlier than 6.12 (#3111).+	* GHC compatibility window for the Cabal library has been extended+	  to five years (#3838). 	* Convenience/internal libraries are now supported (#269). 	  An internal library is declared using the stanza "library-	  'libname'".+	  'libname'".  Packages which use internal libraries can+	  result in multiple registrations; thus '--gen-pkg-config'+	  can now output a directory of registration scripts rather than+	  a single file. 	* Backwards incompatible change to preprocessor interface: 	  the function in 'PPSuffixHandler' now takes an additional 	  'ComponentLocalBuildInfo' specifying the build information@@ -16,16 +21,103 @@ 	  only the macros for the library, and is not generated if a 	  package has no library; to find the macros for an executable 	  named 'foobar', look in 'dist/build/foobar/autogen/cabal_macros.h'.+	  Similarly, if you used 'autogenModulesDir' you should now+	  use 'autogenComponentModulesDir', which now requires a+	  'ComponentLocalBuildInfo' argument as well in order to+	  disambiguate which component the autogenerated files are for.+	* Backwards incompatible change to 'Component': 'TestSuite' and+	  'Benchmark' no longer have 'testEnabled' and+	  'benchmarkEnabled'.  If you used+	  'enabledTests' or 'enabledBenchmarks', please instead use+	  'enabledTestLBIs' and 'enabledBenchLBIs'+	  (you will need a 'LocalBuildInfo' for these functions.)+	  Additionally, the semantics of 'withTest' and 'withBench'+	  have changed: they now iterate over all buildable+	  such components, regardless of whether or not they have+	  been enabled; if you only want enabled components,+	  use 'withTestLBI' and 'withBenchLBI'.+	  'finalizePackageDescription' is deprecated:+	  its replacement 'finalizePD' now takes an extra argument+	  'ComponentRequestedSpec' which specifies what components+	  are to be enabled: use this instead of modifying the+	  'Component' in a 'GenericPackageDescription'.  (As+	  it's not possible now, 'finalizePackageDescription'+	  will assume tests/benchmarks are disabled.)+	  If you only need to test if a component is buildable+	  (i.e., it is marked buildable in the Cabal file)+	  use the new function 'componentBuildable'.+	* Backwards incompatible change to 'PackageName' (#3896):+	  'PackageName' is now opaque; conversion to/from 'String' now works+	  via (old) 'unPackageName' and (new) 'mkPackageName' functions.+	* Backwards incompatible change to 'ComponentId' (#3917):+	  'ComponentId' is now opaque; conversion to/from 'String' now works+	  via 'unComponentId' and 'mkComponentId' functions.+	* Backwards incompatible change to 'AbiHash' (#3921):+	  'AbiHash' is now opaque; conversion to/from 'String' now works+	  via 'unAbiHash' and 'mkAbiHash' functions.+	* Backwards incompatible change to 'FlagName' (#4062):+	  'FlagName' is now opaque; conversion to/from 'String' now works+	  via 'unFlagName' and 'mkFlagName' functions.+	* Backwards incompatible change to 'Version' (#3905):+	  Version is now opaque; conversion to/from '[Int]' now works+	  via 'versionNumbers' and 'mkVersion' functions.+	* Add support for `--allow-older` (dual to `--allow-newer`) (#3466)+	* Improved an error message for process output decoding errors+	(#3408).+	* 'getComponentLocalBuildInfo', 'withComponentsInBuildOrder'+	  and 'componentsInBuildOrder' are deprecated in favor of a+	  new interface in "Distribution.Types.LocalBuildInfo".+	* New 'autogen-modules' field. Modules that are built automatically at+	  setup, like Paths_PACKAGENAME or others created with a build-type+	  custom, appear on 'other-modules' for the Library, Executable,+	  Test-Suite or Benchmark stanzas or also on 'exposed-modules' for+	  libraries but are not really on the package when distributed. This+	  makes commands like sdist fail because the file is not found, so with+	  this new field modules that appear there are treated the same way as+	  Paths_PACKAGENAME was and there is no need to create complex build+	  hooks. Just add the module names on 'other-modules' and+	  'exposed-modules' as always and on the new 'autogen-modules' besides.+	(#3656).+	* New './Setup configure' flag '--cabal-file', allowing multiple+	.cabal files in a single directory (#3553). Primarily intended for+	internal use.+	* Macros in 'cabal_macros.h' are now ifndef'd, so that they+	don't cause an error if the macro is already defined. (#3041)+	* './Setup configure' now accepts a single argument specifying+	  the component to be configured.  The semantics of this mode+	  of operation are described in+	  <https://github.com/ghc-proposals/ghc-proposals/pull/4>+	* Internal 'build-tools' dependencies are now added to PATH+	  upon invocation of GHC, so that they can be conveniently+	  used via `-pgmF`. (#1541)+	* Add support for new caret-style version range operator `^>=` (#3705)+	* Verbosity `-v` now takes an extended format which allows+	  specifying exactly what you want to be logged.  The format is+	  "[silent|normal|verbose|debug] flags", where flags is a space+	  separated list of flags. At the moment, only the flags+	  +callsite and +callstack are supported; these report the+	  call site/stack of a logging output respectively (these+	  are only supported if Cabal is built with GHC 8.0/7.10.2+	  or greater, respectively).+	* New `Distribution.Utils.ShortText.ShortText` type for representing+	  short text strings compactly (#3898)+	* Cabal no longer supports using a version bound to disambiguate+	  between an internal and external package (#4020).  This should+	  not affect many people, as this mode of use already did not+	  work with the dependency solver.+	* Support for "foreign libraries" (#2540), which are Haskell+	  libraries intended to be used by foreign languages like C.+	  Foreign libraries only work with GHC 7.8 and later.  1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016 	* Support GHC 8. 	* Deal with extra C sources from preprocessors (#238). 	* Include cabal_macros.h when running c2hs (#2600). 	* Don't recompile C sources unless needed (#2601).-	* Read 'builddir' option from 'CABAL_BUILDDIR' environment variable+	* Read 'builddir' option from 'CABAL_BUILDDIR' environment variable. 	* Add '--profiling-detail=$level' flag with a default for libraries 	  and executables of 'exported-functions' and 'toplevel-functions'-	  respetively (GHC's '-fprof-auto-{exported,top}' flags) (#193).+	  respectively (GHC's '-fprof-auto-{exported,top}' flags) (#193). 	* New 'custom-setup' stanza to specify setup deps. Setup is also built 	  with the cabal_macros.h style macros, for conditional compilation. 	* Support Haddock response files (#2746).@@ -44,6 +136,11 @@ 	as an argument to './Setup configure' (#3158). 	* Macros 'VERSION_$pkgname' and 'MIN_VERSION_$pkgname' are now 	also generated for the current package. (#3235).+	* Backpack is supported!  Two new fields supported in Cabal+	files: signatures and mixins; and a new flag+	to setup scripts, '--instantiate-with'.  See+	https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst+	for more details.  1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015 	* Support GHC 7.10.
− cabal/Cabal/doc/Cabal.css 
@@ -1,49 +0,0 @@-body {-  max-width: 18cm;-}--div {-  font-family: sans-serif;-  color: black;-  background: white-}--h1, h2, h3, h4, h5, h6, p.title { color: #005A9C }--h1 { font:            170% sans-serif }-h2 { font:            140% sans-serif }-h3 { font:            120% sans-serif }-h4 { font: bold       100% sans-serif }-h5 { font: italic     100% sans-serif }-h6 { font: small-caps 100% sans-serif }--pre {-  font-family: monospace;-  border-width: 1px;-  border-style: solid;-  padding: 0.3em-}--pre.screen         { color: #006400 }-pre.programlisting { color: maroon }--div.example {-  margin: 1ex 0em;-  border: solid #412e25 1px;-  padding: 0ex 0.4em-}--div.example, div.example-contents {-  background-color: #fffcf5-}--a:link    { color:      #0000C8 }-a:hover   { background: #FFFFA8 }-a:active  { color:      #D00000 }-a:visited { color:      #680098 }--h1 a:link, h2 a:link, h3 a:link, h4 a:link, h5 a:link, h6 a:link,-h1 a:visited, h2 a:visited, h3 a:visited, h4 a:visited, h5 a:visited, h6 a:visited {-  color: #005A9C;-  text-decoration: none-}
+ cabal/Cabal/doc/README.md view
@@ -0,0 +1,122 @@+Cabal documentation+===================++### Where to read it+These docs will be built and deployed whenever a release is made,+and can be read at: https://www.haskell.org/cabal/users-guide/++In addition, the docs are taken directly from git and hosted at:+http://cabal.readthedocs.io/+++### How to build it++* `> pip install sphinx`+* `> sphinx-build doc html`+* if you are missing dependencies, install them with pip as needed+¯\\\_(ツ)_/¯+* Python on Mac OS X dislikes `LC_CTYPE=UTF-8`, unset the env var in+terminal preferences and instead set `LC_ALL=en_US.UTF-8` or something++### Caveats, for newcomers to RST from MD+RST does not allow you to skip section levels when nesting, like MD+does.+So, you cannot have++```+	Section heading+	===============++	Some unimportant block+	""""""""""""""""""""""+```++  instead you need to observe order and either promote your block:++```+    Section heading+    ===============++    Some not quite so important block+    ---------------------------------+```++  or introduce more subsections:++```+    Section heading+    ===============++    Subsection+    ----------++    Subsubsection+    ^^^^^^^^^^^^^++    Some unimportant block+    """"""""""""""""""""""+```++* RST simply parses a file and interpretes headings to indicate the+  start of a new block,+  * at the level implied by the header's *adornment*, if the adornment was+  previously encountered in this file,+  * at one level deeper than the previous block, otherwise.++  This means that a lot of confusion can arise when people use+  different adornments to signify the same depth in different files.++  To eliminate this confusion, please stick to the adornment order+  recommended by the Sphinx team:++```+    ####+    Part+    ####++    *******+    Chapter+    *******++    Section+    =======++    Subsection+    ----------++    Subsubsection+    ^^^^^^^^^^^^^++    Paragraph+    """""""""+```++* The Read-The-Docs stylesheet does not support multiple top-level+  sections in a file that is linked to from the top-most TOC (in+  `index.rst`). It will mess up the sidebar.+  E.g. you cannot link to a `cabal.rst` with sections "Introduction",+  "Using Cabal", "Epilogue" from `index.rst`.++  One solution is to have a single section, e.g. "All About Cabal", in+  `cabal.rst` and make the other blocks subsections of that.++  Another solution is to link via an indirection, e.g. create+  `all-about-cabal.rst`, where you include `cabal.rst` using  the+  `.. toctree::` command and then link to `all-about-cabal.rst` from+  `index.rst`.+  This will effectively "push down" all blocks by one layer and solve+  the problem without having to change `cabal.rst`.+++* We use [`extlinks`](http://www.sphinx-doc.org/en/stable/ext/extlinks.html)+  to shorten links to commonly referred resources (wiki, issue trackers).++  E.g. you can use the more convenient short syntax++        :issue:`123`++  which is expanded into a hyperlink++        `#123 <https://github.com/haskell/cabal/issues/123>`__++  See `conf.py` for list of currently defined link shorteners.
+ cabal/Cabal/doc/_templates/layout.html view
@@ -0,0 +1,8 @@+{% extends "!layout.html" %}++{% block menu %}+  {{ super() }}+  <a href="cabal-projectindex.html">Reference</a>+  <a href="genindex.html">Index</a>+{% endblock %}+
+ cabal/Cabal/doc/bugs-and-stability.rst view
@@ -0,0 +1,6 @@+Reporting Bugs and Stability of Cabal Interfaces+================================================++.. toctree::+   misc+
+ cabal/Cabal/doc/cabaldomain.py view
@@ -0,0 +1,885 @@+# -*- coding: utf-8 -*-+'''+Sphinx domain for documenting all things cabal++The main reason to use this instead of adding object types to std domain+is the ability to generate nice 'Reference' page and also provide some meta+data for objects described with directives described here.++Most directives have at least following optional arguments++`:since: 1.23`+    version of Cabal in which feature was added.++`:deprecated: 1.23`+`:deprecated:`+    Feature was deprecatead, and optionally since which version.++`:synopsis: Short desc`+    Text used as short description on reference page.+++Added directives++.. rst:directive:: .. cabal::cfg-section++   Describes a package.cabal section, such as library or exectuble.++   All following `pkg-field` directives will add section name+   to their fields name for disambiguating duplicates.++   You can reset the section disambguation with with `.. pkg-section:: None`.++.. rst::role:: pkg-section++   References section added by `.. pkg-section`++.. rst:directive:: .. cabal::pkg-field++   Describes a package.cabal field.++   Can have a :default: field. Will group on reference page under pkg-section+   if set and parent header otherwise.++.. rst::role:: pkg-field++   References field added by `.. pkg-field`, fields can be disambiguated+   with section name `:pkg-field:`section:field`.+++.. rst:directive:: .. cabal:cfg-section::++   Same as `.. cabal::pkg-section` but does not produce any visible output+   currently unused.++.. rst:directive:: .. cabal:cfg-field::++   Describes a project.cabal field.++   Can have multiple arguments, if arguments start with '-' then it is treated+   as a cabal flag.++   Can have a :default: field. Will group on reference page under pkg-section+   if set and parent header otherwise.++.. rst::role:: cfg-field++   References field added by `.. cfg-field`.++.. rst::role:: cfg-flag++   References flag added by `.. cfg-field`.+++All roles can be supplied with title as in standard sphinx references::++   :pkg-field:`Build dependencies<build-depends>`+++To be done:++- Directives for describing executables, their subcommands and flags.++  These should act in a way similar to `.. std::option` directive, but with+  extra meta. And should also end up in reference.++  At least setup and 'new-build` subcommands should get special directvies++- Improve rendering of flags in `.. cfg-field::` directive. It should be+  possible without copy-pasting code from sphinx.directives.ObjectDescription+  by examining result of ObjectDescription.run and inserting flags into+  desc_content node.++  Alternatively Or `.. flags::` sub-directive can be added which will be aware+  of parent `.. cfg-field` directive.++- With same ObjectDescription.run trick as above, render since and deprecated+  info same way as standard object fields, and use fancy rendering only on+  references page.++- Add 'since_version` config value to sphinx env and use it to decide if+  version meta info should be rendered on reference page and thus reduce some+  clutter.+  Can also be used to generate 'Whats new' reference page++'''+++import re++from docutils import nodes+from docutils.parsers.rst import Directive, directives, roles++import pygments.lexer as lexer+import pygments.token as token++from distutils.version import StrictVersion++from sphinx import addnodes+from sphinx.directives import ObjectDescription+from sphinx.domains import ObjType, Domain, Index+from sphinx.domains.std import StandardDomain+from sphinx.locale import l_, _+from sphinx.roles import XRefRole+from sphinx.util.docfields import Field, DocFieldTransformer+from sphinx.util.nodes import make_refnode++def parse_deprecated(txt):+    if txt is None:+        return True+    try:+        return StrictVersion(txt)+    except ValueError:+        return True++def parse_flag(env, sig, signode):+    import re+    names = []+    for i, flag in enumerate(sig.split(',')):+        flag = flag.strip()+        sep = '='+        parts = flag.split('=')+        if len(parts) == 1:+            sep=' '+            parts = flag.split()+        if len(parts) == 0: continue++        name = parts[0]+        names.append(name)+        sig = sep + ' '.join(parts[1:])+        sig = re.sub(ur'<([-a-zA-Z ]+)>', ur'⟨\1⟩', sig)+        if i > 0:+            signode += addnodes.desc_name(', ', ', ')+        signode += addnodes.desc_name(name, name)+        if len(sig) > 0:+            signode += addnodes.desc_addname(sig, sig)++    return names[0]+++class Meta(object):+    '''+    Meta data associated with object+    '''+    def __init__(self,+                 since=None,+                 deprecated=None,+                 synopsis=None,+                 title=None,+                 section=None,+                 index=0):+        self.since = since+        self.deprecated = deprecated+        self.synopsis = synopsis+        self.title = title+        self.section = section+        self.index = index+++def find_section_title(parent):+    '''+    Find current section id and title if possible+    '''+    while parent is not None:+        if isinstance(parent, nodes.section):+            break+        parent = parent.parent++    if parent is None:+        return None++    section_id = parent['ids'][0]+    section_name = parent['names'][0]++    for kid in parent:+        if isinstance(kid, nodes.title):+            return kid.astext(), section_id++    print section_name, section_id+    return section_name, section_id+++class CabalSection(Directive):+    """+    Marks section to which following objects belong, used to disambiguate+    references to fields and flags which can have similar names++    Does not generate any output besides anchor.+    """+    has_content = False+    required_arguments = 1+    optional_arguments = 0+    final_argument_whitespace = True+    option_spec = {+        'name': lambda x: x,+        'deprecated': parse_deprecated,+        'since' : StrictVersion,+        'synopsis' : lambda x:x,+    }+    section_key = 'cabal:pkg-section'+    target_prefix = 'pkg-section-'+    indextemplate = ''+    indextype = 'pair'++    def get_index_entry(self, name):+        return self.indextemplate % name++    def run(self):+        env = self.state.document.settings.env+        section = self.arguments[0].strip()++        if ':' in self.name:+            self.domain, self.objtype = self.name.split(':', 1)+        else:+            self.domain, self.objtype = '', self.name++        if section == 'None':+            env.ref_context.pop(self.section_key, None)+            return []++        env.ref_context[self.section_key] = section+        targetname = self.target_prefix + section+        node = nodes.target('', '', ids=[targetname])+        self.state.document.note_explicit_target(node)++        indexentry = self.get_index_entry(section)++        inode = addnodes.index(+            entries = [+                (self.indextype, indexentry, targetname, '', None)])++        # find title of parent section node+        title = find_section_title(self.state.parent)++        data_key = CabalDomain.types[self.objtype]++        # find how many sections in this document were added+        num = env.domaindata['cabal']['index-num'].get(env.docname, 0)+        env.domaindata['cabal']['index-num'][env.docname] = num + 1++        meta = Meta(since=self.options.get('since'),+                    deprecated=self.options.get('deprecated'),+                    synopsis=self.options.get('synopsis'),+                    index = num,+                    title = title)++        store = env.domaindata['cabal'][data_key]+        if not section in store:+            store[section] = env.docname, targetname, meta++        return [inode, node]+++class CabalObject(ObjectDescription):+    option_spec = {+        'noindex'   : directives.flag,+        'deprecated': parse_deprecated,+        'since'     : StrictVersion,+        'synopsis'  : lambda x:x+    }++    # node attribute marking which section field belongs to+    section_key = ''+    # template for index, it is passed a field name as argument+    # used by default deg_index_entry method+    indextemplate = ''++    def get_meta(self):+        '''+        Collect meta data for fields++        Reads optional arguments passed to directive and also+        tries to find current section title and adds it as section+        '''+        env = self.state.document.settings.env+        # find title of current section, will group references page by it+        num = env.domaindata['cabal']['index-num'].get(env.docname, 0)+        env.domaindata['cabal']['index-num'][env.docname] = num + 1++        title = find_section_title(self.state.parent)+        return Meta(since=self.options.get('since'),+                    deprecated=self.options.get('deprecated'),+                    title=title,+                    index = num,+                    synopsis=self.options.get('synopsis'))++    def get_env_key(self, env, name):+        '''+        Should return a key used to reference this field and key in domain+        data to store this object+        '''+        section = self.env.ref_context.get(self.section_key)+        store = CabalDomain.types[self.objtype]+        return (section, name), store++    def get_index_entry(self, env, name):+        '''+        Should return index entry and achor++        By default uses indextemplate attribute to generate name and+        index entry by joining directive name, section and field name+        '''+        section = self.env.ref_context.get(self.section_key)++        if section is not None:+            parts = (self.objtype, section, name)+            indexentry = self.indextemplate % (section + ':' + name)+        else:+            parts = (self.objtype, name)+            indexentry = self.indextemplate % name++        targetname = '-'.join(parts)+        return indexentry, targetname+++    def add_target_and_index(self, name, sig, signode):+        '''+        As in sphinx.directive.ObjectDescription++        By default adds 'pair' index as returned by get_index_entry and+        stores object data into domain data store as returned by get_env_data+        '''+        env = self.state.document.settings.env++        indexentry, targetname = self.get_index_entry(self, name)++        signode['ids'].append(targetname)+        self.state.document.note_explicit_target(signode)++        inode = addnodes.index(+            entries=[('pair', indexentry, targetname, '', None)])+        signode.insert(0, inode)++        key, store = self.get_env_key(env, name)+        env.domaindata['cabal'][store][key] = env.docname, targetname, self.cabal_meta++    def run(self):+        self.cabal_meta = self.get_meta()+        result = super(CabalObject, self).run()++        if self.cabal_meta.since is not None \+           or self.cabal_meta.deprecated is not None:++            #find content part of description+            for item in result:+                if isinstance(item, addnodes.desc):+                    desc = item+                    break+            else:+                return result++            for item in desc:+                if isinstance(item, addnodes.desc_content):+                    contents = item+                    break+            else:+                return result++            # find exsting field list and add to it+            # or create new one+            for item in contents:+                if isinstance(item, nodes.field_list):+                    field_list = item+                    break+            else:+                field_list = nodes.field_list('')+                contents.insert(0, field_list)+++            if self.cabal_meta.since is not None:+                #docutils horror+                field = nodes.field('')+                field_name = nodes.field_name('Since', 'Since')+                since = 'Cabal ' + str(self.cabal_meta.since)+                field_body = nodes.field_body(since, nodes.paragraph(since, since))+                field += field_name+                field += field_body+                field_list.insert(0, field)++            if self.cabal_meta.deprecated is not None:+                field = nodes.field('')+                field_name = nodes.field_name('Deprecated', 'Deprecated')+                if isinstance(self.cabal_meta.deprecated, StrictVersion):+                    since = 'Cabal ' + str(self.cabal_meta.deprecated)+                else:+                    since = ''++                field_body = nodes.field_body(since, nodes.paragraph(since, since))+                field += field_name+                field += field_body+                field_list.insert(0, field)++        return result++class CabalPackageSection(CabalObject):+    """+    Cabal section in package.cabal file+    """+    section_key = 'cabal:pkg-section'+    indextemplate = '%s; package.cabal section'++    def handle_signature(self, sig, signode):+        '''+        As in sphinx.directives.ObjectDescription++        By default make an object description from name and adding+        either deprecated or since as annotation.+        '''+        env = self.state.document.settings.env++        sig = sig.strip()+        parts = sig.split(' ',1)+        name = parts[0]+        signode += addnodes.desc_name(name, name)+        signode += addnodes.desc_addname(' ', ' ')+        if len(parts) > 1:+            rest = parts[1].strip()+            signode += addnodes.desc_annotation(rest, rest)++        return name++    def get_env_key(self, env, name):+        store = CabalDomain.types[self.objtype]+        return name, store++    def run(self):+        env = self.state.document.settings.env+        section = self.arguments[0].strip().split(' ',1)[0]+        if section == 'None':+            env.ref_context.pop('cabal:pkg-section', None)+            return []+        env.ref_context['cabal:pkg-section'] = section+        return super(CabalPackageSection, self).run()+++class CabalField(CabalObject):+    '''+    Base for fields in *.cabal files+    '''+    option_spec = {+        'noindex'   : directives.flag,+        'deprecated': parse_deprecated,+        'since'     : StrictVersion,+        'synopsis'  : lambda x:x+    }++    doc_field_types = [+        Field('default', label='Default value', names=['default'], has_arg=False)+    ]++    def handle_signature(self, sig, signode):+        '''+        As in sphinx.directives.ObjectDescription++        By default make an object description from name and adding+        either deprecated or since as annotation.+        '''+        env = self.state.document.settings.env++        sig = sig.strip()+        parts = sig.split(':',1)+        name = parts[0]+        signode += addnodes.desc_name(name, name)+        signode += addnodes.desc_addname(': ', ': ')++        if len(parts) > 1:+            rest = parts[1].strip()+            signode += addnodes.desc_annotation(rest, rest)++        return name++class CabalPackageField(CabalField):+    '''+    Describes section in package.cabal file+    '''+    section_key = 'cabal:pkg-section'+    indextemplate = '%s; package.cabal field'++class CabalFieldXRef(XRefRole):+    '''+    Cross ref node for all kinds of fields++    Gets section_key entry from context and stores it on node, so it can+    later be used by CabalDomain.resolve_xref to find target for reference to+    this+    '''+    section_key = 'cabal:pkg-section'+    def process_link(self, env, refnode, has_explicit_title, title, target):+        parts = target.split(':',1)+        if len(parts) == 2:+            section, target = parts+            section = section.strip()+            target = target.strip()+            refnode[self.section_key] = section+        else:+            refnode[self.section_key] = env.ref_context.get(self.section_key)++        return title, target++#+# Directives for config files.+#++class CabalPackageFieldXRef(CabalFieldXRef):+    '''+    Role referencing project.cabal section+    '''+    section_key = 'cabal:pkg-section'++class CabalConfigSection(CabalSection):+    """+    Marks section in package.cabal file+    """+    indextemplate = '%s; project.cabal section'+    section_key = 'cabal:cfg-section'+    target_prefix = 'cfg-section-'++class ConfigField(CabalField):+    section_key = 'cabal:cfg-section'+    indextemplate = '%s ; cabal project option'+    def handle_signature(self, sig, signode):+        sig = sig.strip()+        if sig.startswith('-'):+            name = parse_flag(self, sig, signode)+        else:+            name = super(ConfigField, self).handle_signature(sig, signode)++        return name++    def get_index_entry(self, env, name):+        if name.startswith('-'):+            section = self.env.ref_context.get(self.section_key)+            if section is not None:+                parts = ('cfg-flag', section, name)+                indexname = section + ':' + name+            else:+                parts = ('cfg-flag', name)+                indexname = name+            indexentry = name + '; cabal project option'+            targetname = '-'.join(parts)+            return indexentry, targetname+        else:+            return super(ConfigField,self).get_index_entry(env, name)++    def get_env_key(self, env, name):+        section = self.env.ref_context.get(self.section_key)+        if name.startswith('-'):+            return (section, name), 'cfg-flags'+        return (section, name), 'cfg-fields'++class CabalConfigFieldXRef(CabalFieldXRef):+    section_key = 'cabal:cfg-section'+++#+# Cabal domain+#++class ConfigFieldIndex(Index):+    name = 'projectindex'+    localname = "Cabal reference"+    shortname = "Reference"++    class Entry(object):+        def __init__(self, typ, name, doc, anchor, meta):+            self.type = typ+            self.name = name+            self.doc = doc+            self.anchor = anchor+            self.meta = meta++    def _gather_data(self, obj_types):+        '''+        Gather objects and return [(title, [Entry])]+        '''+        def massage(typ, datum):+            name, (doc, anchor, meta) = datum+            return self.Entry(typ, name, doc, anchor, meta)++        fields = []+        for typ in obj_types:+            store = CabalDomain.types[typ]+            fields += [massage(typ, x)+                      for x in self.domain.data[store].items()]++        fields.sort(key=lambda x: (x.doc, x.meta.index))++        if len(fields) == 0:+            return []++        result = []+        current = []+        current_title = fields[0].meta.title+        for field in fields:+            if field.meta.title != current_title:+                result.append((current_title, current))+                current = []+                current_title = field.meta.title+            current.append(field)+        result.append((current_title, current))++        return result+++    def generate(self, docnames=None):+        '''+        Try to group entries such that if entry has a section then put it+        into same group.++        Otherwise group it under same `title`.++        Try to keep in same order as it was defined.++        sort by (document, index)+        group on (document, doc_section)++        TODO: Check how to extract section numbers from (document,doc_section)+              and add it as annotation to titles+        '''++        # (title, section store, fields store)+        entries = [('project.cabal fields', 'cfg-section', 'cfg-field'),+                   ('cabal project flags', 'cfg-section', 'cfg-flag'),+                   ('package.cabal fields', 'pkg-section', 'pkg-field')]++        result = []+        for label, section_key, key in entries:++            data = self._gather_data([section_key, key])++            references = []+            for section, entries in data:+                if section is None:+                    elem_type = 0 # Normal entry+                else:+                    elem_type = 2 # sub_entry++                assert len(entries) != 0+                docname = entries[0].doc+                if section is not None:+                    section_title, section_anchor = section+                    references.append(+                        (section_title, 1, docname, section_anchor, '', '', ''))++                for entry in entries:+                    #todo deal with if+                    if isinstance(entry.name, tuple):+                        name = entry.name[1]+                    else:+                        name = entry.name++                    meta = entry.meta+                    extra = render_meta(meta)+                    descr = meta.synopsis if meta.synopsis is not None else ''+                    field = (name, elem_type, docname,+                             entry.anchor, extra, '', descr)+                    references.append(field)+            result.append((label, references))++        return result, False++def make_data_keys(typ, target, node):+    '''+    Returns a list of keys to search for targets of this type+    in domain data.++    Used for resolving references+    '''+    if typ == 'pkg-field':+        section = node.get('cabal:pkg-section')+        return [(section, target),+                (None, target)]+    elif typ in ('cfg-field', 'cfg-flag'):+        section = node.get('cabal:cfg-section')+        return [(section, target), (None, target)]+    else:+        return [target]+++def render_deprecated(deprecated):+    if isinstance(deprecated, StrictVersion):+        return 'deprecated since: '+str(deprecated)+    else:+        return 'deprecated'+++def render_meta(meta):+    '''+    Render meta as short text++    Will render either deprecated or since info+    '''+    if meta.deprecated is not None:+        return render_deprecated(meta.deprecated)+    elif meta.since is not None:+        return 'since version: ' + str(meta.since)+    else:+        return ''++def render_meta_title(meta):+    '''+    Render meta as suitable to use in titles+    '''+    rendered = render_meta(meta)+    if rendered != '':+        return '(' + rendered + ')'+    return ''++def make_title(typ, key, meta):+    '''+    Render title of an object (section, field or flag)+    '''+    if typ == 'pkg-section':+        return "package.cabal " + key + " section " + render_meta_title(meta)++    elif typ == 'pkg-field':+        section, name = key+        if section is not None:+            base = "package.cabal " + section + " section " + name + ": field"+        else:+            base = "package.cabal " + name + " field"++        return base + render_meta_title(meta)++    elif typ == 'cfg-section':+        return "project.cabal " + key + " section " + render_meta_title(meta)++    elif typ == 'cfg-field':+        section, name = key+        return "project.cabal " + name + " field " + render_meta_title(meta)++    elif typ == 'cfg-flag':+        section, name = key+        return "cabal flag " + name + " " + render_meta_title(meta)++    else:+        raise ValueError("Unknown type: " + typ)++def make_full_name(typ, key, meta):+    '''+    Return an anchor name for object type+    '''+    if typ == 'pkg-section':+        return 'pkg-section-' + key++    elif typ == 'pkg-field':+        section, name = key+        if section is not None:+            return '-'.join(('pkg-field',section, name))+        else:+            return 'pkg-field-' + name++    elif typ == 'cfg-field':+        return 'cfg-field-' + key++    else:+        raise ValueError('Unknown object type: ' + typ)++class CabalDomain(Domain):+    '''+    Sphinx domain for cabal++    needs Domain.merge_doc for parallel building, just union all dicts+    '''+    name = 'cabal'+    label = 'Cabal'+    object_types = {+        'pkg-section': ObjType(l_('pkg-section'), 'pkg-section'),+        'pkg-field'  : ObjType(l_('pkg-field')  , 'pkg-field'  ),+        'cfg-section': ObjType(l_('cfg-section'), 'cfg-section'),+        'cfg-field'  : ObjType(l_('cfg-field')  , 'cfg-field' ),+    }+    directives = {+        'pkg-section': CabalPackageSection,+        'pkg-field'  : CabalPackageField,+        'cfg-section': CabalConfigSection,+        'cfg-field'  : ConfigField,+    }+    roles = {+        'pkg-section': XRefRole(warn_dangling=True),+        'pkg-field'  : CabalPackageFieldXRef(warn_dangling=True),+        'cfg-section': XRefRole(warn_dangling=True),+        'cfg-field'  : CabalConfigFieldXRef(warn_dangling=True),+        'cfg-flag'   : CabalConfigFieldXRef(warn_dangling=True),+    }+    initial_data = {+        'pkg-sections': {},+        'pkg-fields'  : {},+        'cfg-sections': {},+        'index-num'   : {}, #per document number of objects+                            # used to order references page+        'cfg-fields'  : {},+        'cfg-flags'   : {},+    }+    indices = [+        ConfigFieldIndex+    ]+    types = {+        'pkg-section': 'pkg-sections',+        'pkg-field'  : 'pkg-fields',+        'cfg-section': 'cfg-sections',+        'cfg-field'  : 'cfg-fields',+        'cfg-flag'   : 'cfg-flags',+    }+    def clear_doc(self, docname):+        for k in ['pkg-sections', 'pkg-fields', 'cfg-sections',+                  'cfg-fields', 'cfg-flags']:+            for name, (fn, _, _) in self.data[k].items():+                if fn == docname:+                    del self.data[k][comname]+        try:+            del self.data['index-num'][docname]+        except KeyError:+            pass++    def resolve_xref(self, env, fromdocname, builder, type, target, node, contnode):+        objtypes = self.objtypes_for_role(type)+        for typ, key in ((typ, key)+                         for typ in objtypes+                         for key in make_data_keys(typ, target, node)):+            try:+                data = env.domaindata['cabal'][self.types[typ]][key]+            except KeyError:+                continue+            doc, ref, meta = data+            title = make_title(typ, key, meta)+            return make_refnode(builder, fromdocname, doc, ref, contnode, title)++    def get_objects(self):+        '''+        Used for search functionality+        '''+        for typ in ['pkg-section', 'pkg-field',+                    'cfg-section', 'cfg-field', 'cfg-flag']:+            key = self.types[typ]+            for name, (fn, target, meta) in self.data[key].items():+                title = make_title(typ, name, meta)+                yield title, title, typ, fn, target, 0++class CabalLexer(lexer.RegexLexer):+    '''+    Basic cabal lexer, does not try to be smart+    '''+    name = 'Cabal'+    aliases = ['cabal']+    filenames = ['.cabal']+    flags = re.MULTILINE++    tokens = {+      'root' : [+          (r'^(\s*)(--.*)$', lexer.bygroups(token.Whitespace, token.Comment.Single)),+          # key: value+          (r'^(\s*)([\w\-_]+)(:)',+           lexer.bygroups(token.Whitespace, token.Keyword, token.Punctuation)),+          (r'^([\w\-_]+)', token.Keyword), # library, executable, flag etc.+          (r'[^\S\n]+', token.Text),+          (r'&&|\|\||==|<=|\^>=|>=|<|>', token.Operator),+          (r',|:|{|}', token.Punctuation),+          (r'.', token.Text)+      ],+    }++def setup(app):+    app.add_domain(CabalDomain)+    app.add_lexer('cabal', CabalLexer())+
+ cabal/Cabal/doc/concepts-and-development.rst view
@@ -0,0 +1,7 @@+Package Concepts and Development+================================++.. toctree::+   :maxdepth: 2++   developing-packages
+ cabal/Cabal/doc/conf.py view
@@ -0,0 +1,207 @@+# -*- coding: utf-8 -*-+#+# GHC Users Guide documentation build configuration file+#+# This file is execfile()d with the current directory set to its+# containing dir.+#+import sys+import os+import sphinx_rtd_theme++# Support for :base-ref:, etc.+sys.path.insert(0, os.path.abspath('.'))+import cabaldomain++version = "1.25"++extensions = ['sphinx.ext.extlinks']++templates_path = ['_templates']+source_suffix = '.rst'+source_encoding = 'utf-8-sig'+master_doc = 'index'++# extlinks -- see http://www.sphinx-doc.org/en/stable/ext/extlinks.html+extlinks = {+    'issue': ('https://github.com/haskell/cabal/issues/%s', '#'),++    'ghc-wiki': ('http://ghc.haskell.org/trac/ghc/wiki/%s', ''),+    'ghc-ticket': ('http://ghc.haskell.org/trac/ghc/ticket/%s', 'GHC #'),++    'hackage-pkg': ('http://hackage.haskell.org/package/%s', ''),+}++# General information about the project.+project = u'Cabal'+copyright = u'2016, Cabal Team'+# N.B. version comes from ghc_config+release = version  # The full version, including alpha/beta/rc tags.++# Syntax highlighting+highlight_language = 'cabal'+#pygments_style = 'tango'++primary_domain = 'cabal'++# List of patterns, relative to source directory, that match files and+# directories to ignore when looking for source files.+exclude_patterns = ['.build', "*.gen.rst"]++# -- Options for HTML output ---------------------------------------------++# on_rtd is whether we are on readthedocs.org, this line of code grabbed from docs.readthedocs.org+on_rtd = os.environ.get('READTHEDOCS', None) == 'True'++if not on_rtd:  # only import and set the theme if we're building docs locally+    import sphinx_rtd_theme+    html_theme = 'sphinx_rtd_theme'+    html_theme_path = [sphinx_rtd_theme.get_html_theme_path()]++# The name for this set of Sphinx documents.  If None, it defaults to+# "<project> v<release> documentation".+html_title = "Cabal <release> User's Guide"+html_short_title = "Cabal %s User's Guide" % release+html_logo = 'images/Cabal-dark.png'+html_static_path = ['images']+# Convert quotes and dashes to typographically correct entities+html_use_smartypants = True+html_show_copyright = True++# If true, an OpenSearch description file will be output, and all pages will+# contain a <link> tag referring to it.  The value of this option must be the+# base URL from which the finished HTML is served.+#html_use_opensearch = ''++# This is the file name suffix for HTML files (e.g. ".xhtml").+#html_file_suffix = None++# Output file base name for HTML help builder.+htmlhelp_basename = 'CabalUsersGuide'+++# -- Options for LaTeX output ---------------------------------------------++latex_elements = {+    'inputenc': '',+    'utf8extra': '',+    'preamble': '''+\usepackage{fontspec}+\usepackage{makeidx}+\setsansfont{DejaVu Sans}+\setromanfont{DejaVu Serif}+\setmonofont{DejaVu Sans Mono}+''',+}++# Grouping the document tree into LaTeX files. List of tuples+# (source start file, target name, title,+#  author, documentclass [howto, manual, or own class]).+latex_documents = [+  ('index', 'users_guide.tex', u'GHC Users Guide Documentation',+   u'GHC Team', 'manual'),+]++# The name of an image file (relative to this directory) to place at the top of+# the title page.+latex_logo = 'images/logo.pdf'++# If true, show page references after internal links.+latex_show_pagerefs = True+++# -- Options for manual page output ---------------------------------------++# One entry per manual page. List of tuples+# (source start file, name, description, authors, manual section).+man_pages = [+    ('cabal', 'cabal', 'The Haskell Cabal', 'The Cabal Team', 1)+]++# If true, show URL addresses after external links.+#man_show_urls = False+++# -- Options for Texinfo output -------------------------------------------++# Grouping the document tree into Texinfo files. List of tuples+# (source start file, target name, title, author,+#  dir menu entry, description, category)+texinfo_documents = [+  ('index', 'CabalUsersGuide', u'Cabal Users Guide',+   u'Cabal Team', 'CabalUsersGuide', 'The Haskell Cabal.',+   'Compilers'),+]++from sphinx import addnodes+from docutils import nodes++def parse_ghci_cmd(env, sig, signode):+    name = sig.split(';')[0]+    sig = sig.replace(';', '')+    signode += addnodes.desc_name(name, sig)+    return name++def parse_flag(env, sig, signode):+    import re+    names = []+    for i, flag in enumerate(sig.split(',')):+        flag = flag.strip()+        sep = '='+        parts = flag.split('=')+        if len(parts) == 1:+            sep=' '+            parts = flag.split()+        if len(parts) == 0: continue++        name = parts[0]+        names.append(name)+        sig = sep + ' '.join(parts[1:])+        sig = re.sub(ur'<([-a-zA-Z ]+)>', ur'⟨\1⟩', sig)+        if i > 0:+            signode += addnodes.desc_name(', ', ', ')+        signode += addnodes.desc_name(name, name)+        if len(sig) > 0:+            signode += addnodes.desc_addname(sig, sig)++    return names[0]++def setup(app):+    from sphinx.util.docfields import Field, TypedField++    increase_python_stack()++    # the :ghci-cmd: directive used in ghci.rst+    app.add_object_type('ghci-cmd', 'ghci-cmd',+                        parse_node=parse_ghci_cmd,+                        objname='GHCi command',+                        indextemplate='pair: %s; GHCi command')++    app.add_object_type('ghc-flag', 'ghc-flag',+                        objname='GHC command-line option',+                        parse_node=parse_flag,+                        indextemplate='pair: %s; GHC option',+                        doc_field_types=[+                            Field('since', label='Introduced in GHC version', names=['since']),+                            Field('default', label='Default value', names=['default']),+                            Field('static')+                        ])++    app.add_object_type('rts-flag', 'rts-flag',+                        objname='runtime system command-line option',+                        parse_node=parse_flag,+                        indextemplate='pair: %s; RTS option',+                        doc_field_types=[+                            Field('since', label='Introduced in GHC version', names=['since']),+                        ])++    cabaldomain.setup(app)++def increase_python_stack():+    # Workaround sphinx-build recursion limit overflow:+    # pickle.dump(doctree, f, pickle.HIGHEST_PROTOCOL)+    #  RuntimeError: maximum recursion depth exceeded while pickling an object+    #+    # Default python allows recursion depth of 1000 calls.+    sys.setrecursionlimit(10000)+
+ cabal/Cabal/doc/config-and-install.rst view
@@ -0,0 +1,5 @@+Configuration and Installing Packages+=====================================++.. toctree::+   installing-packages
− cabal/Cabal/doc/developing-packages.markdown 
@@ -1,2255 +0,0 @@-% Cabal User Guide: Developing Cabal packages---# Quickstart #---Lets assume we have created a project directory and already have a-Haskell module or two.--Every project needs a name, we'll call this example "proglet".--~~~~~~~~~~~-$ cd proglet/-$ ls-Proglet.hs-~~~~~~~~~~~--It is assumed that (apart from external dependencies) all the files that-make up a package live under a common project root directory. This-simple example has all the project files in one directory, but most-packages will use one or more subdirectories.--To turn this into a Cabal package we need two extra files in the-project's root directory:-- * `proglet.cabal`: containing package metadata and build information.-- * `Setup.hs`: usually containing a few standardized lines of code, but-   can be customized if necessary.--We can create both files manually or we can use `cabal init` to create-them for us.--### Using "cabal init" ###--The `cabal init` command is interactive. It asks us a number of-questions starting with the package name and version.--~~~~~~~~~~-$ cabal init-Package name [default "proglet"]?-Package version [default "0.1"]?-...-~~~~~~~~~~--It also asks questions about various other bits of package metadata. For-a package that you never intend to distribute to others, these fields can-be left blank.--One of the important questions is whether the package contains a library-or an executable. Libraries are collections of Haskell modules that can-be re-used by other Haskell libraries and programs, while executables-are standalone programs.--~~~~~~~~~~-What does the package build:-   1) Library-   2) Executable-Your choice?-~~~~~~~~~~--For the moment these are the only choices. For more complex packages-(e.g. a library and multiple executables or test suites) the `.cabal`-file can be edited afterwards.--Finally, `cabal init` creates the initial `proglet.cabal` and `Setup.hs`-files, and depending on your choice of license, a `LICENSE` file as well.--~~~~~~~~~~-Generating LICENSE...-Generating Setup.hs...-Generating proglet.cabal...--You may want to edit the .cabal file and add a Description field.-~~~~~~~~~~--As this stage the `proglet.cabal` is not quite complete and before you-are able to build the package you will need to edit the file and add-some build information about the library or executable.--### Editing the .cabal file ###--Load up the `.cabal` file in a text editor. The first part of the-`.cabal` file has the package metadata and towards the end of the file-you will find the `executable` or `library` section.--You will see that the fields that have yet to be filled in are commented-out. Cabal files use "`--`" Haskell-style comment syntax. (Note that-comments are only allowed on lines on their own. Trailing comments on-other lines are not allowed because they could be confused with program-options.)--If you selected earlier to create a library package then your `.cabal`-file will have a section that looks like this:--~~~~~~~~~~~~~~~~~-library-  exposed-modules:     Proglet-  -- other-modules:-  -- build-depends:-~~~~~~~~~~~~~~~~~--Alternatively, if you selected an executable then there will be a-section like:--~~~~~~~~~~~~~~~~~-executable proglet-  -- main-is:-  -- other-modules:-  -- build-depends:-~~~~~~~~~~~~~~~~~--The build information fields listed (but commented out) are just the few-most important and common fields. There are many others that are covered-later in this chapter.--Most of the build information fields are the same between libraries and-executables. The difference is that libraries have a number of "exposed"-modules that make up the public interface of the library, while-executables have a file containing a `Main` module.--The name of a library always matches the name of the package, so it is-not specified in the library section. Executables often follow the name-of the package too, but this is not required and the name is given-explicitly.--### Modules included in the package ###--For a library, `cabal init` looks in the project directory for files-that look like Haskell modules and adds all the modules to the-`exposed-modules` field. For modules that do not form part of your-package's public interface, you can move those modules to the-`other-modules` field. Either way, all modules in the library need to be-listed.--For an executable, `cabal init` does not try to guess which file-contains your program's `Main` module. You will need to fill in the-`main-is` field with the file name of your program's `Main` module-(including `.hs` or `.lhs` extension). Other modules included in the-executable should be listed in the `other-modules` field.--### Modules imported from other packages ###--While your library or executable may include a number of modules, it-almost certainly also imports a number of external modules from the-standard libraries or other pre-packaged libraries. (These other-libraries are of course just Cabal packages that contain a library.)--You have to list all of the library packages that your library or-executable imports modules from. Or to put it another way: you have to-list all the other packages that your package depends on.--For example, suppose the example `Proglet` module imports the module-`Data.Map`. The `Data.Map` module comes from the `containers` package,-so we must list it:--~~~~~~~~~~~~~~~~~-library-  exposed-modules:     Proglet-  other-modules:-  build-depends:       containers, base == 4.*-~~~~~~~~~~~~~~~~~--In addition, almost every package also depends on the `base` library-package because it exports the standard `Prelude` module plus other-basic modules like `Data.List`.--You will notice that we have listed `base == 4.*`. This gives a-constraint on the version of the base package that our package will work-with. The most common kinds of constraints are:-- * `pkgname >= n`- * `pkgname >= n && < m`- * `pkgname == n.*`--The last is just shorthand, for example `base == 4.*` means exactly the-same thing as `base >= 4 && < 5`.--### Building the package ###--For simple packages that's it! We can now try configuring and building-the package:--~~~~~~~~~~~~~~~~-cabal configure-cabal build-~~~~~~~~~~~~~~~~--Assuming those two steps worked then you can also install the package:--~~~~~~~~~~~~~~~~-cabal install-~~~~~~~~~~~~~~~~--For libraries this makes them available for use in GHCi or to be used by-other packages. For executables it installs the program so that you can-run it (though you may first need to adjust your system's `$PATH`).--### Next steps ###--What we have covered so far should be enough for very simple packages-that you use on your own system.--The next few sections cover more details needed for more complex-packages and details needed for distributing packages to other people.--The previous chapter covers building and installing packages -- your own-packages or ones developed by other people.---# Package concepts #--Before diving into the details of writing packages it helps to-understand a bit about packages in the Haskell world and the particular-approach that Cabal takes.--### The point of packages ###--Packages are a mechanism for organising and distributing code. Packages-are particularly suited for "programming in the large", that is building-big systems by using and re-using code written by different people at-different times.--People organise code into packages based on functionality and-dependencies. Social factors are also important: most packages have a-single author, or a relatively small team of authors.--Packages are also used for distribution: the idea is that a package can-be created in one place and be moved to a different computer and be-usable in that different environment. There are a surprising number of-details that have to be got right for this to work, and a good package-system helps to simply this process and make it reliable.--Packages come in two main flavours: libraries of reusable code, and-complete programs. Libraries present a code interface, an API, while-programs can be run directly. In the Haskell world, library packages-expose a set of Haskell modules as their public interface. Cabal-packages can contain a library or executables or both.--Some programming languages have packages as a builtin language concept.-For example in Java, a package provides a local namespace for types and-other definitions. In the Haskell world, packages are not a part of the-language itself. Haskell programs consist of a number of modules, and-packages just provide a way to partition the modules into sets of-related functionality. Thus the choice of module names in Haskell is-still important, even when using packages.--### Package names and versions ###--All packages have a name, e.g. "HUnit". Package names are assumed to be-unique. Cabal package names can use letters, numbers and hyphens, but-not spaces. The namespace for Cabal packages is flat, not hierarchical.--Packages also have a version, e.g "1.1". This matches the typical way in-which packages are developed. Strictly speaking, each version of a-package is independent, but usually they are very similar. Cabal package-versions follow the conventional numeric style, consisting of a sequence-of digits such as "1.0.1" or "2.0". There are a range of common-conventions for "versioning" packages, that is giving some meaning to-the version number in terms of changes in the package. Section [TODO]-has some tips on package versioning.--The combination of package name and version is called the _package ID_-and is written with a hyphen to separate the name and version, e.g.-"HUnit-1.1".--For Cabal packages, the combination of the package name and version-_uniquely_ identifies each package. Or to put it another way: two-packages with the same name and version are considered to _be_ the same.--Strictly speaking, the package ID only identifies each Cabal _source_-package; the same Cabal source package can be configured and built in-different ways. There is a separate installed package ID that uniquely-identifies each installed package instance. Most of the time however,-users need not be aware of this detail.--### Kinds of package: Cabal vs GHC vs system ###--It can be slightly confusing at first because there are various-different notions of package floating around. Fortunately the details-are not very complicated.--Cabal packages-:   Cabal packages are really source packages. That is they contain-    Haskell (and sometimes C) source code.--    Cabal packages can be compiled to produce GHC packages. They can-    also be translated into operating system packages.--GHC packages-:   This is GHC's view on packages. GHC only cares about library-    packages, not executables. Library packages have to be registered-    with GHC for them to be available in GHCi or to be used when-    compiling other programs or packages.--    The low-level tool `ghc-pkg` is used to register GHC packages and to-    get information on what packages are currently registered.--    You never need to make GHC packages manually. When you build and-    install a Cabal package containing a library then it gets registered-    with GHC automatically.--    Haskell implementations other than GHC have essentially the same-    concept of registered packages. For the most part, Cabal hides the-    slight differences.--Operating system packages-:   On operating systems like Linux and Mac OS X, the system has a-    specific notion of a package and there are tools for installing and-    managing packages.--    The Cabal package format is designed to allow Cabal packages to be-    translated, mostly-automatically, into operating system packages.-    They are usually translated 1:1, that is a single Cabal package-    becomes a single system package.--    It is also possible to make Windows installers from Cabal packages,-    though this is typically done for a program together with all of its-    library dependencies, rather than packaging each library separately.---### Unit of distribution ###--The Cabal package is the unit of distribution. What this means is that-each Cabal package can be distributed on its own in source or binary-form. Of course there may dependencies between packages, but there is-usually a degree of flexibility in which versions of packages can work-together so distributing them independently makes sense.--It is perhaps easiest to see what being ``the unit of distribution''-means by contrast to an alternative approach. Many projects are made up-of several interdependent packages and during development these might-all be kept under one common directory tree and be built and tested-together. When it comes to distribution however, rather than-distributing them all together in a single tarball, it is required that-they each be distributed independently in their own tarballs.--Cabal's approach is to say that if you can specify a dependency on a-package then that package should be able to be distributed-independently. Or to put it the other way round, if you want to-distribute it as a single unit, then it should be a single package.---### Explicit dependencies and automatic package management ###--Cabal takes the approach that all packages dependencies are specified-explicitly and specified in a declarative way. The point is to enable-automatic package management. This means tools like `cabal` can resolve-dependencies and install a package plus all of its dependencies-automatically. Alternatively, it is possible to mechanically (or mostly-mechanically) translate Cabal packages into system packages and let the-system package manager install dependencies automatically.--It is important to track dependencies accurately so that packages can-reliably be moved from one system to another system and still be able to-build it there. Cabal is therefore relatively strict about specifying-dependencies. For example Cabal's default build system will not even let-code build if it tries to import a module from a package that isn't-listed in the `.cabal` file, even if that package is actually installed.-This helps to ensure that there are no "untracked dependencies" that-could cause the code to fail to build on some other system.--The explicit dependency approach is in contrast to the traditional-"./configure" approach where instead of specifying dependencies-declaratively, the `./configure` script checks if the dependencies are-present on the system. Some manual work is required to transform a-`./configure` based package into a Linux distribution package (or-similar). This conversion work is usually done by people other than the-package author(s). The practical effect of this is that only the most-popular packages will benefit from automatic package management. Instead,-Cabal forces the original author to specify the dependencies but the-advantage is that every package can benefit from automatic package-management.--The "./configure" approach tends to encourage packages that adapt-themselves to the environment in which they are built, for example by-disabling optional features so that they can continue to work when a-particular dependency is not available. This approach makes sense in a-world where installing additional dependencies is a tiresome manual-process and so minimising dependencies is important. The automatic-package management view is that packages should just declare what they-need and the package manager will take responsibility for ensuring that-all the dependencies are installed.--Sometimes of course optional features and optional dependencies do make-sense. Cabal packages can have optional features and varying-dependencies. These conditional dependencies are still specified in a-declarative way however and remain compatible with automatic package-management. The need to remain compatible with automatic package-management means that Cabal's conditional dependencies system is a bit-less flexible than with the "./configure" approach.--### Portability ###--One of the purposes of Cabal is to make it easier to build packages on-different platforms (operating systems and CPU architectures), with-different compiler versions and indeed even with different Haskell-implementations. (Yes, there are Haskell implementations other than-GHC!)--Cabal provides abstractions of features present in different Haskell-implementations and wherever possible it is best to take advantage of-these to increase portability. Where necessary however it is possible to-use specific features of specific implementations.--For example a package author can list in the package's `.cabal` what-language extensions the code uses. This allows Cabal to figure out if-the language extension is supported by the Haskell implementation that-the user picks. Additionally, certain language extensions such as-Template Haskell require special handling from the build system and by-listing the extension it provides the build system with enough-information to do the right thing.--Another similar example is linking with foreign libraries. Rather than-specifying GHC flags directly, the package author can list the libraries-that are needed and the build system will take care of using the right-flags for the compiler. Additionally this makes it easier for tools to-discover what system C libraries a package needs, which is useful for-tracking dependencies on system libraries (e.g. when translating into-Linux distribution packages).--In fact both of these examples fall into the category of explicitly-specifying dependencies. Not all dependencies are other Cabal packages.-Foreign libraries are clearly another kind of dependency. It's also-possible to think of language extensions as dependencies: the package-depends on a Haskell implementation that supports all those extensions.--Where compiler-specific options are needed however, there is an "escape-hatch" available. The developer can specify implementation-specific-options and more generally there is a configuration mechanism to-customise many aspects of how a package is built depending on the-Haskell implementation, the operating system, computer architecture and-user-specified configuration flags.---# Developing packages #--The Cabal package is the unit of distribution. When installed, its-purpose is to make available:--  * One or more Haskell programs.--  * At most one library, exposing a number of Haskell modules.--However having both a library and executables in a package does not work-very well; if the executables depend on the library, they must-explicitly list all the modules they directly or indirectly import from-that library.  Fortunately, starting with Cabal 1.8.0.4, executables can-also declare the package that they are in as a dependency, and Cabal-will treat them as if they were in another package that depended on-the library.--Internally, the package may consist of much more than a bunch of Haskell-modules: it may also have C source code and header files, source code-meant for preprocessing, documentation, test cases, auxiliary tools etc.--A package is identified by a globally-unique _package name_, which-consists of one or more alphanumeric words separated by hyphens.  To-avoid ambiguity, each of these words should contain at least one letter.-Chaos will result if two distinct packages with the same name are-installed on the same system. A particular version of the package is-distinguished by a _version number_, consisting of a sequence of one or-more integers separated by dots.  These can be combined to form a single-text string called the _package ID_, using a hyphen to separate the name-from the version, e.g. "`HUnit-1.1`".--Note: Packages are not part of the Haskell language; they simply-populate the hierarchical space of module names. In GHC 6.6 and later a-program may contain multiple modules with the same name if they come-from separate packages; in all other current Haskell systems packages-may not overlap in the modules they provide, including hidden modules.---## Creating a package ##--Suppose you have a directory hierarchy containing the source files that-make up your package.  You will need to add two more files to the root-directory of the package:--_package_`.cabal`--:   a Unicode UTF-8 text file containing a package description.-    For details of the syntax of this file, see the [section on package-    descriptions](#package-descriptions).--`Setup.hs`--:   a single-module Haskell program to perform various setup tasks (with-    the interface described in the section on [building and installing-    packages](installing-packages.html). This module should-    import only modules that will be present in all Haskell-    implementations, including modules of the Cabal library. The-    content of this file is determined by the `build-type` setting in-    the `.cabal` file. In most cases it will be trivial, calling on-    the Cabal library to do most of the work.--Once you have these, you can create a source bundle of this directory-for distribution. Building of the package is discussed in the section on-[building and installing packages](installing-packages.html).--One of the purposes of Cabal is to make it easier to build a package-with different Haskell implementations. So it provides abstractions of-features present in different Haskell implementations and wherever-possible it is best to take advantage of these to increase portability.-Where necessary however it is possible to use specific features of-specific implementations. For example one of the pieces of information a-package author can put in the package's `.cabal` file is what language-extensions the code uses. This is far preferable to specifying flags for-a specific compiler as it allows Cabal to pick the right flags for the-Haskell implementation that the user picks. It also allows Cabal to-figure out if the language extension is even supported by the Haskell-implementation that the user picks. Where compiler-specific options are-needed however, there is an "escape hatch" available. The developer can-specify implementation-specific options and more generally there is a-configuration mechanism to customise many aspects of how a package is-built depending on the Haskell implementation, the Operating system,-computer architecture and user-specified configuration flags.--~~~~~~~~~~~~~~~~-name:     Foo-version:  1.0--library-  build-depends:   base-  exposed-modules: Foo-  extensions:      ForeignFunctionInterface-  ghc-options:     -Wall-  if os(windows)-    build-depends: Win32-~~~~~~~~~~~~~~~~--#### Example: A package containing a simple library ####--The HUnit package contains a file `HUnit.cabal` containing:--~~~~~~~~~~~~~~~~-name:           HUnit-version:        1.1.1-synopsis:       A unit testing framework for Haskell-homepage:       http://hunit.sourceforge.net/-category:       Testing-author:         Dean Herington-license:        BSD3-license-file:   LICENSE-cabal-version:  >= 1.10-build-type:     Simple--library-  build-depends:      base >= 2 && < 4-  exposed-modules:    Test.HUnit.Base, Test.HUnit.Lang,-                      Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit-  default-extensions: CPP-~~~~~~~~~~~~~~~~--and the following `Setup.hs`:--~~~~~~~~~~~~~~~~-import Distribution.Simple-main = defaultMain-~~~~~~~~~~~~~~~~--#### Example: A package containing executable programs ####--~~~~~~~~~~~~~~~~-name:           TestPackage-version:        0.0-synopsis:       Small package with two programs-author:         Angela Author-license:        BSD3-build-type:     Simple-cabal-version:  >= 1.2--executable program1-  build-depends:  HUnit-  main-is:        Main.hs-  hs-source-dirs: prog1--executable program2-  main-is:        Main.hs-  build-depends:  HUnit-  hs-source-dirs: prog2-  other-modules:  Utils-~~~~~~~~~~~~~~~~--with `Setup.hs` the same as above.--#### Example: A package containing a library and executable programs ####--~~~~~~~~~~~~~~~~-name:            TestPackage-version:         0.0-synopsis:        Package with library and two programs-license:         BSD3-author:          Angela Author-build-type:      Simple-cabal-version:   >= 1.2--library-  build-depends:   HUnit-  exposed-modules: A, B, C--executable program1-  main-is:         Main.hs-  hs-source-dirs:  prog1-  other-modules:   A, B--executable program2-  main-is:         Main.hs-  hs-source-dirs:  prog2-  other-modules:   A, C, Utils-~~~~~~~~~~~~~~~~--with `Setup.hs` the same as above. Note that any library modules-required (directly or indirectly) by an executable must be listed again.--The trivial setup script used in these examples uses the _simple build-infrastructure_ provided by the Cabal library (see-[Distribution.Simple][dist-simple]). The simplicity lies in its-interface rather that its implementation. It automatically handles-preprocessing with standard preprocessors, and builds packages for all-the Haskell implementations.--The simple build infrastructure can also handle packages where building-is governed by system-dependent parameters, if you specify a little more-(see the section on [system-dependent-parameters](#system-dependent-parameters)). A few packages require [more-elaborate solutions](#more-complex-packages).--## Package descriptions ##--The package description file must have a name ending in "`.cabal`".  It-must be a Unicode text file encoded using valid UTF-8. There must be-exactly one such file in the directory.  The first part of the name is-usually the package name, and some of the tools that operate on Cabal-packages require this.--In the package description file, lines whose first non-whitespace characters-are "`--`" are treated as comments and ignored.--This file should contain of a number global property descriptions and-several sections.--* The [global properties](#package-properties) describe the package as a-  whole, such as name, license, author, etc.--* Optionally, a number of _configuration flags_ can be declared.  These-  can be used to enable or disable certain features of a package. (see-  the section on [configurations](#configurations)).--* The (optional) library section specifies the [library-  properties](#library) and relevant [build-  information](#build-information).--* Following is an arbitrary number of executable sections-  which describe an executable program and relevant [build-  information](#build-information).--Each section consists of a number of property descriptions-in the form of field/value pairs, with a syntax roughly like mail-message headers.--* Case is not significant in field names, but is significant in field-  values.--* To continue a field value, indent the next line relative to the field-  name.--* Field names may be indented, but all field values in the same section-  must use the same indentation.--* Tabs are *not* allowed as indentation characters due to a missing-  standard interpretation of tab width.--* To get a blank line in a field value, use an indented "`.`"--The syntax of the value depends on the field.  Field types include:--_token_, _filename_, _directory_-:   Either a sequence of one or more non-space non-comma characters, or a quoted-    string in Haskell 98 lexical syntax. The latter can be used for escaping-    whitespace, for example: `ghc-options: -Wall "-with-rtsopts=-T -I1"`.-    Unless otherwise stated, relative filenames and directories are interpreted-    from the package root directory.--_freeform_, _URL_, _address_-:   An arbitrary, uninterpreted string.--_identifier_-:   A letter followed by zero or more alphanumerics or underscores.--_compiler_-:   A compiler flavor (one of: `GHC`, `JHC`, `UHC` or `LHC`) followed by a-    version range.  For example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`.--### Modules and preprocessors ###--Haskell module names listed in the `exposed-modules` and `other-modules`-fields may correspond to Haskell source files, i.e. with names ending in-"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The-simple build infrastructure understands the extensions:--* `.gc` ([greencard][])-* `.chs` ([c2hs][])-* `.hsc` (`hsc2hs`)-* `.y` and `.ly` ([happy][])-* `.x` ([alex][])-* `.cpphs` ([cpphs][])--When building, Cabal will automatically run the appropriate-preprocessor and compile the Haskell module it produces.  For the-`c2hs` and `hsc2hs` preprocessors, Cabal will also automatically add,-compile and link any C sources generated by the preprocessor (produced-by `hsc2hs`'s `#def` feature or `c2hs`'s auto-generated wrapper-functions).--Some fields take lists of values, which are optionally separated by commas,-except for the `build-depends` field, where the commas are mandatory.--Some fields are marked as required.  All others are optional, and unless-otherwise specified have empty default values.--### Package properties ###--These fields may occur in the first top-level properties section and-describe the package as a whole:--`name:` _package-name_ (required)-:   The unique name of the package, without the version number.--`version:` _numbers_ (required)-:   The package version number, usually consisting of a sequence of-    natural numbers separated by dots.--`cabal-version:`  _>= x.y_-:   The version of the Cabal specification that this package description uses.-    The Cabal specification does slowly evolve, introducing new features and-    occasionally changing the meaning of existing features. By specifying-    which version of the spec you are using it enables programs which process-    the package description to know what syntax to expect and what each part-    means.--    For historical reasons this is always expressed using _>=_ version range-    syntax. No other kinds of version range make sense, in particular upper-    bounds do not make sense. In future this field will specify just a version-    number, rather than a version range.--    The version number you specify will affect both compatibility and-    behaviour. Most tools (including the Cabal library and cabal program)-    understand a range of versions of the Cabal specification. Older tools-    will of course only work with older versions of the Cabal specification.-    Most of the time, tools that are too old will recognise this fact and-    produce a suitable error message.--    As for behaviour, new versions of the Cabal spec can change the meaning-    of existing syntax. This means if you want to take advantage of the new-    meaning or behaviour then you must specify the newer Cabal version.-    Tools are expected to use the meaning and behaviour appropriate to the-    version given in the package description.--    In particular, the syntax of package descriptions changed significantly-    with Cabal version 1.2 and the `cabal-version` field is now required.-    Files written in the old syntax are still recognized, so if you require-    compatibility with very old Cabal versions then you may write your package-    description file using the old syntax.  Please consult the user's guide of-    an older Cabal version for a description of that syntax.--`build-type:` _identifier_-:   The type of build used by this package. Build types are the-    constructors of the [BuildType][] type, defaulting to `Custom`.--    If the build type is anything other than `Custom`, then the-    `Setup.hs` file *must* be exactly the standardized content-    discussed below. This is because in these cases, `cabal` will-    ignore the `Setup.hs` file completely, whereas other methods of-    package management, such as `runhaskell Setup.hs [CMD]`, still-    rely on the `Setup.hs` file.--    For build type `Simple`, the contents of `Setup.hs` must be:--    ~~~~~~~~~~~~~~~~-    import Distribution.Simple-    main = defaultMain-    ~~~~~~~~~~~~~~~~--    For build type `Configure` (see the section on [system-dependent-    parameters](#system-dependent-parameters) below), the contents of-    `Setup.hs` must be:--    ~~~~~~~~~~~~~~~~-    import Distribution.Simple-    main = defaultMainWithHooks autoconfUserHooks-    ~~~~~~~~~~~~~~~~--    For build type `Make` (see the section on [more complex-    packages](installing-packages.html#more-complex-packages) below),-    the contents of `Setup.hs` must be:--    ~~~~~~~~~~~~~~~~-    import Distribution.Make-    main = defaultMain-    ~~~~~~~~~~~~~~~~--    For build type `Custom`, the file `Setup.hs` can be customized,-    and will be used both by `cabal` and other tools.--    For most packages, the build type `Simple` is sufficient.--`license:` _identifier_ (default: `AllRightsReserved`)-:   The type of license under which this package is distributed.-    License names are the constants of the [License][dist-license] type.--`license-file:` _filename_ or `license-files:` _filename list_-:   The name of a file(s) containing the precise copyright license for-    this package. The license file(s) will be installed with the package.--    If you have multiple license files then use the `license-files`-    field instead of (or in addition to) the `license-file` field.--`copyright:` _freeform_-:   The content of a copyright notice, typically the name of the holder-    of the copyright on the package and the year(s) from which copyright-    is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs`--`author:` _freeform_-:   The original author of the package.--    Remember that `.cabal` files are Unicode, using the UTF-8 encoding.--`maintainer:` _address_-:   The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug-    reports, feature requests and patches.--`stability:` _freeform_-:   The stability level of the package, e.g. `alpha`, `experimental`, `provisional`,-    `stable`.--`homepage:` _URL_-:   The package homepage.--`bug-reports:` _URL_-:   The URL where users should direct bug reports. This would normally be either:--    * A `mailto:` URL, e.g. for a person or a mailing list.--    * An `http:` (or `https:`) URL for an online bug tracking system.--    For example Cabal itself uses a web-based bug tracking system--    ~~~~~~~~~~~~~~~~-    bug-reports: http://hackage.haskell.org/trac/hackage/-    ~~~~~~~~~~~~~~~~--`package-url:` _URL_-:   The location of a source bundle for the package. The distribution-    should be a Cabal package.--`synopsis:` _freeform_-:   A very short description of the package, for use in a table of-    packages.  This is your headline, so keep it short (one line) but as-    informative as possible. Save space by not including the package-    name or saying it's written in Haskell.--`description:` _freeform_-:   Description of the package.  This may be several paragraphs, and-    should be aimed at a Haskell programmer who has never heard of your-    package before.--    For library packages, this field is used as prologue text by [`setup-    haddock`](installing-packages.html#setup-haddock), and thus may-    contain the same markup as [haddock][] documentation comments.--`category:` _freeform_-:   A classification category for future use by the package catalogue [Hackage].  These-    categories have not yet been specified, but the upper levels of the-    module hierarchy make a good start.--`tested-with:` _compiler list_-:   A list of compilers and versions against which the package has been-    tested (or at least built).--`data-files:` _filename list_-:   A list of files to be installed for run-time use by the package.-    This is useful for packages that use a large amount of static data,-    such as tables of values  or code templates. Cabal provides a way to-    [find these files at-    run-time](#accessing-data-files-from-package-code).--    A limited form of `*` wildcards in file names, for example-    `data-files: images/*.png` matches all the `.png` files in the-    `images` directory.--    The limitation is that `*` wildcards are only allowed in place of-    the file name, not in the directory name or file extension.  In-    particular, wildcards do not include directories contents-    recursively. Furthermore, if a wildcard is used it must be used with-    an extension, so `data-files: data/*` is not allowed. When matching-    a wildcard plus extension, a file's full extension must match-    exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard-    that does not match any files is an error.--    The reason for providing only a very limited form of wildcard is to-    concisely express the common case of a large number of related files-    of the same file type without making it too easy to accidentally-    include unwanted files.--`data-dir:` _directory_-:   The directory where Cabal looks for data files to install, relative-    to the source directory. By default, Cabal will look in the source-    directory itself.--`extra-source-files:` _filename list_-:   A list of additional files to be included in source distributions-    built with [`setup sdist`](installing-packages.html#setup-sdist). As-    with `data-files` it can use a limited form of `*` wildcards in file-    names.--`extra-doc-files:` _filename list_-:   A list of additional files to be included in source distributions,-    and also copied to the html directory when Haddock documentation is-    generated. As with `data-files` it can use a limited form of `*`-    wildcards in file names.--`extra-tmp-files:` _filename list_-:   A list of additional files or directories to be removed by [`setup-    clean`](installing-packages.html#setup-clean). These would typically-    be additional files created by additional hooks, such as the scheme-    described in the section on [system-dependent-    parameters](#system-dependent-parameters).--### Library ###--The library section should contain the following fields:--`exposed-modules:` _identifier list_ (required if this package contains a library)-:   A list of modules added by this package.--`exposed:` _boolean_ (default: `True`)-:   Some Haskell compilers (notably GHC) support the notion of packages-    being "exposed" or "hidden" which means the modules they provide can-    be easily imported without always having to specify which package-    they come from. However this only works effectively if the modules-    provided by all exposed packages do not overlap (otherwise a module-    import would be ambiguous).--    Almost all new libraries use hierarchical module names that do not-    clash, so it is very uncommon to have to use this field. However it-    may be necessary to set `exposed: False` for some old libraries that-    use a flat module namespace or where it is known that the exposed-    modules would clash with other common modules.--`reexported-modules:` _exportlist _-:   Supported only in GHC 7.10 and later.  A list of modules to _reexport_ from-    this package.  The syntax of this field is `orig-pkg:Name as NewName` to-    reexport module `Name` from `orig-pkg` with the new name `NewName`.  We also-    support abbreviated versions of the syntax: if you omit `as NewName`,-    we'll reexport without renaming; if you omit `orig-pkg`, then we will-    automatically figure out which package to reexport from, if it's-    unambiguous.--    Reexported modules are useful for compatibility shims when a package has-    been split into multiple packages, and they have the useful property that-    if a package provides a module, and another package reexports it under-    the same name, these are not considered a conflict (as would be the case-    with a stub module.)  They can also be used to resolve name conflicts.--The library section may also contain build information fields (see the-section on [build information](#build-information)).--Cabal 1.23 and later support "internal libraries", which are extra named-libraries (as opposed to the usual unnamed library section).  For-example, suppose that your test suite needs access to some internal-modules in your library, which you do not otherwise want to export.  You-could put these modules in an internal library, which the main library-and the test suite `build-depends` upon.  Then your Cabal file might-look something like this:--~~~~~~~~~~~~~~~~-name:           foo-version:        1.0-license:        BSD3-cabal-version:  >= 1.23-build-type:     Simple--library foo-internal-    exposed-modules: Foo.Internal-    build-depends: base--library-    exposed-modules: Foo.Public-    build-depends: foo-internal, base--test-suite test-foo-    type:       exitcode-stdio-1.0-    main-is:    test-foo.hs-    build-depends: foo-internal, base-~~~~~~~~~~~~~~~~--Internal libraries are also useful for packages that define multiple-executables, but do not define a publically accessible library.-Internal libraries are only visible internally in the package (so they-can only be added to the `build-depends` of same-package libraries,-executables, test suites, etc.)  Internal libraries locally shadow any-packages which have the same name (so don't name an internal library-with the same name as an external dependency.)--#### Opening an interpreter session ####--While developing a package, it is often useful to make its code available inside-an interpreter session. This can be done with the `repl` command:--~~~~~~~~~~~~~~~~-cabal repl-~~~~~~~~~~~~~~~~--The name comes from the acronym [REPL], which stands for-"read-eval-print-loop". By default `cabal repl` loads the first component in a-package. If the package contains several named components, the name can be given-as an argument to `repl`. The name can be also optionally prefixed with the-component's type for disambiguation purposes. Example:--~~~~~~~~~~~~~~~~-cabal repl foo-cabal repl exe:foo-cabal repl test:bar-cabal repl bench:baz-~~~~~~~~~~~~~~~~--#### Freezing dependency versions ####--If a package is built in several different environments, such as a development-environment, a staging environment and a production environment, it may be-necessary or desirable to ensure that the same dependency versions are-selected in each environment. This can be done with the `freeze` command:--~~~~~~~~~~~~~~~~-cabal freeze-~~~~~~~~~~~~~~~~--The command writes the selected version for all dependencies to the-`cabal.config` file.  All environments which share this file will use the-dependency versions specified in it.--#### Generating dependency version bounds ####--Cabal also has the ability to suggest dependency version bounds that conform to-[Package Versioning Policy][PVP], which is a recommended versioning system for-publicly released Cabal packages. This is done by running the `gen-bounds`-command:--~~~~~~~~~~~~~~~~-cabal gen-bounds-~~~~~~~~~~~~~~~~--For example, given the following dependencies specified in `build-depends`:--~~~~~~~~~~~~~~~~-foo == 0.5.2-bar == 1.1-~~~~~~~~~~~~~~~~--`gen-bounds` will suggest changing them to the following:--~~~~~~~~~~~~~~~~-foo >= 0.5.2 && < 0.6-bar >= 1.1 && < 1.2-~~~~~~~~~~~~~~~~---### Executables ###--Executable sections (if present) describe executable programs contained-in the package and must have an argument after the section label, which-defines the name of the executable.  This is a freeform argument but may-not contain spaces.--The executable may be described using the following fields, as well as-build information fields (see the section on [build-information](#build-information)).--`main-is:` _filename_ (required)-:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the-    `.hs` filename that must be listed, even if that file is generated-    using a preprocessor. The source file must be relative to one of the-    directories listed in `hs-source-dirs`.--#### Running executables ####--You can have Cabal build and run your executables by using the `run` command:--~~~~~~~~~~~~~~~~-$ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS]-~~~~~~~~~~~~~~~~--This command will configure, build and run the executable `EXECUTABLE`. The-double dash separator is required to distinguish executable flags from `run`'s-own flags. If there is only one executable defined in the whole package, the-executable's name can be omitted. See the output of `cabal help run` for a list-of options you can pass to `cabal run`.---### Test suites ###--Test suite sections (if present) describe package test suites and must have an-argument after the section label, which defines the name of the test suite.-This is a freeform argument, but may not contain spaces.  It should be unique-among the names of the package's other test suites, the package's executables,-and the package itself.  Using test suite sections requires at least Cabal-version 1.9.2.--The test suite may be described using the following fields, as well as build-information fields (see the section on [build-information](#build-information)).--`type:` _interface_ (required)-:   The interface type and version of the test suite.  Cabal supports two test-    suite interfaces, called `exitcode-stdio-1.0` and `detailed-0.9`.  Each of-    these types may require or disallow other fields as described below.--Test suites using the `exitcode-stdio-1.0` interface are executables-that indicate test failure with a non-zero exit code when run; they may provide-human-readable log information through the standard output and error channels.-This interface is provided primarily for compatibility with existing test-suites; it is preferred that new test suites be written for the `detailed-0.9`-interface.  The `exitcode-stdio-1.0` type requires the `main-is` field.--`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-0.9`)-:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the-    `.hs` filename that must be listed, even if that file is generated-    using a preprocessor. The source file must be relative to one of the-    directories listed in `hs-source-dirs`.  This field is analogous to the-    `main-is` field of an executable section.--Test suites using the `detailed-0.9` interface are modules exporting the symbol-`tests :: IO [Test]`.  The `Test` type is exported by the module-`Distribution.TestSuite` provided by Cabal.  For more details, see the example below.--The `detailed-0.9` interface allows Cabal and other test agents to inspect a-test suite's results case by case, producing detailed human- and-machine-readable log files.  The `detailed-0.9` interface requires the-`test-module` field.--`test-module:` _identifier_ (required: `detailed-0.9`, disallowed: `exitcode-stdio-1.0`)-:   The module exporting the `tests` symbol.--#### Example: Package using `exitcode-stdio-1.0` interface ####--The example package description and executable source file below demonstrate-the use of the `exitcode-stdio-1.0` interface.--foo.cabal:--~~~~~~~~~~~~~~~~-Name:           foo-Version:        1.0-License:        BSD3-Cabal-Version:  >= 1.9.2-Build-Type:     Simple--Test-Suite test-foo-    type:       exitcode-stdio-1.0-    main-is:    test-foo.hs-    build-depends: base-~~~~~~~~~~~~~~~~--test-foo.hs:--~~~~~~~~~~~~~~~~-module Main where--import System.Exit (exitFailure)--main = do-    putStrLn "This test always fails!"-    exitFailure-~~~~~~~~~~~~~~~~--#### Example: Package using `detailed-0.9` interface ####--The example package description and test module source file below demonstrate-the use of the `detailed-0.9` interface.  The test module also develops a simple-implementation of the interface set by `Distribution.TestSuite`, but in actual-usage the implementation would be provided by the library that provides the-testing facility.--bar.cabal:--~~~~~~~~~~~~~~~~-Name:           bar-Version:        1.0-License:        BSD3-Cabal-Version:  >= 1.9.2-Build-Type:     Simple--Test-Suite test-bar-    type:       detailed-0.9-    test-module: Bar-    build-depends: base, Cabal >= 1.9.2-~~~~~~~~~~~~~~~~--Bar.hs:--~~~~~~~~~~~~~~~~-module Bar ( tests ) where--import Distribution.TestSuite--tests :: IO [Test]-tests = return [ Test succeeds, Test fails ]-  where-    succeeds = TestInstance-        { run = return $ Finished Pass-        , name = "succeeds"-        , tags = []-        , options = []-        , setOption = \_ _ -> Right succeeds-        }-    fails = TestInstance-        { run = return $ Finished $ Fail "Always fails!"-        , name = "fails"-        , tags = []-        , options = []-        , setOption = \_ _ -> Right fails-        }-~~~~~~~~~~~~~~~~--#### Running test suites ####--You can have Cabal run your test suites using its built-in test-runner:--~~~~~~~~~~~~~~~~-$ cabal configure --enable-tests-$ cabal build-$ cabal test-~~~~~~~~~~~~~~~~--See the output of `cabal help test` for a list of options you can pass-to `cabal test`.--### Benchmarks ###--Benchmark sections (if present) describe benchmarks contained in the package and-must have an argument after the section label, which defines the name of the-benchmark.  This is a freeform argument, but may not contain spaces.  It should-be unique among the names of the package's other benchmarks, the package's test-suites, the package's executables, and the package itself.  Using benchmark-sections requires at least Cabal version 1.9.2.--The benchmark may be described using the following fields, as well as build-information fields (see the section on [build information](#build-information)).--`type:` _interface_ (required)-:   The interface type and version of the benchmark.  At the moment Cabal only-    support one benchmark interface, called `exitcode-stdio-1.0`.--Benchmarks using the `exitcode-stdio-1.0` interface are executables that-indicate failure to run the benchmark with a non-zero exit code when run; they-may provide human-readable information through the standard output and error-channels.--`main-is:` _filename_ (required: `exitcode-stdio-1.0`)-:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that-    it is the `.hs` filename that must be listed, even if that file is generated-    using a preprocessor. The source file must be relative to one of the-    directories listed in `hs-source-dirs`.  This field is analogous to the-    `main-is` field of an executable section.--#### Example: Package using `exitcode-stdio-1.0` interface ####--The example package description and executable source file below demonstrate-the use of the `exitcode-stdio-1.0` interface.--foo.cabal:--~~~~~~~~~~~~~~~~-Name:           foo-Version:        1.0-License:        BSD3-Cabal-Version:  >= 1.9.2-Build-Type:     Simple--Benchmark bench-foo-    type:       exitcode-stdio-1.0-    main-is:    bench-foo.hs-    build-depends: base, time-~~~~~~~~~~~~~~~~--bench-foo.hs:--~~~~~~~~~~~~~~~~-{-# LANGUAGE BangPatterns #-}-module Main where--import Data.Time.Clock--fib 0 = 1-fib 1 = 1-fib n = fib (n-1) + fib (n-2)--main = do-    start <- getCurrentTime-    let !r = fib 20-    end <- getCurrentTime-    putStrLn $ "fib 20 took " ++ show (diffUTCTime end start)-~~~~~~~~~~~~~~~~--#### Running benchmarks ####--You can have Cabal run your benchmark using its built-in benchmark runner:--~~~~~~~~~~~~~~~~-$ cabal configure --enable-benchmarks-$ cabal build-$ cabal bench-~~~~~~~~~~~~~~~~--See the output of `cabal help bench` for a list of options you can-pass to `cabal bench`.--### Build information ###--The following fields may be optionally present in a library, executable, test-suite or benchmark section, and give information for the building of the-corresponding library or executable.  See also the sections on-[system-dependent parameters](#system-dependent-parameters) and-[configurations](#configurations) for a way to supply system-dependent values-for these fields.--`build-depends:` _package list_-:   A list of packages needed to build this one. Each package can be-    annotated with a version constraint.--    Version constraints use the operators `==, >=, >, <, <=` and a-    version number. Multiple constraints can be combined using `&&` or-    `||`. If no version constraint is specified, any version is assumed-    to be acceptable. For example:--    ~~~~~~~~~~~~~~~~-    library-      build-depends:-        base >= 2,-        foo >= 1.2 && < 1.3,-        bar-    ~~~~~~~~~~~~~~~~--    Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common-    because it is recommended practise for package versions to-    correspond to API versions. As of Cabal 1.6, there is a special-    syntax to support this use:--    ~~~~~~~~~~~~~~~~-    build-depends: foo ==1.2.*-    ~~~~~~~~~~~~~~~~--    It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`.--    Note: Prior to Cabal 1.8, build-depends specified in each section-    were global to all sections. This was unintentional, but some packages-    were written to depend on it, so if you need your build-depends to-    be local to each section, you must specify at least-    `Cabal-Version: >= 1.8` in your `.cabal` file.--    Note: Cabal 1.20 experimentally supported module thinning and-    renaming in `build-depends`; however, this support has since been-    removed and should not be used.--`other-modules:` _identifier list_-:   A list of modules used by the component but not exposed to users.-    For a library component, these would be hidden modules of the-    library. For an executable, these would be auxiliary modules to be-    linked with the file named in the `main-is` field.--    Note: Every module in the package *must* be listed in one of-    `other-modules`, `exposed-modules` or `main-is` fields.--`hs-source-dirs:` _directory list_ (default: "`.`")-:   Root directories for the module hierarchy.--    For backwards compatibility, the old variant `hs-source-dir` is also-    recognized.--`default-extensions:` _identifier list_-:   A list of Haskell extensions used by every module. These determine-    corresponding compiler options enabled for all files. Extension names are-    the constructors of the [Extension][extension] type. For example, `CPP`-    specifies that Haskell source files are to be preprocessed with a C-    preprocessor.--`other-extensions:` _identifier list_-:   A list of Haskell extensions used by some (but not necessarily all) modules.-    From GHC version 6.6 onward, these may be specified by placing a `LANGUAGE`-    pragma in the source files affected e.g.--    ~~~~~~~~~~~~~~~~-    {-# LANGUAGE CPP, MultiParamTypeClasses #-}-    ~~~~~~~~~~~~~~~~--    In Cabal-1.24 the dependency solver will use this and `default-extensions` information.-    Cabal prior to 1.24 will abort compilation if the current compiler doesn't provide-    the extensions.--    If you use some extensions conditionally, using CPP or conditional module lists,-    it is good to replicate the condition in `other-extensions` declarations:--    ~~~~~~~~~~~~~~~~-    other-extensions: CPP-    if impl(ghc >= 7.5)-      other-extensions: PolyKinds-    ~~~~~~~~~~~~~~~~--    You could also omit the conditionally used extensions, as they are for information only,-    but it is recommended to replicate them in `other-extensions` declarations.--`build-tools:` _program list_-:   A list of programs, possibly annotated with versions, needed to-    build this package, e.g. `c2hs >= 0.15, cpphs`.  If no version-    constraint is specified, any version is assumed to be acceptable.-    `build-tools` can refer to locally defined executables, in which-    case Cabal will make sure that executable is built first.--`buildable:` _boolean_ (default: `True`)-:   Is the component buildable? Like some of the other fields below,-    this field is more useful with the slightly more elaborate form of-    the simple build infrastructure described in the section on-    [system-dependent parameters](#system-dependent-parameters).--`ghc-options:` _token list_-:   Additional options for GHC. You can often achieve the same effect-    using the `extensions` field, which is preferred.--    Options required only by one module may be specified by placing an-    `OPTIONS_GHC` pragma in the source file affected.--    As with many other fields, whitespace can be escaped by using Haskell string-    syntax. Example: `ghc-options: -Wcompat "-with-rtsopts=-T -I1" -Wall`.--`ghc-prof-options:` _token list_-:   Additional options for GHC when the package is built with profiling-    enabled.--    Note that as of Cabal-1.24, the default profiling detail level defaults to-    `exported-functions` for libraries and `toplevel-functions` for-    executables. For GHC these correspond to the flags `-fprof-auto-exported`-    and `-fprof-auto-top`. Prior to Cabal-1.24 the level defaulted to `none`.-    These levels can be adjusted by the person building the package with the-    `--profiling-detail` and `--library-profiling-detail` flags.--    It is typically better for the person building the package to pick the-    profiling detail level rather than for the package author. So unless you-    have special needs it is probably better not to specify any of the GHC-    `-fprof-auto*` flags here. However if you wish to override the profiling-    detail level, you can do so using the `ghc-prof-options` field: use-    `-fno-prof-auto` or one of the other `-fprof-auto*` flags.---`ghc-shared-options:` _token list_-:   Additional options for GHC when the package is built as shared library.-    The options specified via this field are combined with the ones specified-    via `ghc-options`, and are passed to GHC during both the compile and-    link phases.--`includes:` _filename list_-:   A list of header files to be included in any compilations via C.-    This field applies to both header files that are already installed-    on the system and to those coming with the package to be installed.-    These files typically contain function prototypes for foreign-    imports used by the package.--`install-includes:` _filename list_-:   A list of header files from this package to be installed into-    `$libdir/includes` when the package is installed. Files listed in-    `install-includes:` should be found in relative to the top of the-    source tree or relative to one of the directories listed in-    `include-dirs`.--    `install-includes` is typically used to name header files that-    contain prototypes for foreign imports used in Haskell code in this-    package, for which the C implementations are also provided with the-    package.  Note that to include them when compiling the package-    itself, they need to be listed in the `includes:` field as well.--`include-dirs:` _directory list_-:   A list of directories to search for header files, when preprocessing-    with `c2hs`, `hsc2hs`, `cpphs` or the C preprocessor, and-    also when compiling via C.--`c-sources:` _filename list_-:   A list of C source files to be compiled and linked with the Haskell files.--`js-sources:` _filename list_-:   A list of JavaScript source files to be linked with the Haskell files-    (only for JavaScript targets).--`extra-libraries:` _token list_-:   A list of extra libraries to link with.--`extra-ghci-libraries:` _token list_-:   A list of extra libraries to be used instead of 'extra-libraries' when-    the package is loaded with GHCi.--`extra-lib-dirs:` _directory list_-:   A list of directories to search for libraries.--`cc-options:` _token list_-:   Command-line arguments to be passed to the C compiler. Since the-    arguments are compiler-dependent, this field is more useful with the-    setup described in the section on [system-dependent-    parameters](#system-dependent-parameters).--`cpp-options:` _token list_-:   Command-line arguments for pre-processing Haskell code. Applies to-    haskell source and other pre-processed Haskell source like .hsc .chs.-    Does not apply to C code, that's what cc-options is for.--`ld-options:` _token list_-:   Command-line arguments to be passed to the linker. Since the-    arguments are compiler-dependent, this field is more useful with the-    setup described in the section on [system-dependent-    parameters](#system-dependent-parameters)>.--`pkgconfig-depends:` _package list_-:   A list of [pkg-config] packages, needed to build this package.-    They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo-    >= 1.0`. If no version constraint is specified, any version is-    assumed to be acceptable. Cabal uses `pkg-config` to find if the-    packages are available on the system and to find the extra-    compilation and linker options needed to use the packages.--    If you need to bind to a C library that supports `pkg-config` (use-    `pkg-config --list-all` to find out if it is supported) then it is-    much preferable to use this field rather than hard code options into-    the other fields.--`frameworks:` _token list_-:   On Darwin/MacOS X, a list of frameworks to link to. See Apple's-    developer documentation for more details on frameworks.  This entry-    is ignored on all other platforms.--`extra-frameworks-dirs:` _directory list_-:   On Darwin/MacOS X, a list of directories to search for frameworks.-    This entry is ignored on all other platforms.--### Configurations ###--Library and executable sections may include conditional-blocks, which test for various system parameters and-configuration flags.  The flags mechanism is rather generic,-but most of the time a flag represents certain feature, that-can be switched on or off by the package user.-Here is an example package description file using-configurations:--#### Example: A package containing a library and executable programs ####--~~~~~~~~~~~~~~~~-Name: Test1-Version: 0.0.1-Cabal-Version: >= 1.2-License: BSD3-Author:  Jane Doe-Synopsis: Test package to test configurations-Category: Example--Flag Debug-  Description: Enable debug support-  Default:     False--Flag WebFrontend-  Description: Include API for web frontend.-  -- Cabal checks if the configuration is possible, first-  -- with this flag set to True and if not it tries with False--Library-  Build-Depends:   base-  Exposed-Modules: Testing.Test1-  Extensions:      CPP--  if flag(debug)-    GHC-Options: -DDEBUG-    if !os(windows)-      CC-Options: "-DDEBUG"-    else-      CC-Options: "-DNDEBUG"--  if flag(webfrontend)-    Build-Depends: cgi > 0.42-    Other-Modules: Testing.WebStuff--Executable test1-  Main-is: T1.hs-  Other-Modules: Testing.Test1-  Build-Depends: base--  if flag(debug)-    CC-Options: "-DDEBUG"-    GHC-Options: -DDEBUG-~~~~~~~~~~~~~~~~--#### Layout ####--Flags, conditionals, library and executable sections use layout to-indicate structure. This is very similar to the Haskell layout rule.-Entries in a section have to all be indented to the same level which-must be more than the section header. Tabs are not allowed to be used-for indentation.--As an alternative to using layout you can also use explicit braces `{}`.-In this case the indentation of entries in a section does not matter,-though different fields within a block must be on different lines. Here-is a bit of the above example again, using braces:--#### Example: Using explicit braces rather than indentation for layout ####--~~~~~~~~~~~~~~~~-Name: Test1-Version: 0.0.1-Cabal-Version: >= 1.2-License: BSD3-Author:  Jane Doe-Synopsis: Test package to test configurations-Category: Example--Flag Debug {-  Description: Enable debug support-  Default:     False-}--Library {-  Build-Depends:   base-  Exposed-Modules: Testing.Test1-  Extensions:      CPP-  if flag(debug) {-    GHC-Options: -DDEBUG-    if !os(windows) {-      CC-Options: "-DDEBUG"-    } else {-      CC-Options: "-DNDEBUG"-    }-  }-}-~~~~~~~~~~~~~~~~--#### Configuration Flags ####--A flag section takes the flag name as an argument and may contain the-following fields.--`description:` _freeform_-:   The description of this flag.--`default:` _boolean_ (default: `True`)-:   The default value of this flag.--    Note that this value may be [overridden in several-    ways](installing-packages.html#controlling-flag-assignments"). The-    rationale for having flags default to True is that users usually-    want new features as soon as they are available. Flags representing-    features that are not (yet) recommended for most users (such as-    experimental features or debugging support) should therefore-    explicitly override the default to False.--`manual:` _boolean_ (default: `False`)-:   By default, Cabal will first try to satisfy dependencies with the-    default flag value and then, if that is not possible, with the-    negated value. However, if the flag is manual, then the default-    value (which can be overridden by commandline flags) will be used.--#### Conditional Blocks ####--Conditional blocks may appear anywhere inside a library or executable-section.  They have to follow rather strict formatting rules.-Conditional blocks must always be of the shape--~~~~~~~~~~~~~~~~-  `if `_condition_-       _property-descriptions-or-conditionals*_-~~~~~~~~~~~~~~~~--or--~~~~~~~~~~~~~~~~-  `if `_condition_-       _property-descriptions-or-conditionals*_-  `else`-       _property-descriptions-or-conditionals*_-~~~~~~~~~~~~~~~~--Note that the `if` and the condition have to be all on the same line.--#### Conditions ####--Conditions can be formed using boolean tests and the boolean operators-`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"),-or `!` (negation / logical "not").  The unary `!` takes highest-precedence, `||` takes lowest.  Precedence levels may be overridden-through the use of parentheses. For example, `os(darwin) && !arch(i386)-|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) ||-os(freebsd)`.--The following tests are currently supported.--`os(`_name_`)`-:   Tests if the current operating system is _name_. The argument is-    tested against `System.Info.os` on the target system. There is-    unfortunately some disagreement between Haskell implementations-    about the standard values of `System.Info.os`. Cabal canonicalises-    it so that in particular `os(windows)` works on all implementations.-    If the canonicalised os names match, this test evaluates to true,-    otherwise false. The match is case-insensitive.--`arch(`_name_`)`-:   Tests if the current architecture is _name_.  The argument is-    matched against `System.Info.arch` on the target system. If the arch-    names match, this test evaluates to true, otherwise false. The match-    is case-insensitive.--`impl(`_compiler_`)`-:   Tests for the configured Haskell implementation. An optional version-    constraint may be specified (for example `impl(ghc >= 6.6.1)`). If-    the configured implementation is of the right type and matches the-    version constraint, then this evaluates to true, otherwise false.-    The match is case-insensitive.--`flag(`_name_`)`-:   Evaluates to the current assignment of the flag of the given name.-    Flag names are case insensitive. Testing for flags that have not-    been introduced with a flag section is an error.--`true`-:   Constant value true.--`false`-:   Constant value false.--#### Resolution of Conditions and Flags ####--If a package descriptions specifies configuration flags the package user can-[control these in several ways](installing-packages.html#controlling-flag-assignments).-If the user does not fix the value of a flag, Cabal will try to find a flag-assignment in the following way.--  * For each flag specified, it will assign its default value, evaluate-    all conditions with this flag assignment, and check if all-    dependencies can be satisfied.  If this check succeeded, the package-    will be configured with those flag assignments.--  * If dependencies were missing, the last flag (as by the order in-    which the flags were introduced in the package description) is tried-    with its alternative value and so on.  This continues until either-    an assignment is found where all dependencies can be satisfied, or-    all possible flag assignments have been tried.--To put it another way, Cabal does a complete backtracking search to find-a satisfiable package configuration. It is only the dependencies-specified in the `build-depends` field in conditional blocks that-determine if a particular flag assignment is satisfiable (`build-tools`-are not considered). The order of the declaration and the default value-of the flags determines the search order. Flags overridden on the-command line fix the assignment of that flag, so no backtracking will be-tried for that flag.--If no suitable flag assignment could be found, the configuration phase-will fail and a list of missing dependencies will be printed.  Note that-this resolution process is exponential in the worst case (i.e., in the-case where dependencies cannot be satisfied).  There are some-optimizations applied internally, but the overall complexity remains-unchanged.--### Meaning of field values when using conditionals ###--During the configuration phase, a flag assignment is chosen, all-conditionals are evaluated, and the package description is combined into-a flat package descriptions. If the same field both inside a conditional-and outside then they are combined using the following rules.---  * Boolean fields are combined using conjunction (logical "and").--  * List fields are combined by appending the inner items to the outer-    items, for example--    ~~~~~~~~~~~~~~~~-    other-extensions: CPP-    if impl(ghc)-      other-extensions: MultiParamTypeClasses-    ~~~~~~~~~~~~~~~~--    when compiled using GHC will be combined to--    ~~~~~~~~~~~~~~~~-    other-extensions: CPP, MultiParamTypeClasses-    ~~~~~~~~~~~~~~~~--    Similarly, if two conditional sections appear at the same nesting-    level, properties specified in the latter will come after properties-    specified in the former.--  * All other fields must not be specified in ambiguous ways. For-    example--    ~~~~~~~~~~~~~~~~-    Main-is: Main.hs-    if flag(useothermain)-      Main-is: OtherMain.hs-    ~~~~~~~~~~~~~~~~--    will lead to an error.  Instead use--    ~~~~~~~~~~~~~~~~-    if flag(useothermain)-      Main-is: OtherMain.hs-    else-      Main-is: Main.hs-    ~~~~~~~~~~~~~~~~--### Source Repositories ###--It is often useful to be able to specify a source revision control-repository for a package. Cabal lets you specifying this information in-a relatively structured form which enables other tools to interpret and-make effective use of the information. For example the information-should be sufficient for an automatic tool to checkout the sources.--Cabal supports specifying different information for various common-source control systems. Obviously not all automated tools will support-all source control systems.--Cabal supports specifying repositories for different use cases. By-declaring which case we mean automated tools can be more useful. There-are currently two kinds defined:-- *  The `head` kind refers to the latest development branch of the-    package. This may be used for example to track activity of a project-    or as an indication to outside developers what sources to get for-    making new contributions.-- *  The `this` kind refers to the branch and tag of a repository that-    contains the sources for this version or release of a package. For most-    source control systems this involves specifying a tag, id or hash of-    some form and perhaps a branch. The purpose is to be able to-    reconstruct the sources corresponding to a particular package-    version. This might be used to indicate what sources to get if-    someone needs to fix a bug in an older branch that is no longer an-    active head branch.--You can specify one kind or the other or both. As an example here are-the repositories for the Cabal library. Note that the `this` kind of-repository specifies a tag.--~~~~~~~~~~~~~~~~-source-repository head-  type:     darcs-  location: http://darcs.haskell.org/cabal/--source-repository this-  type:     darcs-  location: http://darcs.haskell.org/cabal-branches/cabal-1.6/-  tag:      1.6.1-~~~~~~~~~~~~~~~~--The exact fields are as follows:--`type:` _token_-:   The name of the source control system used for this repository. The-    currently recognised types are:--    * `darcs`-    * `git`-    * `svn`-    * `cvs`-    * `mercurial` (or alias `hg`)-    * `bazaar` (or alias `bzr`)-    * `arch`-    * `monotone`--    This field is required.--`location:` _URL_-:   The location of the repository. The exact form of this field depends-    on the repository type. For example:--    * for darcs: `http://code.haskell.org/foo/`-    * for git: `git://github.com/foo/bar.git`-    * for CVS: `anoncvs@cvs.foo.org:/cvs`--    This field is required.--`module:` _token_-:   CVS requires a named module, as each CVS server can host multiple-    named repositories.--    This field is required for the CVS repository type and should not-    be used otherwise.--`branch:` _token_-:   Many source control systems support the notion of a branch, as a-    distinct concept from having repositories in separate locations. For-    example CVS, SVN and git use branches while for darcs uses different-    locations for different branches. If you need to specify a branch to-    identify a your repository then specify it in this field.--    This field is optional.--`tag:` _token_-:   A tag identifies a particular state of a source repository. The tag-    can be used with a `this` repository kind to identify the state of-    a repository corresponding to a particular package version or-    release. The exact form of the tag depends on the repository type.--    This field is required for the `this` repository kind.--`subdir:` _directory_-:   Some projects put the sources for multiple packages under a single-    source repository. This field lets you specify the relative path-    from the root of the repository to the top directory for the-    package, i.e. the directory containing the package's `.cabal` file.--    This field is optional. It default to empty which corresponds to the-    root directory of the repository.--### Downloading a package's source ###--The `cabal get` command allows to access a package's source code - either by-unpacking a tarball downloaded from Hackage (the default) or by checking out a-working copy from the package's source repository.--~~~~~~~~~~~~~~~~-$ cabal get [FLAGS] PACKAGES-~~~~~~~~~~~~~~~~--The `get` command supports the following options:--`-d --destdir` _PATH_-:   Where to place the package source, defaults to (a subdirectory of) the-    current directory.--`-s --source-repository` _[head|this|...]_-:   Fork the package's source repository using the appropriate version control-    system. The optional argument allows to choose a specific repository kind.---## Accessing data files from package code ##--The placement on the target system of files listed in the `data-files`-field varies between systems, and in some cases one can even move-packages around after installation (see [prefix-independence](installing-packages.html#prefix-independence)). To enable-packages to find these files in a portable way, Cabal generates a module-called `Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by-underscores) during building, so that it may be imported by modules of-the package.  This module defines a function--~~~~~~~~~~~~~~~-getDataFileName :: FilePath -> IO FilePath-~~~~~~~~~~~~~~~--If the argument is a filename listed in the `data-files` field, the-result is the name of the corresponding file on the system on which the-program is running.--Note: If you decide to import the `Paths_`_pkgname_ module then it-*must* be listed in the `other-modules` field just like any other module-in your package.--The `Paths_`_pkgname_ module is not platform independent so it does not-get included in the source tarballs generated by `sdist`.--The `Paths_`_pkgname_ module also includes some other useful functions-and values, which record the version of the package and some other-directories which the package has been configured to be installed-into (e.g. data files live in `getDataDir`):--~~~~~~~~~~~~~~~-version :: Version--getBinDir :: IO FilePath-getLibDir :: IO FilePath-getDataDir :: IO FilePath-getLibexecDir :: IO FilePath-getSysconfDir :: IO FilePath-~~~~~~~~~~~~~~~--### Accessing the package version ###--The aforementioned auto generated `Paths_`_pkgname_ module also-exports the constant `version ::` [Version][data-version] which is-defined as the version of your package as specified in the `version`-field.--## System-dependent parameters ##--For some packages, especially those interfacing with C libraries,-implementation details and the build procedure depend on the build-environment. The `build-type` `Configure` can be used to handle many-such situations. In this case, `Setup.hs` should be:--~~~~~~~~~~~~~~~~-import Distribution.Simple-main = defaultMainWithHooks autoconfUserHooks-~~~~~~~~~~~~~~~~--Most packages, however, would probably do better using the `Simple`-build type and [configurations](#configurations).--The `build-type` `Configure` differs from `Simple` in two ways:--* The package root directory must contain a shell script called-  `configure`. The configure step will run the script. This `configure`-  script may be produced by [autoconf][] or may be hand-written. The-  `configure` script typically discovers information about the system-  and records it for later steps, e.g. by generating system-dependent-  header files for inclusion in C source files and preprocessed Haskell-  source files. (Clearly this won't work for Windows without MSYS or-  Cygwin: other ideas are needed.)--* If the package root directory contains a file called-  _package_`.buildinfo` after the configuration step, subsequent steps-  will read it to obtain additional settings for [build-  information](#build-information) fields,to be merged with the ones-  given in the `.cabal` file. In particular, this file may be generated-  by the `configure` script mentioned above, allowing these settings to-  vary depending on the build environment.--  The build information file should have the following structure:--  > _buildinfo_-  >-  > `executable:` _name_-  > _buildinfo_-  >-  > `executable:` _name_-  > _buildinfo_-  > ...--  where each _buildinfo_ consists of settings of fields listed in the-  section on [build information](#build-information). The first one (if-  present) relates to the library, while each of the others relate to-  the named executable.  (The names must match the package description,-  but you don't have to have entries for all of them.)--Neither of these files is required.  If they are absent, this setup-script is equivalent to `defaultMain`.--#### Example: Using autoconf ####--This example is for people familiar with the [autoconf][] tools.--In the X11 package, the file `configure.ac` contains:--~~~~~~~~~~~~~~~~-AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11])--# Safety check: Ensure that we are in the correct source directory.-AC_CONFIG_SRCDIR([X11.cabal])--# Header file to place defines in-AC_CONFIG_HEADERS([include/HsX11Config.h])--# Check for X11 include paths and libraries-AC_PATH_XTRA-AC_TRY_CPP([#include <X11/Xlib.h>],,[no_x=yes])--# Build the package if we found X11 stuff-if test "$no_x" = yes-then BUILD_PACKAGE_BOOL=False-else BUILD_PACKAGE_BOOL=True-fi-AC_SUBST([BUILD_PACKAGE_BOOL])--AC_CONFIG_FILES([X11.buildinfo])-AC_OUTPUT-~~~~~~~~~~~~~~~~--Then the setup script will run the `configure` script, which checks for-the presence of the X11 libraries and substitutes for variables in the-file `X11.buildinfo.in`:--~~~~~~~~~~~~~~~~-buildable: @BUILD_PACKAGE_BOOL@-cc-options: @X_CFLAGS@-ld-options: @X_LIBS@-~~~~~~~~~~~~~~~~--This generates a file `X11.buildinfo` supplying the parameters needed by-later stages:--~~~~~~~~~~~~~~~~-buildable: True-cc-options:  -I/usr/X11R6/include-ld-options:  -L/usr/X11R6/lib-~~~~~~~~~~~~~~~~--The `configure` script also generates a header file `include/HsX11Config.h`-containing C preprocessor defines recording the results of various tests.  This-file may be included by C source files and preprocessed Haskell source files in-the package.--Note: Packages using these features will also need to list additional files such-as `configure`, templates for `.buildinfo` files, files named only in-`.buildinfo` files, header files and so on in the `extra-source-files` field to-ensure that they are included in source distributions.  They should also list-files and directories generated by `configure` in the `extra-tmp-files` field to-ensure that they are removed by `setup clean`.--Quite often the files generated by `configure` need to be listed somewhere in-the package description (for example, in the `install-includes` field). However,-we usually don't want generated files to be included in the source tarball. The-solution is again provided by the `.buildinfo` file. In the above example, the-following line should be added to `X11.buildinfo`:--~~~~~~~~~~~~~~~~-install-includes: HsX11Config.h-~~~~~~~~~~~~~~~~--In this way, the generated `HsX11Config.h` file won't be included in the source-tarball in addition to `HsX11Config.h.in`, but it will be copied to the right-location during the install process. Packages that use custom `Setup.hs` scripts-can update the necessary fields programmatically instead of using the-`.buildinfo` file.---## Conditional compilation ##--Sometimes you want to write code that works with more than one version-of a dependency.  You can specify a range of versions for the dependency-in the `build-depends`, but how do you then write the code that can use-different versions of the API?--Haskell lets you preprocess your code using the C preprocessor (either-the real C preprocessor, or `cpphs`).  To enable this, add `extensions:-CPP` to your package description.  When using CPP, Cabal provides some-pre-defined macros to let you test the version of dependent packages;-for example, suppose your package works with either version 3 or version-4 of the `base` package, you could select the available version in your-Haskell modules like this:--~~~~~~~~~~~~~~~~-#if MIN_VERSION_base(4,0,0)-... code that works with base-4 ...-#else-... code that works with base-3 ...-#endif-~~~~~~~~~~~~~~~~--In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)`-for each package depended on via `build-depends`. This macro is true if-the actual version of the package in use is greater than or equal to-`A.B.C` (using the conventional ordering on version numbers, which is-lexicographic on the sequence, but numeric on each component, so for-example 1.2.0 is greater than 1.0.3).--Since version 1.20, there is also the `MIN_TOOL_VERSION_`_`tool`_ family of-macros for conditioning on the version of build tools used to build the program-(e.g. `hsc2hs`).--Cabal places the definitions of these macros into an-automatically-generated header file, which is included when-preprocessing Haskell source code by passing options to the C-preprocessor.--Cabal also allows to detect when the source code is being used for generating-documentation. The `__HADDOCK_VERSION__` macro is defined only when compiling-via [haddock][] instead of a normal Haskell compiler. The value of the-`__HADDOCK_VERSION__` macro is defined as `A*1000 + B*10 + C`, where `A.B.C` is-the Haddock version. This can be useful for working around bugs in Haddock or-generating prettier documentation in some special cases.--## More complex packages ##--For packages that don't fit the simple schemes described above, you have-a few options:--  * By using the `build-type` `Custom`, you can supply your own-    `Setup.hs` file, and customize the simple build infrastructure-    using _hooks_.  These allow you to perform additional actions-    before and after each command is run, and also to specify-    additional preprocessors. A typical `Setup.hs` may look like this:--    ~~~~~~~~~~~~~~~~-    import Distribution.Simple-    main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock }--    posthaddock args flags desc info = ....-    ~~~~~~~~~~~~~~~~--    See `UserHooks` in [Distribution.Simple][dist-simple] for the-    details, but note that this interface is experimental, and likely-    to change in future releases.--  * You could delegate all the work to `make`, though this is unlikely-    to be very portable. Cabal supports this with the `build-type`-    `Make` and a trivial setup library [Distribution.Make][dist-make],-    which simply parses the command line arguments and invokes `make`.-    Here `Setup.hs` should look like this:--    ~~~~~~~~~~~~~~~~-    import Distribution.Make-    main = defaultMain-    ~~~~~~~~~~~~~~~~--    The root directory of the package should contain a `configure`-    script, and, after that has run, a `Makefile` with a default target-    that builds the package, plus targets `install`, `register`,-    `unregister`, `clean`, `dist` and `docs`. Some options to commands-    are passed through as follows:--      * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir`,-        `--libexecdir` and `--sysconfdir` options to the `configure` command are-        passed on to the `configure` script. In addition the value of the-        `--with-compiler` option is passed in a `--with-hc` option and all-        options specified with `--configure-option=` are passed on.--      * The `--destdir` option to the `copy` command becomes a setting-        of a `destdir` variable on the invocation of `make copy`. The-        supplied `Makefile` should provide a `copy` target, which will-        probably look like this:--        ~~~~~~~~~~~~~~~~-        copy :-                $(MAKE) install prefix=$(destdir)/$(prefix) \-                                bindir=$(destdir)/$(bindir) \-                                libdir=$(destdir)/$(libdir) \-                                datadir=$(destdir)/$(datadir) \-                                libexecdir=$(destdir)/$(libexecdir) \-                                sysconfdir=$(destdir)/$(sysconfdir) \-        ~~~~~~~~~~~~~~~~--  * Finally, with the `build-type` `Custom`, you can also write your-    own setup script from scratch. It must conform to the interface-    described in the section on [building and installing-    packages](installing-packages.html), and you may use the Cabal-    library for all or part of the work.  One option is to copy the-    source of `Distribution.Simple`, and alter it for your needs. Good-    luck.----[dist-simple]:  ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html-[dist-make]:    ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html-[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License-[extension]:    ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType-[data-version]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Version.html-[alex]:       http://www.haskell.org/alex/-[autoconf]:   http://www.gnu.org/software/autoconf/-[c2hs]:       http://www.cse.unsw.edu.au/~chak/haskell/c2hs/-[cpphs]:      http://projects.haskell.org/cpphs/-[greencard]:  http://hackage.haskell.org/package/greencard-[haddock]:    http://www.haskell.org/haddock/-[HsColour]:   http://www.cs.york.ac.uk/fp/darcs/hscolour/-[happy]:      http://www.haskell.org/happy/-[Hackage]:    http://hackage.haskell.org/-[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/-[REPL]:       http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop-[PVP]:        https://wiki.haskell.org/Package_versioning_policy
+ cabal/Cabal/doc/developing-packages.rst view
@@ -0,0 +1,2675 @@+Quickstart+==========++Lets assume we have created a project directory and already have a+Haskell module or two.++Every project needs a name, we'll call this example "proglet".++.. highlight:: console++::++    $ cd proglet/+    $ ls+    Proglet.hs++It is assumed that (apart from external dependencies) all the files that+make up a package live under a common project root directory. This+simple example has all the project files in one directory, but most+packages will use one or more subdirectories.++To turn this into a Cabal package we need two extra files in the+project's root directory:++-  ``proglet.cabal``: containing package metadata and build information.++-  ``Setup.hs``: usually containing a few standardized lines of code,+   but can be customized if necessary.++We can create both files manually or we can use ``cabal init`` to create+them for us.++Using "cabal init"+------------------++The ``cabal init`` command is interactive. It asks us a number of+questions starting with the package name and version.++::++    $ cabal init+    Package name [default "proglet"]?+    Package version [default "0.1"]?+    ...++It also asks questions about various other bits of package metadata. For+a package that you never intend to distribute to others, these fields+can be left blank.++One of the important questions is whether the package contains a library+or an executable. Libraries are collections of Haskell modules that can+be re-used by other Haskell libraries and programs, while executables+are standalone programs.++::++    What does the package build:+       1) Library+       2) Executable+    Your choice?++For the moment these are the only choices. For more complex packages+(e.g. a library and multiple executables or test suites) the ``.cabal``+file can be edited afterwards.++Finally, ``cabal init`` creates the initial ``proglet.cabal`` and+``Setup.hs`` files, and depending on your choice of license, a+``LICENSE`` file as well.++::++    Generating LICENSE...+    Generating Setup.hs...+    Generating proglet.cabal...++    You may want to edit the .cabal file and add a Description field.++As this stage the ``proglet.cabal`` is not quite complete and before you+are able to build the package you will need to edit the file and add+some build information about the library or executable.++Editing the .cabal file+-----------------------++.. highlight:: cabal++Load up the ``.cabal`` file in a text editor. The first part of the+``.cabal`` file has the package metadata and towards the end of the file+you will find the :pkg-section:`executable` or :pkg-section:`library` section.++You will see that the fields that have yet to be filled in are commented+out. Cabal files use "``--``" Haskell-style comment syntax. (Note that+comments are only allowed on lines on their own. Trailing comments on+other lines are not allowed because they could be confused with program+options.)++If you selected earlier to create a library package then your ``.cabal``+file will have a section that looks like this:++::++    library+      exposed-modules:     Proglet+      -- other-modules:+      -- build-depends:++Alternatively, if you selected an executable then there will be a+section like:++::++    executable proglet+      -- main-is:+      -- other-modules:+      -- build-depends:++The build information fields listed (but commented out) are just the few+most important and common fields. There are many others that are covered+later in this chapter.++Most of the build information fields are the same between libraries and+executables. The difference is that libraries have a number of "exposed"+modules that make up the public interface of the library, while+executables have a file containing a ``Main`` module.++The name of a library always matches the name of the package, so it is+not specified in the library section. Executables often follow the name+of the package too, but this is not required and the name is given+explicitly.++Modules included in the package+-------------------------------++For a library, ``cabal init`` looks in the project directory for files+that look like Haskell modules and adds all the modules to the+:pkg-field:`library:exposed-modules` field. For modules that do not form part+of your package's public interface, you can move those modules to the+:pkg-field:`other-modules` field. Either way, all modules in the library need+to be listed.++For an executable, ``cabal init`` does not try to guess which file+contains your program's ``Main`` module. You will need to fill in the+:pkg-field:`executable:main-is` field with the file name of your program's+``Main`` module (including ``.hs`` or ``.lhs`` extension). Other modules+included in the executable should be listed in the :pkg-field:`other-modules`+field.++Modules imported from other packages+------------------------------------++While your library or executable may include a number of modules, it+almost certainly also imports a number of external modules from the+standard libraries or other pre-packaged libraries. (These other+libraries are of course just Cabal packages that contain a library.)++You have to list all of the library packages that your library or+executable imports modules from. Or to put it another way: you have to+list all the other packages that your package depends on.++For example, suppose the example ``Proglet`` module imports the module+``Data.Map``. The ``Data.Map`` module comes from the ``containers``+package, so we must list it:++::++    library+      exposed-modules:     Proglet+      other-modules:+      build-depends:       containers, base == 4.*++In addition, almost every package also depends on the ``base`` library+package because it exports the standard ``Prelude`` module plus other+basic modules like ``Data.List``.++You will notice that we have listed ``base == 4.*``. This gives a+constraint on the version of the base package that our package will work+with. The most common kinds of constraints are:++-  ``pkgname >= n``+-  ``pkgname >= n && < m``+-  ``pkgname == n.*``++The last is just shorthand, for example ``base == 4.*`` means exactly+the same thing as ``base >= 4 && < 5``.++Building the package+--------------------++For simple packages that's it! We can now try configuring and building+the package:++.. code-block:: console++    $ cabal configure+    $ cabal build++Assuming those two steps worked then you can also install the package:++.. code-block:: console++    $ cabal install++For libraries this makes them available for use in GHCi or to be used by+other packages. For executables it installs the program so that you can+run it (though you may first need to adjust your system's ``$PATH``).++Next steps+----------++What we have covered so far should be enough for very simple packages+that you use on your own system.++The next few sections cover more details needed for more complex+packages and details needed for distributing packages to other people.++The previous chapter covers building and installing packages -- your own+packages or ones developed by other people.++Package concepts+================++Before diving into the details of writing packages it helps to+understand a bit about packages in the Haskell world and the particular+approach that Cabal takes.++The point of packages+---------------------++Packages are a mechanism for organising and distributing code. Packages+are particularly suited for "programming in the large", that is building+big systems by using and re-using code written by different people at+different times.++People organise code into packages based on functionality and+dependencies. Social factors are also important: most packages have a+single author, or a relatively small team of authors.++Packages are also used for distribution: the idea is that a package can+be created in one place and be moved to a different computer and be+usable in that different environment. There are a surprising number of+details that have to be got right for this to work, and a good package+system helps to simply this process and make it reliable.++Packages come in two main flavours: libraries of reusable code, and+complete programs. Libraries present a code interface, an API, while+programs can be run directly. In the Haskell world, library packages+expose a set of Haskell modules as their public interface. Cabal+packages can contain a library or executables or both.++Some programming languages have packages as a builtin language concept.+For example in Java, a package provides a local namespace for types and+other definitions. In the Haskell world, packages are not a part of the+language itself. Haskell programs consist of a number of modules, and+packages just provide a way to partition the modules into sets of+related functionality. Thus the choice of module names in Haskell is+still important, even when using packages.++Package names and versions+--------------------------++All packages have a name, e.g. "HUnit". Package names are assumed to be+unique. Cabal package names may contain letters, numbers and hyphens,+but not spaces and may also not contain a hyphened section consisting of+only numbers. The namespace for Cabal packages is flat, not+hierarchical.++Packages also have a version, e.g "1.1". This matches the typical way in+which packages are developed. Strictly speaking, each version of a+package is independent, but usually they are very similar. Cabal package+versions follow the conventional numeric style, consisting of a sequence+of digits such as "1.0.1" or "2.0". There are a range of common+conventions for "versioning" packages, that is giving some meaning to+the version number in terms of changes in the package. Section [TODO]+has some tips on package versioning.++The combination of package name and version is called the *package ID*+and is written with a hyphen to separate the name and version, e.g.+"HUnit-1.1".++For Cabal packages, the combination of the package name and version+*uniquely* identifies each package. Or to put it another way: two+packages with the same name and version are considered to *be* the same.++Strictly speaking, the package ID only identifies each Cabal *source*+package; the same Cabal source package can be configured and built in+different ways. There is a separate installed package ID that uniquely+identifies each installed package instance. Most of the time however,+users need not be aware of this detail.++Kinds of package: Cabal vs GHC vs system+----------------------------------------++It can be slightly confusing at first because there are various+different notions of package floating around. Fortunately the details+are not very complicated.++Cabal packages+    Cabal packages are really source packages. That is they contain+    Haskell (and sometimes C) source code.++    Cabal packages can be compiled to produce GHC packages. They can+    also be translated into operating system packages.++GHC packages+    This is GHC's view on packages. GHC only cares about library+    packages, not executables. Library packages have to be registered+    with GHC for them to be available in GHCi or to be used when+    compiling other programs or packages.++    The low-level tool ``ghc-pkg`` is used to register GHC packages and+    to get information on what packages are currently registered.++    You never need to make GHC packages manually. When you build and+    install a Cabal package containing a library then it gets registered+    with GHC automatically.++    Haskell implementations other than GHC have essentially the same+    concept of registered packages. For the most part, Cabal hides the+    slight differences.++Operating system packages+    On operating systems like Linux and Mac OS X, the system has a+    specific notion of a package and there are tools for installing and+    managing packages.++    The Cabal package format is designed to allow Cabal packages to be+    translated, mostly-automatically, into operating system packages.+    They are usually translated 1:1, that is a single Cabal package+    becomes a single system package.++    It is also possible to make Windows installers from Cabal packages,+    though this is typically done for a program together with all of its+    library dependencies, rather than packaging each library separately.++Unit of distribution+--------------------++The Cabal package is the unit of distribution. What this means is that+each Cabal package can be distributed on its own in source or binary+form. Of course there may dependencies between packages, but there is+usually a degree of flexibility in which versions of packages can work+together so distributing them independently makes sense.++It is perhaps easiest to see what being "the unit of distribution"+means by contrast to an alternative approach. Many projects are made up+of several interdependent packages and during development these might+all be kept under one common directory tree and be built and tested+together. When it comes to distribution however, rather than+distributing them all together in a single tarball, it is required that+they each be distributed independently in their own tarballs.++Cabal's approach is to say that if you can specify a dependency on a+package then that package should be able to be distributed+independently. Or to put it the other way round, if you want to+distribute it as a single unit, then it should be a single package.++Explicit dependencies and automatic package management+------------------------------------------------------++Cabal takes the approach that all packages dependencies are specified+explicitly and specified in a declarative way. The point is to enable+automatic package management. This means tools like ``cabal`` can+resolve dependencies and install a package plus all of its dependencies+automatically. Alternatively, it is possible to mechanically (or mostly+mechanically) translate Cabal packages into system packages and let the+system package manager install dependencies automatically.++It is important to track dependencies accurately so that packages can+reliably be moved from one system to another system and still be able to+build it there. Cabal is therefore relatively strict about specifying+dependencies. For example Cabal's default build system will not even let+code build if it tries to import a module from a package that isn't+listed in the ``.cabal`` file, even if that package is actually+installed. This helps to ensure that there are no "untracked+dependencies" that could cause the code to fail to build on some other+system.++The explicit dependency approach is in contrast to the traditional+"./configure" approach where instead of specifying dependencies+declaratively, the ``./configure`` script checks if the dependencies are+present on the system. Some manual work is required to transform a+``./configure`` based package into a Linux distribution package (or+similar). This conversion work is usually done by people other than the+package author(s). The practical effect of this is that only the most+popular packages will benefit from automatic package management.+Instead, Cabal forces the original author to specify the dependencies+but the advantage is that every package can benefit from automatic+package management.++The "./configure" approach tends to encourage packages that adapt+themselves to the environment in which they are built, for example by+disabling optional features so that they can continue to work when a+particular dependency is not available. This approach makes sense in a+world where installing additional dependencies is a tiresome manual+process and so minimising dependencies is important. The automatic+package management view is that packages should just declare what they+need and the package manager will take responsibility for ensuring that+all the dependencies are installed.++Sometimes of course optional features and optional dependencies do make+sense. Cabal packages can have optional features and varying+dependencies. These conditional dependencies are still specified in a+declarative way however and remain compatible with automatic package+management. The need to remain compatible with automatic package+management means that Cabal's conditional dependencies system is a bit+less flexible than with the "./configure" approach.++Portability+-----------++One of the purposes of Cabal is to make it easier to build packages on+different platforms (operating systems and CPU architectures), with+different compiler versions and indeed even with different Haskell+implementations. (Yes, there are Haskell implementations other than+GHC!)++Cabal provides abstractions of features present in different Haskell+implementations and wherever possible it is best to take advantage of+these to increase portability. Where necessary however it is possible to+use specific features of specific implementations.++For example a package author can list in the package's ``.cabal`` what+language extensions the code uses. This allows Cabal to figure out if+the language extension is supported by the Haskell implementation that+the user picks. Additionally, certain language extensions such as+Template Haskell require special handling from the build system and by+listing the extension it provides the build system with enough+information to do the right thing.++Another similar example is linking with foreign libraries. Rather than+specifying GHC flags directly, the package author can list the libraries+that are needed and the build system will take care of using the right+flags for the compiler. Additionally this makes it easier for tools to+discover what system C libraries a package needs, which is useful for+tracking dependencies on system libraries (e.g. when translating into+Linux distribution packages).++In fact both of these examples fall into the category of explicitly+specifying dependencies. Not all dependencies are other Cabal packages.+Foreign libraries are clearly another kind of dependency. It's also+possible to think of language extensions as dependencies: the package+depends on a Haskell implementation that supports all those extensions.++Where compiler-specific options are needed however, there is an "escape+hatch" available. The developer can specify implementation-specific+options and more generally there is a configuration mechanism to+customise many aspects of how a package is built depending on the+Haskell implementation, the operating system, computer architecture and+user-specified configuration flags.++Developing packages+===================++The Cabal package is the unit of distribution. When installed, its+purpose is to make available:++-  One or more Haskell programs.++-  At most one library, exposing a number of Haskell modules.++However having both a library and executables in a package does not work+very well; if the executables depend on the library, they must+explicitly list all the modules they directly or indirectly import from+that library. Fortunately, starting with Cabal 1.8.0.4, executables can+also declare the package that they are in as a dependency, and Cabal+will treat them as if they were in another package that depended on the+library.++Internally, the package may consist of much more than a bunch of Haskell+modules: it may also have C source code and header files, source code+meant for preprocessing, documentation, test cases, auxiliary tools etc.++A package is identified by a globally-unique *package name*, which+consists of one or more alphanumeric words separated by hyphens. To+avoid ambiguity, each of these words should contain at least one letter.+Chaos will result if two distinct packages with the same name are+installed on the same system. A particular version of the package is+distinguished by a *version number*, consisting of a sequence of one or+more integers separated by dots. These can be combined to form a single+text string called the *package ID*, using a hyphen to separate the name+from the version, e.g. "``HUnit-1.1``".++.. Note::++   Packages are not part of the Haskell language; they simply+   populate the hierarchical space of module names. In GHC 6.6 and later a+   program may contain multiple modules with the same name if they come+   from separate packages; in all other current Haskell systems packages+   may not overlap in the modules they provide, including hidden modules.++Creating a package+------------------++Suppose you have a directory hierarchy containing the source files that+make up your package. You will need to add two more files to the root+directory of the package:++:file:`{package}.cabal`+    a Unicode UTF-8 text file containing a package description. For+    details of the syntax of this file, see the section on+    `package descriptions`_.++:file:`Setup.hs`+    a single-module Haskell program to perform various setup tasks (with+    the interface described in the section on :ref:`installing-packages`).+    This module should import only modules that will be present in all Haskell+    implementations, including modules of the Cabal library. The content of+    this file is determined by the :pkg-field:`build-type` setting in the+    ``.cabal`` file. In most cases it will be trivial, calling on the Cabal+    library to do most of the work.++Once you have these, you can create a source bundle of this directory+for distribution. Building of the package is discussed in the section on+:ref:`installing-packages`.++One of the purposes of Cabal is to make it easier to build a package+with different Haskell implementations. So it provides abstractions of+features present in different Haskell implementations and wherever+possible it is best to take advantage of these to increase portability.+Where necessary however it is possible to use specific features of+specific implementations. For example one of the pieces of information a+package author can put in the package's ``.cabal`` file is what language+extensions the code uses. This is far preferable to specifying flags for+a specific compiler as it allows Cabal to pick the right flags for the+Haskell implementation that the user picks. It also allows Cabal to+figure out if the language extension is even supported by the Haskell+implementation that the user picks. Where compiler-specific options are+needed however, there is an "escape hatch" available. The developer can+specify implementation-specific options and more generally there is a+configuration mechanism to customise many aspects of how a package is+built depending on the Haskell implementation, the Operating system,+computer architecture and user-specified configuration flags.++::++    name:     Foo+    version:  1.0++    library+      build-depends:   base+      exposed-modules: Foo+      extensions:      ForeignFunctionInterface+      ghc-options:     -Wall+      if os(windows)+        build-depends: Win32++Example: A package containing a simple library+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++The HUnit package contains a file ``HUnit.cabal`` containing:++::++    name:           HUnit+    version:        1.1.1+    synopsis:       A unit testing framework for Haskell+    homepage:       http://hunit.sourceforge.net/+    category:       Testing+    author:         Dean Herington+    license:        BSD3+    license-file:   LICENSE+    cabal-version:  >= 1.10+    build-type:     Simple++    library+      build-depends:      base >= 2 && < 4+      exposed-modules:    Test.HUnit.Base, Test.HUnit.Lang,+                          Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit+      default-extensions: CPP++and the following ``Setup.hs``:++.. code-block:: haskell++    import Distribution.Simple+    main = defaultMain++Example: A package containing executable programs+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++::++    name:           TestPackage+    version:        0.0+    synopsis:       Small package with two programs+    author:         Angela Author+    license:        BSD3+    build-type:     Simple+    cabal-version:  >= 1.2++    executable program1+      build-depends:  HUnit+      main-is:        Main.hs+      hs-source-dirs: prog1++    executable program2+      main-is:        Main.hs+      build-depends:  HUnit+      hs-source-dirs: prog2+      other-modules:  Utils++with ``Setup.hs`` the same as above.++Example: A package containing a library and executable programs+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++::++    name:            TestPackage+    version:         0.0+    synopsis:        Package with library and two programs+    license:         BSD3+    author:          Angela Author+    build-type:      Simple+    cabal-version:   >= 1.2++    library+      build-depends:   HUnit+      exposed-modules: A, B, C++    executable program1+      main-is:         Main.hs+      hs-source-dirs:  prog1+      other-modules:   A, B++    executable program2+      main-is:         Main.hs+      hs-source-dirs:  prog2+      other-modules:   A, C, Utils++with ``Setup.hs`` the same as above. Note that any library modules+required (directly or indirectly) by an executable must be listed again.++The trivial setup script used in these examples uses the *simple build+infrastructure* provided by the Cabal library (see+`Distribution.Simple <../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html>`__).+The simplicity lies in its interface rather that its implementation. It+automatically handles preprocessing with standard preprocessors, and+builds packages for all the Haskell implementations.++The simple build infrastructure can also handle packages where building+is governed by system-dependent parameters, if you specify a little more+(see the section on `system-dependent parameters`_).+A few packages require `more elaborate solutions <more complex packages>`_.++Package descriptions+--------------------++The package description file must have a name ending in "``.cabal``". It+must be a Unicode text file encoded using valid UTF-8. There must be+exactly one such file in the directory. The first part of the name is+usually the package name, and some of the tools that operate on Cabal+packages require this.++In the package description file, lines whose first non-whitespace+characters are "``--``" are treated as comments and ignored.++This file should contain of a number global property descriptions and+several sections.++-  The `package properties`_ describe the package+   as a whole, such as name, license, author, etc.++-  Optionally, a number of *configuration flags* can be declared. These+   can be used to enable or disable certain features of a package. (see+   the section on `configurations`_).++-  The (optional) library section specifies the `library`_ properties and+   relevant `build information`_.++-  Following is an arbitrary number of executable sections which describe+   an executable program and relevant `build information`_.++Each section consists of a number of property descriptions in the form+of field/value pairs, with a syntax roughly like mail message headers.++-  Case is not significant in field names, but is significant in field+   values.++-  To continue a field value, indent the next line relative to the field+   name.++-  Field names may be indented, but all field values in the same section+   must use the same indentation.++-  Tabs are *not* allowed as indentation characters due to a missing+   standard interpretation of tab width.++-  To get a blank line in a field value, use an indented "``.``"++The syntax of the value depends on the field. Field types include:++*token*, *filename*, *directory*+    Either a sequence of one or more non-space non-comma characters, or+    a quoted string in Haskell 98 lexical syntax. The latter can be used+    for escaping whitespace, for example:+    ``ghc-options: -Wall "-with-rtsopts=-T -I1"``. Unless otherwise+    stated, relative filenames and directories are interpreted from the+    package root directory.+*freeform*, *URL*, *address*+    An arbitrary, uninterpreted string.+*identifier*+    A letter followed by zero or more alphanumerics or underscores.+*compiler*+    A compiler flavor (one of: ``GHC``, ``JHC``, ``UHC`` or ``LHC``)+    followed by a version range. For example, ``GHC ==6.10.3``, or+    ``LHC >=0.6 && <0.8``.++Modules and preprocessors+^^^^^^^^^^^^^^^^^^^^^^^^^++Haskell module names listed in the :pkg-field:`library:exposed-modules` and+:pkg-field:`library:other-modules` fields may correspond to Haskell source+files, i.e. with names ending in "``.hs``" or "``.lhs``", or to inputs for+various Haskell preprocessors. The simple build infrastructure understands the+extensions:++-  ``.gc`` (:hackage-pkg:`greencard`)+-  ``.chs`` (:hackage-pkg:`c2hs`)+-  ``.hsc`` (:hackage-pkg:`hsc2hs`)+-  ``.y`` and ``.ly`` (happy_)+-  ``.x`` (alex_)+-  ``.cpphs`` (cpphs_)++When building, Cabal will automatically run the appropriate preprocessor+and compile the Haskell module it produces. For the ``c2hs`` and+``hsc2hs`` preprocessors, Cabal will also automatically add, compile and+link any C sources generated by the preprocessor (produced by+``hsc2hs``'s ``#def`` feature or ``c2hs``'s auto-generated wrapper+functions).++Some fields take lists of values, which are optionally separated by+commas, except for the :pkg-field:`build-depends` field, where the commas are+mandatory.++Some fields are marked as required. All others are optional, and unless+otherwise specified have empty default values.++Package properties+^^^^^^^^^^^^^^^^^^++These fields may occur in the first top-level properties section and+describe the package as a whole:++.. pkg-field:: name: package-name (required)++    The unique name of the package, without the version number.++.. pkg-field:: version: numbers (required)++    The package version number, usually consisting of a sequence of+    natural numbers separated by dots.++.. pkg-field:: cabal-version: >= x.y++    The version of the Cabal specification that this package description+    uses. The Cabal specification does slowly evolve, introducing new+    features and occasionally changing the meaning of existing features.+    By specifying which version of the spec you are using it enables+    programs which process the package description to know what syntax+    to expect and what each part means.++    For historical reasons this is always expressed using *>=* version+    range syntax. No other kinds of version range make sense, in+    particular upper bounds do not make sense. In future this field will+    specify just a version number, rather than a version range.++    The version number you specify will affect both compatibility and+    behaviour. Most tools (including the Cabal library and cabal+    program) understand a range of versions of the Cabal specification.+    Older tools will of course only work with older versions of the+    Cabal specification. Most of the time, tools that are too old will+    recognise this fact and produce a suitable error message.++    As for behaviour, new versions of the Cabal spec can change the+    meaning of existing syntax. This means if you want to take advantage+    of the new meaning or behaviour then you must specify the newer+    Cabal version. Tools are expected to use the meaning and behaviour+    appropriate to the version given in the package description.++    In particular, the syntax of package descriptions changed+    significantly with Cabal version 1.2 and the :pkg-field:`cabal-version`+    field is now required. Files written in the old syntax are still+    recognized, so if you require compatibility with very old Cabal+    versions then you may write your package description file using the+    old syntax. Please consult the user's guide of an older Cabal+    version for a description of that syntax.++.. pkg-field:: build-type: identifier++    :default: ``Custom``++    The type of build used by this package. Build types are the+    constructors of the+    `BuildType <../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType>`__+    type, defaulting to ``Custom``.++    If the build type is anything other than ``Custom``, then the+    ``Setup.hs`` file *must* be exactly the standardized content+    discussed below. This is because in these cases, ``cabal`` will+    ignore the ``Setup.hs`` file completely, whereas other methods of+    package management, such as ``runhaskell Setup.hs [CMD]``, still+    rely on the ``Setup.hs`` file.++    For build type ``Simple``, the contents of ``Setup.hs`` must be:++    .. code-block:: haskell++        import Distribution.Simple+        main = defaultMain++    For build type ``Configure`` (see the section on `system-dependent+    parameters`_ below), the contents of+    ``Setup.hs`` must be:++    .. code-block:: haskell++        import Distribution.Simple+        main = defaultMainWithHooks autoconfUserHooks++    For build type ``Make`` (see the section on `more complex packages`_ below),+    the contents of ``Setup.hs`` must be:++    .. code-block:: haskell++        import Distribution.Make+        main = defaultMain++    For build type ``Custom``, the file ``Setup.hs`` can be customized,+    and will be used both by ``cabal`` and other tools.++    For most packages, the build type ``Simple`` is sufficient.++.. pkg-field:: license: identifier++    :default: ``AllRightsReserved``++    The type of license under which this package is distributed. License+    names are the constants of the+    `License <../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License>`__+    type.++.. pkg-field:: license-file: filename+.. pkg-field:: license-files: filename list++    The name of a file(s) containing the precise copyright license for+    this package. The license file(s) will be installed with the+    package.++    If you have multiple license files then use the :pkg-field:`license-files`+    field instead of (or in addition to) the :pkg-field:`license-file` field.++.. pkg-field:: copyright: freeform++    The content of a copyright notice, typically the name of the holder+    of the copyright on the package and the year(s) from which copyright+    is claimed. For example::++      copyright: (c) 2006-2007 Joe Bloggs++.. pkg-field:: author: freeform++    The original author of the package.++    Remember that ``.cabal`` files are Unicode, using the UTF-8+    encoding.++.. pkg-field:: maintainer: address++    The current maintainer or maintainers of the package. This is an+    e-mail address to which users should send bug reports, feature+    requests and patches.++.. pkg-field:: stability: freeform++    The stability level of the package, e.g. ``alpha``,+    ``experimental``, ``provisional``, ``stable``.++.. pkg-field:: homepage: URL++    The package homepage.++.. pkg-field:: bug-reports: URL++    The URL where users should direct bug reports. This would normally+    be either:++    -  A ``mailto:`` URL, e.g. for a person or a mailing list.++    -  An ``http:`` (or ``https:``) URL for an online bug tracking+       system.++    For example Cabal itself uses a web-based bug tracking system++    ::++        bug-reports: http://hackage.haskell.org/trac/hackage/++.. pkg-field:: package-url: URL++    The location of a source bundle for the package. The distribution+    should be a Cabal package.++.. pkg-field:: synopsis: freeform++    A very short description of the package, for use in a table of+    packages. This is your headline, so keep it short (one line) but as+    informative as possible. Save space by not including the package+    name or saying it's written in Haskell.++.. pkg-field:: description: freeform++    Description of the package. This may be several paragraphs, and+    should be aimed at a Haskell programmer who has never heard of your+    package before.++    For library packages, this field is used as prologue text by+    :ref:`setup-haddock` and thus may contain the same markup as Haddock_+    documentation comments.++.. pkg-field:: category: freeform++    A classification category for future use by the package catalogue+    Hackage_. These categories have not+    yet been specified, but the upper levels of the module hierarchy+    make a good start.++.. pkg-field:: tested-with: compiler list++    A list of compilers and versions against which the package has been+    tested (or at least built).++.. pkg-field:: data-files: filename list++    A list of files to be installed for run-time use by the package.+    This is useful for packages that use a large amount of static data,+    such as tables of values or code templates. Cabal provides a way to+    `find these files at run-time <accessing data files from package code>`_.++    A limited form of ``*`` wildcards in file names, for example+    ``data-files: images/*.png`` matches all the ``.png`` files in the+    ``images`` directory.++    The limitation is that ``*`` wildcards are only allowed in place of+    the file name, not in the directory name or file extension. In+    particular, wildcards do not include directories contents+    recursively. Furthermore, if a wildcard is used it must be used with+    an extension, so ``data-files: data/*`` is not allowed. When+    matching a wildcard plus extension, a file's full extension must+    match exactly, so ``*.gz`` matches ``foo.gz`` but not+    ``foo.tar.gz``. A wildcard that does not match any files is an+    error.++    The reason for providing only a very limited form of wildcard is to+    concisely express the common case of a large number of related files+    of the same file type without making it too easy to accidentally+    include unwanted files.++.. pkg-field:: data-dir: directory++    The directory where Cabal looks for data files to install, relative+    to the source directory. By default, Cabal will look in the source+    directory itself.++.. pkg-field:: extra-source-files: filename list++    A list of additional files to be included in source distributions+    built with :ref:`setup-sdist`. As with :pkg-field:`data-files` it can use+    a limited form of ``*`` wildcards in file names.++.. pkg-field:: extra-doc-files: filename list++    A list of additional files to be included in source distributions,+    and also copied to the html directory when Haddock documentation is+    generated. As with :pkg-field:`data-files` it can use a limited form of+    ``*`` wildcards in file names.++.. pkg-field:: extra-tmp-files: filename list++    A list of additional files or directories to be removed by+    :ref:`setup-clean`. These  would typically be additional files created by+    additional hooks, such as the scheme described in the section on+    `system-dependent parameters`_++Library+^^^^^^^++.. pkg-section:: library+    :synopsis: Library build information.++    Build information for libraries. There can be only one library in a+    package, and it's name is the same as package name set by global+    :pkg-field:`name` field.++The library section should contain the following fields:++.. pkg-field:: exposed-modules: identifier list++    :required: if this package contains a library++    A list of modules added by this package.++.. pkg-field:: exposed: boolean++    :default: ``True``++    Some Haskell compilers (notably GHC) support the notion of packages+    being "exposed" or "hidden" which means the modules they provide can+    be easily imported without always having to specify which package+    they come from. However this only works effectively if the modules+    provided by all exposed packages do not overlap (otherwise a module+    import would be ambiguous).++    Almost all new libraries use hierarchical module names that do not+    clash, so it is very uncommon to have to use this field. However it+    may be necessary to set ``exposed: False`` for some old libraries+    that use a flat module namespace or where it is known that the+    exposed modules would clash with other common modules.++.. pkg-field:: reexported-modules: exportlist++    Supported only in GHC 7.10 and later. A list of modules to+    *reexport* from this package. The syntax of this field is+    ``orig-pkg:Name as NewName`` to reexport module ``Name`` from+    ``orig-pkg`` with the new name ``NewName``. We also support+    abbreviated versions of the syntax: if you omit ``as NewName``,+    we'll reexport without renaming; if you omit ``orig-pkg``, then we+    will automatically figure out which package to reexport from, if+    it's unambiguous.++    Reexported modules are useful for compatibility shims when a package+    has been split into multiple packages, and they have the useful+    property that if a package provides a module, and another package+    reexports it under the same name, these are not considered a+    conflict (as would be the case with a stub module.) They can also be+    used to resolve name conflicts.++The library section may also contain build information fields (see the+section on `build information`_).++Cabal 1.25 and later support "internal libraries", which are extra named+libraries (as opposed to the usual unnamed library section). For+example, suppose that your test suite needs access to some internal+modules in your library, which you do not otherwise want to export. You+could put these modules in an internal library, which the main library+and the test suite :pkg-field:`build-depends` upon. Then your Cabal file might+look something like this:++::++    name:           foo+    version:        1.0+    license:        BSD3+    cabal-version:  >= 1.23+    build-type:     Simple++    library foo-internal+        exposed-modules: Foo.Internal+        build-depends: base++    library+        exposed-modules: Foo.Public+        build-depends: foo-internal, base++    test-suite test-foo+        type:       exitcode-stdio-1.0+        main-is:    test-foo.hs+        build-depends: foo-internal, base++Internal libraries are also useful for packages that define multiple+executables, but do not define a publically accessible library. Internal+libraries are only visible internally in the package (so they can only+be added to the :pkg-field:`build-depends` of same-package libraries,+executables, test suites, etc.) Internal libraries locally shadow any+packages which have the same name (so don't name an internal library+with the same name as an external dependency.)++Opening an interpreter session+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++While developing a package, it is often useful to make its code+available inside an interpreter session. This can be done with the+``repl`` command:++.. code-block:: console++    $ cabal repl++The name comes from the acronym+`REPL <http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop>`__,+which stands for "read-eval-print-loop". By default ``cabal repl`` loads+the first component in a package. If the package contains several named+components, the name can be given as an argument to ``repl``. The name+can be also optionally prefixed with the component's type for+disambiguation purposes. Example:++.. code-block:: console++    $ cabal repl foo+    $ cabal repl exe:foo+    $ cabal repl test:bar+    $ cabal repl bench:baz++Freezing dependency versions+""""""""""""""""""""""""""""++If a package is built in several different environments, such as a+development environment, a staging environment and a production+environment, it may be necessary or desirable to ensure that the same+dependency versions are selected in each environment. This can be done+with the ``freeze`` command:++.. code-block:: console++    $ cabal freeze++The command writes the selected version for all dependencies to the+``cabal.config`` file. All environments which share this file will use+the dependency versions specified in it.++Generating dependency version bounds+""""""""""""""""""""""""""""""""""""++Cabal also has the ability to suggest dependency version bounds that+conform to `Package Versioning Policy`_, which is+a recommended versioning system for publicly released Cabal packages.+This is done by running the ``gen-bounds`` command:++.. code-block:: console++    $ cabal gen-bounds++For example, given the following dependencies specified in+:pkg-field:`build-depends`:++::++    build-depends:+      foo == 0.5.2+      bar == 1.1++``gen-bounds`` will suggest changing them to the following:++::++    build-depends:+      foo >= 0.5.2 && < 0.6+      bar >= 1.1 && < 1.2++Executables+^^^^^^^^^^^++.. pkg-section:: executable name+    :synopsis: Exectuable build info section.++    Executable sections (if present) describe executable programs contained+    in the package and must have an argument after the section label, which+    defines the name of the executable. This is a freeform argument but may+    not contain spaces.++The executable may be described using the following fields, as well as+build information fields (see the section on `build information`_).++.. pkg-field:: main-is: filename (required)++    The name of the ``.hs`` or ``.lhs`` file containing the ``Main``+    module. Note that it is the ``.hs`` filename that must be listed,+    even if that file is generated using a preprocessor. The source file+    must be relative to one of the directories listed in+    :pkg-field:`hs-source-dirs`.++Running executables+"""""""""""""""""""++You can have Cabal build and run your executables by using the ``run``+command:++.. code-block:: console++    $ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS]++This command will configure, build and run the executable+``EXECUTABLE``. The double dash separator is required to distinguish+executable flags from ``run``'s own flags. If there is only one+executable defined in the whole package, the executable's name can be+omitted. See the output of ``cabal help run`` for a list of options you+can pass to ``cabal run``.++Test suites+^^^^^^^^^^^++.. pkg-section:: test name+    :synopsis: Test suit build information.++    Test suite sections (if present) describe package test suites and must+    have an argument after the section label, which defines the name of the+    test suite. This is a freeform argument, but may not contain spaces. It+    should be unique among the names of the package's other test suites, the+    package's executables, and the package itself. Using test suite sections+    requires at least Cabal version 1.9.2.++The test suite may be described using the following fields, as well as+build information fields (see the section on `build information`_).++.. pkg-field:: type: interface (required)++    The interface type and version of the test suite. Cabal supports two+    test suite interfaces, called ``exitcode-stdio-1.0`` and+    ``detailed-0.9``. Each of these types may require or disallow other+    fields as described below.++Test suites using the ``exitcode-stdio-1.0`` interface are executables+that indicate test failure with a non-zero exit code when run; they may+provide human-readable log information through the standard output and+error channels. The ``exitcode-stdio-1.0`` type requires the ``main-is``+field.++.. pkg-field:: main-is: filename+    :synopsis: Module containing tests main function.++    :required: ``exitcode-stdio-1.0``+    :disallowed: ``detailed-0.9``++    The name of the ``.hs`` or ``.lhs`` file containing the ``Main``+    module. Note that it is the ``.hs`` filename that must be listed,+    even if that file is generated using a preprocessor. The source file+    must be relative to one of the directories listed in+    :pkg-field:`hs-source-dirs`. This field is analogous to the ``main-is`` field+    of an executable section.++Test suites using the ``detailed-0.9`` interface are modules exporting+the symbol ``tests :: IO [Test]``. The ``Test`` type is exported by the+module ``Distribution.TestSuite`` provided by Cabal. For more details,+see the example below.++The ``detailed-0.9`` interface allows Cabal and other test agents to+inspect a test suite's results case by case, producing detailed human-+and machine-readable log files. The ``detailed-0.9`` interface requires+the :pkg-field:`test-module` field.++.. pkg-field:: test-module: identifier++    :required: ``detailed-0.9``+    :disallowed: ``exitcode-stdio-1.0``++    The module exporting the ``tests`` symbol.++Example: Package using ``exitcode-stdio-1.0`` interface+"""""""""""""""""""""""""""""""""""""""""""""""""""""""++The example package description and executable source file below+demonstrate the use of the ``exitcode-stdio-1.0`` interface.++.. code-block:: cabal+    :caption: foo.cabal++    Name:           foo+    Version:        1.0+    License:        BSD3+    Cabal-Version:  >= 1.9.2+    Build-Type:     Simple++    Test-Suite test-foo+        type:       exitcode-stdio-1.0+        main-is:    test-foo.hs+        build-depends: base++.. code-block:: haskell+    :caption: test-foo.hs++    module Main where++    import System.Exit (exitFailure)++    main = do+        putStrLn "This test always fails!"+        exitFailure++Example: Package using ``detailed-0.9`` interface+"""""""""""""""""""""""""""""""""""""""""""""""""++The example package description and test module source file below+demonstrate the use of the ``detailed-0.9`` interface. The test module+also develops a simple implementation of the interface set by+``Distribution.TestSuite``, but in actual usage the implementation would+be provided by the library that provides the testing facility.++.. code-block:: cabal+    :caption: bar.cabal++    Name:           bar+    Version:        1.0+    License:        BSD3+    Cabal-Version:  >= 1.9.2+    Build-Type:     Simple++    Test-Suite test-bar+        type:       detailed-0.9+        test-module: Bar+        build-depends: base, Cabal >= 1.9.2+++.. code-block:: haskell+    :caption: Bar.hs++    module Bar ( tests ) where++    import Distribution.TestSuite++    tests :: IO [Test]+    tests = return [ Test succeeds, Test fails ]+      where+        succeeds = TestInstance+            { run = return $ Finished Pass+            , name = "succeeds"+            , tags = []+            , options = []+            , setOption = \_ _ -> Right succeeds+            }+        fails = TestInstance+            { run = return $ Finished $ Fail "Always fails!"+            , name = "fails"+            , tags = []+            , options = []+            , setOption = \_ _ -> Right fails+            }++Running test suites+"""""""""""""""""""++You can have Cabal run your test suites using its built-in test runner:++::++    $ cabal configure --enable-tests+    $ cabal build+    $ cabal test++See the output of ``cabal help test`` for a list of options you can pass+to ``cabal test``.++Benchmarks+^^^^^^^^^^++.. pkg-section:: benchmark name+    :since: 1.9.2+    :synopsis: Benchmark build information.++    Benchmark sections (if present) describe benchmarks contained in the+    package and must have an argument after the section label, which defines+    the name of the benchmark. This is a freeform argument, but may not+    contain spaces. It should be unique among the names of the package's+    other benchmarks, the package's test suites, the package's executables,+    and the package itself. Using benchmark sections requires at least Cabal+    version 1.9.2.++The benchmark may be described using the following fields, as well as+build information fields (see the section on `build information`_).++.. pkg-field:: type: interface (required)++    The interface type and version of the benchmark. At the moment Cabal+    only support one benchmark interface, called ``exitcode-stdio-1.0``.++Benchmarks using the ``exitcode-stdio-1.0`` interface are executables+that indicate failure to run the benchmark with a non-zero exit code+when run; they may provide human-readable information through the+standard output and error channels.++.. pkg-field:: main-is: filename++    :required: ``exitcode-stdio-1.0``++    The name of the ``.hs`` or ``.lhs`` file containing the ``Main``+    module. Note that it is the ``.hs`` filename that must be listed,+    even if that file is generated using a preprocessor. The source file+    must be relative to one of the directories listed in+    :pkg-field:`hs-source-dirs`. This field is analogous to the ``main-is``+    field of an executable section.++Example: Package using ``exitcode-stdio-1.0`` interface+"""""""""""""""""""""""""""""""""""""""""""""""""""""""++The example package description and executable source file below+demonstrate the use of the ``exitcode-stdio-1.0`` interface.++.. code-block:: cabal+    :caption: foo.cabal+    :name: foo-bench.cabal++    Name:           foo+    Version:        1.0+    License:        BSD3+    Cabal-Version:  >= 1.9.2+    Build-Type:     Simple++    Benchmark bench-foo+        type:       exitcode-stdio-1.0+        main-is:    bench-foo.hs+        build-depends: base, time++.. code-block:: haskell+    :caption: bench-foo.hs++    {-# LANGUAGE BangPatterns #-}+    module Main where++    import Data.Time.Clock++    fib 0 = 1+    fib 1 = 1+    fib n = fib (n-1) + fib (n-2)++    main = do+        start <- getCurrentTime+        let !r = fib 20+        end <- getCurrentTime+        putStrLn $ "fib 20 took " ++ show (diffUTCTime end start)++Running benchmarks+""""""""""""""""""++You can have Cabal run your benchmark using its built-in benchmark+runner:++::++    $ cabal configure --enable-benchmarks+    $ cabal build+    $ cabal bench++See the output of ``cabal help bench`` for a list of options you can+pass to ``cabal bench``.++Foreign libraries+"""""""""""""""""++Foreign libraries are system libraries intended to be linked against+programs written in C or other "foreign" languages. They+come in two primary flavours: dynamic libraries (``.so`` files on Linux,+``.dylib`` files on OSX, ``.dll`` files on Windows, etc.) are linked against+executables when the executable is run (or even lazily during+execution), while static libraries (``.a`` files on Linux/OSX, ``.lib``+files on Windows) get linked against the executable at compile time.++Foreign libraries only work with GHC 7.8 and later.++A typical stanza for a foreign library looks like++::++    foreign-library myforeignlib+      type:                native-shared++      if os(Windows)+        options: standalone+        mod-def-file: MyForeignLib.def++      other-modules:       MyForeignLib.SomeModule+                           MyForeignLib.SomeOtherModule+      build-depends:       base >=4.7 && <4.9+      hs-source-dirs:      src+      c-sources:           csrc/MyForeignLibWrapper.c+      default-language:    Haskell2010++.. pkg-field:: type: foreign library type++   Cabal recognizes ``native-static`` and ``native-shared`` here, although+   we currently only support building `native-shared` libraries.++.. pkg-field:: options: foreign library option list++   Options for building the foreign library, typically specific to the+   specified type of foreign library. Currently we only support+   ``standalone`` here. A standalone dynamic library is one that does not+   have any dependencies on other (Haskell) shared libraries; without+   the ``standalone`` option the generated library would have dependencies+   on the Haskell runtime library (``libHSrts``), the base library+   (``libHSbase``), etc. Currently, ``standalone`` *must* be used on Windows+   and *must not* be used on any other platform.++.. pkg-field:: mod-def-file: filename++   This option can only be used when creating dynamic Windows libraries+   (that is, when using ``native-shared`` and the ``os`` is ``Windows``). If+   used, it must be a path to a _module definition file_. The details of+   module definition files are beyond the scope of this document; see the+   `GHC <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/win32-dlls.html>`_+   manual for some details and some further pointers.++Note that typically foreign libraries should export a way to initialize+and shutdown the Haskell runtime. In the example above, this is done by+the ``csrc/MyForeignLibWrapper.c`` file, which might look something like++.. code-block:: c++    #include <stdlib.h>+    #include "HsFFI.h"++    HsBool myForeignLibInit(void){+      int argc = 2;+      char *argv[] = { "+RTS", "-A32m", NULL };+      char **pargv = argv;++      // Initialize Haskell runtime+      hs_init(&argc, &pargv);++      // do any other initialization here and+      // return false if there was a problem+      return HS_BOOL_TRUE;+    }++    void myForeignLibExit(void){+      hs_exit();+    }++With modern ghc regular libraries are installed in directories that contain+package keys. This isn't usually a problem because the package gets registered+in ghc's package DB and so we can figure out what the location of the library+is. Foreign libraries however don't get registered, which means that we'd have+to have a way of finding out where a platform library got installed (other than by+searching the ``lib/`` directory). Instead, we install foreign libraries in+``~/.cabal/lib``, much like we install executables in ``~/.cabal/bin``.++Build information+^^^^^^^^^^^^^^^^^+.. pkg-section:: None++The following fields may be optionally present in a library, executable,+test suite or benchmark section, and give information for the building+of the corresponding library or executable. See also the sections on+`system-dependent parameters`_ and `configurations`_ for a way to supply+system-dependent values for these fields.++.. pkg-field:: build-depends: package list++    A list of packages needed to build this one. Each package can be+    annotated with a version constraint.++    Version constraints use the operators ``==, >=, >, <, <=`` and a+    version number. Multiple constraints can be combined using ``&&`` or+    ``||``. If no version constraint is specified, any version is+    assumed to be acceptable. For example:++    ::++        library+          build-depends:+            base >= 2,+            foo >= 1.2.3 && < 1.3,+            bar++    Dependencies like ``foo >= 1.2.3 && < 1.3`` turn out to be very+    common because it is recommended practise for package versions to+    correspond to API versions (see PVP_).++    Since Cabal 1.6, there is a special wildcard syntax to help with+    such ranges++    ::++        build-depends: foo ==1.2.*++    It is only syntactic sugar. It is exactly equivalent to+    ``foo >= 1.2 && < 1.3``.++    Starting with Cabal 2.0, there's a new syntactic sugar to support+    PVP_-style+    major upper bounds conveniently, and is inspired by similiar+    syntactic sugar found in other language ecosystems where it's often+    called the "Caret" operator:++    ::++        build-depends: foo ^>= 1.2.3.4,+                       bar ^>= 1++    The declaration above is exactly equivalent to++    ::++        build-depends: foo >= 1.2.3.4 && < 1.3,+                       bar >= 1 && < 1.1++    .. Note::++       Prior to Cabal 1.8, ``build-depends`` specified in each+       section were global to all sections. This was unintentional, but+       some packages were written to depend on it, so if you need your+       :pkg-field:`build-depends` to be local to each section, you must specify+       at least ``Cabal-Version: >= 1.8`` in your ``.cabal`` file.++    .. Note::++       Cabal 1.20 experimentally supported module thinning and+       renaming in ``build-depends``; however, this support has since been+       removed and should not be used.++.. pkg-field:: other-modules: identifier list++    A list of modules used by the component but not exposed to users.+    For a library component, these would be hidden modules of the+    library. For an executable, these would be auxiliary modules to be+    linked with the file named in the ``main-is`` field.++    .. Note::++       Every module in the package *must* be listed in one of+       :pkg-field:`other-modules`, :pkg-field:`library:exposed-modules` or+       :pkg-field:`executable:main-is` fields.++.. pkg-field:: hs-source-dirs: directory list++    :default: ``.``++    Root directories for the module hierarchy.++    For backwards compatibility, the old variant ``hs-source-dir`` is+    also recognized.++.. pkg-field:: default-extensions: identifier list++    A list of Haskell extensions used by every module. These determine+    corresponding compiler options enabled for all files. Extension+    names are the constructors of the+    `Extension <../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension>`__+    type. For example, ``CPP`` specifies that Haskell source files are+    to be preprocessed with a C preprocessor.++.. pkg-field:: other-extensions: identifier list++    A list of Haskell extensions used by some (but not necessarily all)+    modules. From GHC version 6.6 onward, these may be specified by+    placing a ``LANGUAGE`` pragma in the source files affected e.g.++    .. code-block:: haskell++        {-# LANGUAGE CPP, MultiParamTypeClasses #-}++    In Cabal-1.24 the dependency solver will use this and+    :pkg-field:`default-extensions` information. Cabal prior to 1.24 will abort+    compilation if the current compiler doesn't provide the extensions.++    If you use some extensions conditionally, using CPP or conditional+    module lists, it is good to replicate the condition in+    :pkg-field:`other-extensions` declarations:++    ::++        other-extensions: CPP+        if impl(ghc >= 7.5)+          other-extensions: PolyKinds++    You could also omit the conditionally used extensions, as they are+    for information only, but it is recommended to replicate them in+    :pkg-field:`other-extensions` declarations.++.. pkg-field:: extensions: identifier list+   :deprecated:++   Deprecated in favor of :pkg-field:`default-extensions`.++.. pkg-field:: build-tools: program list++    A list of programs, possibly annotated with versions, needed to+    build this package, e.g. ``c2hs >= 0.15, cpphs``. If no version+    constraint is specified, any version is assumed to be acceptable.+    :pkg-field:`build-tools` can refer to locally defined executables, in which+    case Cabal will make sure that executable is built first and add it+    to the PATH upon invocations to the compiler.++.. pkg-field:: buildable: boolean++    :default: ``True``++    Is the component buildable? Like some of the other fields below,+    this field is more useful with the slightly more elaborate form of+    the simple build infrastructure described in the section on+    `system-dependent parameters`_.++.. pkg-field:: ghc-options: token list++    Additional options for GHC. You can often achieve the same effect+    using the :pkg-field:`extensions` field, which is preferred.++    Options required only by one module may be specified by placing an+    ``OPTIONS_GHC`` pragma in the source file affected.++    As with many other fields, whitespace can be escaped by using+    Haskell string syntax. Example:+    ``ghc-options: -Wcompat "-with-rtsopts=-T -I1" -Wall``.++.. pkg-field:: ghc-prof-options: token list++    Additional options for GHC when the package is built with profiling+    enabled.++    Note that as of Cabal-1.24, the default profiling detail level+    defaults to ``exported-functions`` for libraries and+    ``toplevel-functions`` for executables. For GHC these correspond to+    the flags ``-fprof-auto-exported`` and ``-fprof-auto-top``. Prior to+    Cabal-1.24 the level defaulted to ``none``. These levels can be+    adjusted by the person building the package with the+    ``--profiling-detail`` and ``--library-profiling-detail`` flags.++    It is typically better for the person building the package to pick+    the profiling detail level rather than for the package author. So+    unless you have special needs it is probably better not to specify+    any of the GHC ``-fprof-auto*`` flags here. However if you wish to+    override the profiling detail level, you can do so using the+    :pkg-field:`ghc-prof-options` field: use ``-fno-prof-auto`` or one of the+    other ``-fprof-auto*`` flags.++.. pkg-field:: ghc-shared-options: token list++    Additional options for GHC when the package is built as shared+    library. The options specified via this field are combined with the+    ones specified via :pkg-field:`ghc-options`, and are passed to GHC during+    both the compile and link phases.++.. pkg-field:: includes: filename list++    A list of header files to be included in any compilations via C.+    This field applies to both header files that are already installed+    on the system and to those coming with the package to be installed.+    The former files should be found in absolute paths, while the latter+    files should be found in paths relative to the top of the source+    tree or relative to one of the directories listed in+    :pkg-field:`include-dirs`.++    These files typically contain function prototypes for foreign+    imports used by the package. This is in contrast to+    :pkg-field:`install-includes`, which lists header files that are intended+    to be exposed to other packages that transitively depend on this+    library.++.. pkg-field:: install-includes: filename list++    A list of header files from this package to be installed into+    ``$libdir/includes`` when the package is installed. Files listed in+    :pkg-field:`install-includes` should be found in relative to the top of the+    source tree or relative to one of the directories listed in+    :pkg-field:`include-dirs`.++    :pkg-field:`install-includes` is typically used to name header files that+    contain prototypes for foreign imports used in Haskell code in this+    package, for which the C implementations are also provided with the+    package. For example, here is a ``.cabal`` file for a hypothetical+    ``bindings-clib`` package that bundles the C source code for ``clib``::++        include-dirs:     cbits+        c-sources:        clib.c+        install-includes: clib.h++    Now any package that depends (directly or transitively) on the+    ``bindings-clib`` library can use ``clib.h``.++    Note that in order for files listed in :pkg-field:`install-includes` to be+    usable when compiling the package itself, they need to be listed in+    the :pkg-field:`includes` field as well.++.. pkg-field:: include-dirs: directory list++    A list of directories to search for header files, when preprocessing+    with ``c2hs``, ``hsc2hs``, ``cpphs`` or the C preprocessor, and also+    when compiling via C. Directories can be absolute paths (e.g., for+    system directories) or paths that are relative to the top of the+    source tree. Cabal looks in these directories when attempting to+    locate files listed in :pkg-field:`includes` and+    :pkg-field:`install-includes`.++.. pkg-field:: c-sources: filename list++    A list of C source files to be compiled and linked with the Haskell+    files.++.. pkg-field:: js-sources: filename list++    A list of JavaScript source files to be linked with the Haskell+    files (only for JavaScript targets).++.. pkg-field:: extra-libraries: token list++    A list of extra libraries to link with.++.. pkg-field:: extra-ghci-libraries: token list++    A list of extra libraries to be used instead of 'extra-libraries'+    when the package is loaded with GHCi.++.. pkg-field:: extra-lib-dirs: directory list++    A list of directories to search for libraries.++.. pkg-field:: cc-options: token list++    Command-line arguments to be passed to the C compiler. Since the+    arguments are compiler-dependent, this field is more useful with the+    setup described in the section on `system-dependent parameters`_.++.. pkg-field:: cpp-options: token list++    Command-line arguments for pre-processing Haskell code. Applies to+    haskell source and other pre-processed Haskell source like .hsc+    .chs. Does not apply to C code, that's what cc-options is for.++.. pkg-field:: ld-options: token list++    Command-line arguments to be passed to the linker. Since the+    arguments are compiler-dependent, this field is more useful with the+    setup described in the section on `system-dependent parameters`_.++.. pkg-field:: pkgconfig-depends: package list++    A list of+    `pkg-config <http://www.freedesktop.org/wiki/Software/pkg-config/>`__+    packages, needed to build this package. They can be annotated with+    versions, e.g. ``gtk+-2.0 >= 2.10, cairo >= 1.0``. If no version+    constraint is specified, any version is assumed to be acceptable.+    Cabal uses ``pkg-config`` to find if the packages are available on+    the system and to find the extra compilation and linker options+    needed to use the packages.++    If you need to bind to a C library that supports ``pkg-config`` (use+    ``pkg-config --list-all`` to find out if it is supported) then it is+    much preferable to use this field rather than hard code options into+    the other fields.++.. pkg-field:: frameworks: token list++    On Darwin/MacOS X, a list of frameworks to link to. See Apple's+    developer documentation for more details on frameworks. This entry+    is ignored on all other platforms.++.. pkg-field:: extra-frameworks-dirs: directory list++    On Darwin/MacOS X, a list of directories to search for frameworks.+    This entry is ignored on all other platforms.++Configurations+^^^^^^^^^^^^^^++Library and executable sections may include conditional blocks, which+test for various system parameters and configuration flags. The flags+mechanism is rather generic, but most of the time a flag represents+certain feature, that can be switched on or off by the package user.+Here is an example package description file using configurations:++Example: A package containing a library and executable programs+"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""++::++    Name: Test1+    Version: 0.0.1+    Cabal-Version: >= 1.2+    License: BSD3+    Author:  Jane Doe+    Synopsis: Test package to test configurations+    Category: Example++    Flag Debug+      Description: Enable debug support+      Default:     False++    Flag WebFrontend+      Description: Include API for web frontend.+      -- Cabal checks if the configuration is possible, first+      -- with this flag set to True and if not it tries with False++    Library+      Build-Depends:   base+      Exposed-Modules: Testing.Test1+      Extensions:      CPP++      if flag(debug)+        GHC-Options: -DDEBUG+        if !os(windows)+          CC-Options: "-DDEBUG"+        else+          CC-Options: "-DNDEBUG"++      if flag(webfrontend)+        Build-Depends: cgi > 0.42+        Other-Modules: Testing.WebStuff++    Executable test1+      Main-is: T1.hs+      Other-Modules: Testing.Test1+      Build-Depends: base++      if flag(debug)+        CC-Options: "-DDEBUG"+        GHC-Options: -DDEBUG++Layout+""""""++Flags, conditionals, library and executable sections use layout to+indicate structure. This is very similar to the Haskell layout rule.+Entries in a section have to all be indented to the same level which+must be more than the section header. Tabs are not allowed to be used+for indentation.++As an alternative to using layout you can also use explicit braces+``{}``. In this case the indentation of entries in a section does not+matter, though different fields within a block must be on different+lines. Here is a bit of the above example again, using braces:++Example: Using explicit braces rather than indentation for layout+"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""++::++    Name: Test1+    Version: 0.0.1+    Cabal-Version: >= 1.2+    License: BSD3+    Author:  Jane Doe+    Synopsis: Test package to test configurations+    Category: Example++    Flag Debug {+      Description: Enable debug support+      Default:     False+    }++    Library {+      Build-Depends:   base+      Exposed-Modules: Testing.Test1+      Extensions:      CPP+      if flag(debug) {+        GHC-Options: -DDEBUG+        if !os(windows) {+          CC-Options: "-DDEBUG"+        } else {+          CC-Options: "-DNDEBUG"+        }+      }+    }++Configuration Flags+"""""""""""""""""""++.. pkg-section:: flag name+   :synopsis: Flag declaration.++   Flag section declares a flag which can be used in `conditional blocks`_.++A flag section may contain the following fields:++.. pkg-field:: description: freeform++    The description of this flag.++.. pkg-field:: default: boolean++    :default: ``True``++    The default value of this flag.++    .. note::++      This value may be `overridden in several+      ways <installing-packages.html#controlling-flag-assignments>`__. The+      rationale for having flags default to True is that users usually+      want new features as soon as they are available. Flags representing+      features that are not (yet) recommended for most users (such as+      experimental features or debugging support) should therefore+      explicitly override the default to False.++.. pkg-field:: manual: boolean++    :default: ``False``++    By default, Cabal will first try to satisfy dependencies with the+    default flag value and then, if that is not possible, with the+    negated value. However, if the flag is manual, then the default+    value (which can be overridden by commandline flags) will be used.++Conditional Blocks+^^^^^^^^^^^^^^^^^^++Conditional blocks may appear anywhere inside a library or executable+section. They have to follow rather strict formatting rules. Conditional+blocks must always be of the shape++::++      if condition+         property-descriptions-or-conditionals++or++::++      if condition+           property-descriptions-or-conditionals+      else+           property-descriptions-or-conditionals++Note that the ``if`` and the condition have to be all on the same line.++Conditions+""""""""""++Conditions can be formed using boolean tests and the boolean operators+``||`` (disjunction / logical "or"), ``&&`` (conjunction / logical+"and"), or ``!`` (negation / logical "not"). The unary ``!`` takes+highest precedence, ``||`` takes lowest. Precedence levels may be+overridden through the use of parentheses. For example,+``os(darwin) && !arch(i386) || os(freebsd)`` is equivalent to+``(os(darwin) && !(arch(i386))) || os(freebsd)``.++The following tests are currently supported.++:samp:`os({name})`+    Tests if the current operating system is *name*. The argument is+    tested against ``System.Info.os`` on the target system. There is+    unfortunately some disagreement between Haskell implementations+    about the standard values of ``System.Info.os``. Cabal canonicalises+    it so that in particular ``os(windows)`` works on all+    implementations. If the canonicalised os names match, this test+    evaluates to true, otherwise false. The match is case-insensitive.+:samp:`arch({name})`+    Tests if the current architecture is *name*. The argument is matched+    against ``System.Info.arch`` on the target system. If the arch names+    match, this test evaluates to true, otherwise false. The match is+    case-insensitive.+:samp:`impl({compiler})`+    Tests for the configured Haskell implementation. An optional version+    constraint may be specified (for example ``impl(ghc >= 6.6.1)``). If+    the configured implementation is of the right type and matches the+    version constraint, then this evaluates to true, otherwise false.+    The match is case-insensitive.++    Note that including a version constraint in an ``impl`` test causes+    it to check for two properties:++    -  The current compiler has the specified name, and++    -  The compiler's version satisfied the specified version constraint++    As a result, ``!impl(ghc >= x.y.z)`` is not entirely equivalent to+    ``impl(ghc < x.y.z)``. The test ``!impl(ghc >= x.y.z)`` checks that:++    -  The current compiler is not GHC, or++    -  The version of GHC is earlier than version x.y.z.++:samp:`flag({name})`+    Evaluates to the current assignment of the flag of the given name.+    Flag names are case insensitive. Testing for flags that have not+    been introduced with a flag section is an error.+``true``+    Constant value true.+``false``+    Constant value false.++Resolution of Conditions and Flags+""""""""""""""""""""""""""""""""""++If a package descriptions specifies configuration flags the package user+can `control these in several+ways <installing-packages.html#controlling-flag-assignments>`__. If the+user does not fix the value of a flag, Cabal will try to find a flag+assignment in the following way.++-  For each flag specified, it will assign its default value, evaluate+   all conditions with this flag assignment, and check if all+   dependencies can be satisfied. If this check succeeded, the package+   will be configured with those flag assignments.++-  If dependencies were missing, the last flag (as by the order in which+   the flags were introduced in the package description) is tried with+   its alternative value and so on. This continues until either an+   assignment is found where all dependencies can be satisfied, or all+   possible flag assignments have been tried.++To put it another way, Cabal does a complete backtracking search to find+a satisfiable package configuration. It is only the dependencies+specified in the :pkg-field:`build-depends` field in conditional blocks that+determine if a particular flag assignment is satisfiable+(:pkg-field:`build-tools` are not considered). The order of the declaration and+the default value of the flags determines the search order. Flags+overridden on the command line fix the assignment of that flag, so no+backtracking will be tried for that flag.++If no suitable flag assignment could be found, the configuration phase+will fail and a list of missing dependencies will be printed. Note that+this resolution process is exponential in the worst case (i.e., in the+case where dependencies cannot be satisfied). There are some+optimizations applied internally, but the overall complexity remains+unchanged.++Meaning of field values when using conditionals+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++During the configuration phase, a flag assignment is chosen, all+conditionals are evaluated, and the package description is combined into+a flat package descriptions. If the same field both inside a conditional+and outside then they are combined using the following rules.++-  Boolean fields are combined using conjunction (logical "and").++-  List fields are combined by appending the inner items to the outer+   items, for example++   ::++       other-extensions: CPP+       if impl(ghc)+         other-extensions: MultiParamTypeClasses++   when compiled using GHC will be combined to++   ::++       other-extensions: CPP, MultiParamTypeClasses++   Similarly, if two conditional sections appear at the same nesting+   level, properties specified in the latter will come after properties+   specified in the former.++-  All other fields must not be specified in ambiguous ways. For example++   ::++       Main-is: Main.hs+       if flag(useothermain)+         Main-is: OtherMain.hs++   will lead to an error. Instead use++   ::++       if flag(useothermain)+         Main-is: OtherMain.hs+       else+         Main-is: Main.hs++Source Repositories+^^^^^^^^^^^^^^^^^^^++.. pkg-section:: source-repository++It is often useful to be able to specify a source revision control+repository for a package. Cabal lets you specifying this information in+a relatively structured form which enables other tools to interpret and+make effective use of the information. For example the information+should be sufficient for an automatic tool to checkout the sources.++Cabal supports specifying different information for various common+source control systems. Obviously not all automated tools will support+all source control systems.++Cabal supports specifying repositories for different use cases. By+declaring which case we mean automated tools can be more useful. There+are currently two kinds defined:++-  The ``head`` kind refers to the latest development branch of the+   package. This may be used for example to track activity of a project+   or as an indication to outside developers what sources to get for+   making new contributions.++-  The ``this`` kind refers to the branch and tag of a repository that+   contains the sources for this version or release of a package. For+   most source control systems this involves specifying a tag, id or+   hash of some form and perhaps a branch. The purpose is to be able to+   reconstruct the sources corresponding to a particular package+   version. This might be used to indicate what sources to get if+   someone needs to fix a bug in an older branch that is no longer an+   active head branch.++You can specify one kind or the other or both. As an example here are+the repositories for the Cabal library. Note that the ``this`` kind of+repository specifies a tag.++::++    source-repository head+      type:     darcs+      location: http://darcs.haskell.org/cabal/++    source-repository this+      type:     darcs+      location: http://darcs.haskell.org/cabal-branches/cabal-1.6/+      tag:      1.6.1++The exact fields are as follows:++.. pkg-field:: type: token++    The name of the source control system used for this repository. The+    currently recognised types are:++    -  ``darcs``+    -  ``git``+    -  ``svn``+    -  ``cvs``+    -  ``mercurial`` (or alias ``hg``)+    -  ``bazaar`` (or alias ``bzr``)+    -  ``arch``+    -  ``monotone``++    This field is required.++.. pkg-field:: location: URL++    The location of the repository. The exact form of this field depends+    on the repository type. For example:++    -  for darcs: ``http://code.haskell.org/foo/``+    -  for git: ``git://github.com/foo/bar.git``+    -  for CVS: ``anoncvs@cvs.foo.org:/cvs``++    This field is required.++.. pkg-field:: module: token++    CVS requires a named module, as each CVS server can host multiple+    named repositories.++    This field is required for the CVS repository type and should not be+    used otherwise.++.. pkg-field:: branch: token++    Many source control systems support the notion of a branch, as a+    distinct concept from having repositories in separate locations. For+    example CVS, SVN and git use branches while for darcs uses different+    locations for different branches. If you need to specify a branch to+    identify a your repository then specify it in this field.++    This field is optional.++.. pkg-field:: tag: token++    A tag identifies a particular state of a source repository. The tag+    can be used with a ``this`` repository kind to identify the state of+    a repository corresponding to a particular package version or+    release. The exact form of the tag depends on the repository type.++    This field is required for the ``this`` repository kind.++.. pkg-field:: subdir: directory++    Some projects put the sources for multiple packages under a single+    source repository. This field lets you specify the relative path+    from the root of the repository to the top directory for the+    package, i.e. the directory containing the package's ``.cabal``+    file.++    This field is optional. It default to empty which corresponds to the+    root directory of the repository.++Downloading a package's source+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++The ``cabal get`` command allows to access a package's source code -+either by unpacking a tarball downloaded from Hackage (the default) or+by checking out a working copy from the package's source repository.++::++    $ cabal get [FLAGS] PACKAGES++The ``get`` command supports the following options:++``-d --destdir`` *PATH*+    Where to place the package source, defaults to (a subdirectory of)+    the current directory.+``-s --source-repository`` *[head\|this\|...]*+    Fork the package's source repository using the appropriate version+    control system. The optional argument allows to choose a specific+    repository kind.++Custom setup scripts+--------------------++.. pkg-section:: custom-setup+   :synopsis: Custom Setup.hs build information.+   :since: 1.24++   The optional :pkg-section:`custom-setup` stanza contains information needed+   for the compilation of custom ``Setup.hs`` scripts,++::++    custom-setup+      setup-depends:+        base >= 4.5 && < 4.11,+        Cabal < 1.25++.. pkg-field:: setup-depends: package list+    :since: 1.24++    The dependencies needed to compile ``Setup.hs``. See the+    :pkg-field:`build-depends` field for a description of the syntax expected by+    this field.++Autogenerated modules+---------------------++Modules that are built automatically at setup, created with a custom+setup script, must appear on :pkg-field:`other-modules` for the library,+executable, test-suite or benchmark stanzas or also on+:pkg-field:`library:exposed-modules` for libraries to be used, but are not+really on the package when distributed. This makes commands like sdist fail+because the file is not found.++This special modules must appear again on the :pkg-field:`autogen-modules`+field of the stanza that is using it, besides :pkg-field:`other-modules` or+:pkg-field:`library:exposed-modules`. With this there is no need to create+complex build hooks for this poweruser case.++.. pkg-field:: autogen-modules: module list++   .. TODO: document autogen-modules field++Right now :pkg-field:`executable:main-is` modules are not supported on+:pkg-field:`autogen-modules`.++::++    Library+        default-language: Haskell2010+        build-depends: base+        exposed-modules:+            MyLibrary+            MyLibHelperModule+        other-modules:+            MyLibModule+        autogen-modules:+            MyLibHelperModule++    Executable Exe+        default-language: Haskell2010+        main-is: Dummy.hs+        build-depends: base+        other-modules:+            MyExeModule+            MyExeHelperModule+        autogen-modules:+            MyExeHelperModule++Accessing data files from package code+--------------------------------------++The placement on the target system of files listed in+the :pkg-field:`data-files` field varies between systems, and in some cases+one can even move packages around after installation (see `prefix+independence <installing-packages.html#prefix-independence>`__). To+enable packages to find these files in a portable way, Cabal generates a+module called :file:`Paths_{pkgname}` (with any hyphens in *pkgname*+replaced by underscores) during building, so that it may be imported by+modules of the package. This module defines a function++.. code-block:: haskell++    getDataFileName :: FilePath -> IO FilePath++If the argument is a filename listed in the :pkg-field:`data-files` field, the+result is the name of the corresponding file on the system on which the+program is running.++.. Note::++   If you decide to import the :file:`Paths_{pkgname}` module then it+   *must* be listed in the :pkg-field:`other-modules` field just like any other+   module in your package and on :pkg-field:`autogen-modules` as the file is+   autogenerated.++The :file:`Paths_{pkgname}` module is not platform independent, as any+other autogenerated module, so it does not get included in the source+tarballs generated by ``sdist``.++The :file:`Paths_{pkgname}` module also includes some other useful+functions and values, which record the version of the package and some+other directories which the package has been configured to be installed+into (e.g. data files live in ``getDataDir``):++.. code-block:: haskell++    version :: Version++    getBinDir :: IO FilePath+    getLibDir :: IO FilePath+    getDynLibDir :: IO FilePath+    getDataDir :: IO FilePath+    getLibexecDir :: IO FilePath+    getSysconfDir :: IO FilePath++The actual location of all these directories can be individually+overridden at runtime using environment variables of the form+``pkg_name_var``, where ``pkg_name`` is the name of the package with all+hyphens converted into underscores, and ``var`` is either ``bindir``,+``libdir``, ``dynlibdir``, ``datadir``, ``libexedir`` or ``sysconfdir``. For example,+the configured data directory for ``pretty-show`` is controlled with the+``pretty_show_datadir`` environment variable.++Accessing the package version+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++The aforementioned auto generated :file:`Paths_{pkgname}` module also+exports the constant ``version ::``+`Version <http://hackage.haskell.org/package/base/docs/Data-Version.html>`__+which is defined as the version of your package as specified in the+``version`` field.++System-dependent parameters+---------------------------++For some packages, especially those interfacing with C libraries,+implementation details and the build procedure depend on the build+environment. The ``build-type`` ``Configure`` can be used to handle many+such situations. In this case, ``Setup.hs`` should be:++.. code-block:: haskell++    import Distribution.Simple+    main = defaultMainWithHooks autoconfUserHooks++Most packages, however, would probably do better using the ``Simple``+build type and `configurations`_.++The :pkg-field:`build-type` ``Configure`` differs from ``Simple`` in two ways:++-  The package root directory must contain a shell script called+   ``configure``. The configure step will run the script. This+   ``configure`` script may be produced by+   `autoconf <http://www.gnu.org/software/autoconf/>`__ or may be+   hand-written. The ``configure`` script typically discovers+   information about the system and records it for later steps, e.g. by+   generating system-dependent header files for inclusion in C source+   files and preprocessed Haskell source files. (Clearly this won't work+   for Windows without MSYS or Cygwin: other ideas are needed.)++-  If the package root directory contains a file called+   *package*\ ``.buildinfo`` after the configuration step, subsequent+   steps will read it to obtain additional settings for `build+   information`_ fields,to be merged with the ones+   given in the ``.cabal`` file. In particular, this file may be+   generated by the ``configure`` script mentioned above, allowing these+   settings to vary depending on the build environment.++The build information file should have the following structure:++    *buildinfo*++    ``executable:`` *name* *buildinfo*++    ``executable:`` *name* *buildinfo* ...++where each *buildinfo* consists of settings of fields listed in the+section on `build information`_. The first one (if+present) relates to the library, while each of the others relate to the+named executable. (The names must match the package description, but you+don't have to have entries for all of them.)++Neither of these files is required. If they are absent, this setup+script is equivalent to ``defaultMain``.++Example: Using autoconf+^^^^^^^^^^^^^^^^^^^^^^^++This example is for people familiar with the+`autoconf <http://www.gnu.org/software/autoconf/>`__ tools.++In the X11 package, the file ``configure.ac`` contains:++.. code-block:: shell++    AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11])++    # Safety check: Ensure that we are in the correct source directory.+    AC_CONFIG_SRCDIR([X11.cabal])++    # Header file to place defines in+    AC_CONFIG_HEADERS([include/HsX11Config.h])++    # Check for X11 include paths and libraries+    AC_PATH_XTRA+    AC_TRY_CPP([#include <X11/Xlib.h>],,[no_x=yes])++    # Build the package if we found X11 stuff+    if test "$no_x" = yes+    then BUILD_PACKAGE_BOOL=False+    else BUILD_PACKAGE_BOOL=True+    fi+    AC_SUBST([BUILD_PACKAGE_BOOL])++    AC_CONFIG_FILES([X11.buildinfo])+    AC_OUTPUT++Then the setup script will run the ``configure`` script, which checks+for the presence of the X11 libraries and substitutes for variables in+the file ``X11.buildinfo.in``:++::++    buildable: @BUILD_PACKAGE_BOOL@+    cc-options: @X_CFLAGS@+    ld-options: @X_LIBS@++This generates a file ``X11.buildinfo`` supplying the parameters needed+by later stages:++::++    buildable: True+    cc-options:  -I/usr/X11R6/include+    ld-options:  -L/usr/X11R6/lib++The ``configure`` script also generates a header file+``include/HsX11Config.h`` containing C preprocessor defines recording+the results of various tests. This file may be included by C source+files and preprocessed Haskell source files in the package.++.. Note::++   Packages using these features will also need to list additional+   files such as ``configure``, templates for ``.buildinfo`` files, files+   named only in ``.buildinfo`` files, header files and so on in the+   :pkg-field:`extra-source-files` field to ensure that they are included in+   source distributions. They should also list files and directories generated+   by ``configure`` in the :pkg-field:`extra-tmp-files` field to ensure that+   they are removed by ``setup clean``.++Quite often the files generated by ``configure`` need to be listed+somewhere in the package description (for example, in the+:pkg-field:`install-includes` field). However, we usually don't want generated+files to be included in the source tarball. The solution is again+provided by the ``.buildinfo`` file. In the above example, the following+line should be added to ``X11.buildinfo``:++::++    install-includes: HsX11Config.h++In this way, the generated ``HsX11Config.h`` file won't be included in+the source tarball in addition to ``HsX11Config.h.in``, but it will be+copied to the right location during the install process. Packages that+use custom ``Setup.hs`` scripts can update the necessary fields+programmatically instead of using the ``.buildinfo`` file.++Conditional compilation+-----------------------++Sometimes you want to write code that works with more than one version+of a dependency. You can specify a range of versions for the dependency+in the :pkg-field:`build-depends`, but how do you then write the code that can+use different versions of the API?++Haskell lets you preprocess your code using the C preprocessor (either+the real C preprocessor, or ``cpphs``). To enable this, add+``extensions: CPP`` to your package description. When using CPP, Cabal+provides some pre-defined macros to let you test the version of+dependent packages; for example, suppose your package works with either+version 3 or version 4 of the ``base`` package, you could select the+available version in your Haskell modules like this:++.. code-block:: cpp++    #if MIN_VERSION_base(4,0,0)+    ... code that works with base-4 ...+    #else+    ... code that works with base-3 ...+    #endif++In general, Cabal supplies a macro+``MIN_VERSION_``\ *``package``*\ ``_(A,B,C)`` for each package depended+on via :pkg-field:`build-depends`. This macro is true if the actual version of+the package in use is greater than or equal to ``A.B.C`` (using the+conventional ordering on version numbers, which is lexicographic on the+sequence, but numeric on each component, so for example 1.2.0 is greater+than 1.0.3).++Since version 1.20, there is also the ``MIN_TOOL_VERSION_``\ *``tool``*+family of macros for conditioning on the version of build tools used to+build the program (e.g. ``hsc2hs``).++Cabal places the definitions of these macros into an+automatically-generated header file, which is included when+preprocessing Haskell source code by passing options to the C+preprocessor.++Cabal also allows to detect when the source code is being used for+generating documentation. The ``__HADDOCK_VERSION__`` macro is defined+only when compiling via Haddock_+instead of a normal Haskell compiler. The value of the+``__HADDOCK_VERSION__`` macro is defined as ``A*1000 + B*10 + C``, where+``A.B.C`` is the Haddock version. This can be useful for working around+bugs in Haddock or generating prettier documentation in some special+cases.++More complex packages+---------------------++For packages that don't fit the simple schemes described above, you have+a few options:++-  By using the :pkg-field:`build-type` ``Custom``, you can supply your own+   ``Setup.hs`` file, and customize the simple build infrastructure+   using *hooks*. These allow you to perform additional actions before+   and after each command is run, and also to specify additional+   preprocessors. A typical ``Setup.hs`` may look like this:++   .. code-block:: haskell++       import Distribution.Simple+       main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock }++       posthaddock args flags desc info = ....++   See ``UserHooks`` in+   `Distribution.Simple <../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html>`__+   for the details, but note that this interface is experimental, and+   likely to change in future releases.++   If you use a custom ``Setup.hs`` file you should strongly consider+   adding a :pkg-section:`custom-setup` stanza with a+   :pkg-field:`custom-setup:setup-depends` field to ensure that your setup+   script does not break with future dependency versions.++-  You could delegate all the work to ``make``, though this is unlikely+   to be very portable. Cabal supports this with the :pkg-field:`build-type`+   ``Make`` and a trivial setup library+   `Distribution.Make <../release/cabal-latest/doc/API/Cabal/Distribution-Make.html>`__,+   which simply parses the command line arguments and invokes ``make``.+   Here ``Setup.hs`` should look like this:++   .. code-block:: haskell++       import Distribution.Make+       main = defaultMain++   The root directory of the package should contain a ``configure``+   script, and, after that has run, a ``Makefile`` with a default target+   that builds the package, plus targets ``install``, ``register``,+   ``unregister``, ``clean``, ``dist`` and ``docs``. Some options to+   commands are passed through as follows:++   -  The ``--with-hc-pkg``, ``--prefix``, ``--bindir``, ``--libdir``,+      ``--dynlibdir``, ``--datadir``, ``--libexecdir`` and ``--sysconfdir`` options to+      the ``configure`` command are passed on to the ``configure``+      script. In addition the value of the ``--with-compiler`` option is+      passed in a ``--with-hc`` option and all options specified with+      ``--configure-option=`` are passed on.++   -  The ``--destdir`` option to the ``copy`` command becomes a setting+      of a ``destdir`` variable on the invocation of ``make copy``. The+      supplied ``Makefile`` should provide a ``copy`` target, which will+      probably look like this:++      .. code-block:: make++          copy :+                  $(MAKE) install prefix=$(destdir)/$(prefix) \+                                  bindir=$(destdir)/$(bindir) \+                                  libdir=$(destdir)/$(libdir) \+                                  dynlibdir=$(destdir)/$(dynlibdir) \+                                  datadir=$(destdir)/$(datadir) \+                                  libexecdir=$(destdir)/$(libexecdir) \+                                  sysconfdir=$(destdir)/$(sysconfdir) \++-  Finally, with the :pkg-field:`build-type` ``Custom``, you can also write your+   own setup script from scratch. It must conform to the interface+   described in the section on `building and installing+   packages <installing-packages.html>`__, and you may use the Cabal+   library for all or part of the work. One option is to copy the source+   of ``Distribution.Simple``, and alter it for your needs. Good luck.+++.. include:: references.inc
+ cabal/Cabal/doc/images/Cabal-dark.png view

binary file changed (absent → 7086 bytes)

− cabal/Cabal/doc/index.markdown 
@@ -1,201 +0,0 @@-% Cabal User Guide-**Version: 1.25.0.0**--Cabal is the standard package system for [Haskell] software. It helps-people to configure, build and install Haskell software and to-distribute it easily to other users and developers.--There is a command line tool called `cabal` for working with Cabal-packages. It helps with installing existing packages and also helps-people developing their own packages. It can be used to work with local-packages or to install packages from online package archives, including-automatically installing dependencies. By default it is configured to-use [Hackage] which is Haskell's central package archive that contains-thousands of libraries and applications in the Cabal package format.--# Contents #--  * [Introduction](#introduction)-      - [What's in a package](#whats-in-a-package)-      - [A tool for working with packages](#a-tool-for-working-with-packages)-  * [Building, installing and managing packages](installing-packages.html)-  * [Creating packages](developing-packages.html)-  * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies)-  * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces)--# Introduction #--Cabal is a package system for Haskell software. The point of a package-system is to enable software developers and users to easily distribute,-use and reuse software. A package system makes it easier for developers-to get their software into the hands of users. Equally importantly, it-makes it easier for software developers to be able to reuse software-components written by other developers.--Packaging systems deal with packages and with Cabal we call them _Cabal-packages_. The Cabal package is the unit of distribution. Every Cabal-package has a name and a version number which are used to identify the-package, e.g. `filepath-1.0`.--Cabal packages can depend on other Cabal packages. There are tools-to enable automated package management. This means it is possible for-developers and users to install a package plus all of the other Cabal-packages that it depends on. It also means that it is practical to make-very modular systems using lots of packages that reuse code written by-many developers.--Cabal packages are source based and are typically (but not necessarily)-portable to many platforms and Haskell implementations. The Cabal-package format is designed to make it possible to translate into other-formats, including binary packages for various systems.--When distributed, Cabal packages use the standard compressed tarball-format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`.--Note that packages are not part of the Haskell language, rather they-are a feature provided by the combination of Cabal and GHC (and several-other Haskell implementations).---## A tool for working with packages ##--There is a command line tool, called "`cabal`", that users and developers-can use to build and install Cabal packages. It can be used for both-local packages and for packages available remotely over the network. It-can automatically install Cabal packages plus any other Cabal packages-they depend on.--Developers can use the tool with packages in local directories, e.g.--~~~~~~~~~~~~~~~~-cd foo/-cabal install-~~~~~~~~~~~~~~~~--While working on a package in a local directory, developers can run the-individual steps to configure and build, and also generate documentation-and run test suites and benchmarks.--It is also possible to install several local packages at once, e.g.--~~~~~~~~~~~~~~~~-cabal install foo/ bar/-~~~~~~~~~~~~~~~~--Developers and users can use the tool to install packages from remote-Cabal package archives. By default, the `cabal` tool is configured to-use the central Haskell package archive called [Hackage] but it-is possible to use it with any other suitable archive.--~~~~~~~~~~~~~~~~-cabal install xmonad-~~~~~~~~~~~~~~~~--This will install the `xmonad` package plus all of its dependencies.--In addition to packages that have been published in an archive,-developers can install packages from local or remote tarball files,-for example--~~~~~~~~~~~~~~~~-cabal install foo-1.0.tar.gz-cabal install http://example.com/foo-1.0.tar.gz-~~~~~~~~~~~~~~~~--Cabal provides a number of ways for a user to customise how and where a-package is installed. They can decide where a package will be installed,-which Haskell implementation to use and whether to build optimised code-or build with the ability to profile code. It is not expected that users-will have to modify any of the information in the `.cabal` file.--For full details, see the section on [building and installing-packages](installing-packages.html).--Note that `cabal` is not the only tool for working with Cabal packages.-Due to the standardised format and a library for reading `.cabal` files,-there are several other special-purpose tools.--## What's in a package ##--A Cabal package consists of:--  * Haskell software, including libraries, executables and tests-  * metadata about the package in a standard human and machine-    readable format (the "`.cabal`" file)-  * a standard interface to build the package (the "`Setup.hs`" file)--The `.cabal` file contains information about the package, supplied by-the package author. In particular it lists the other Cabal packages-that the package depends on.--For full details on what goes in the `.cabal` and `Setup.hs` files, and-for all the other features provided by the build system, see the section-on [developing packages](developing-packages.html).---## Cabal featureset ##--Cabal and its associated tools and websites covers:-- * a software build system- * software configuration- * packaging for distribution- * automated package management-    * natively using the `cabal` command line tool; or-    * by translation into native package formats such as RPM or deb- * web and local Cabal package archives-    * central Hackage website with 1000's of Cabal packages--Some parts of the system can be used without others. In particular the-built-in build system for simple packages is optional: it is possible-to use custom build systems.--## Similar systems ##--The Cabal system is roughly comparable with the system of Python Eggs,-Ruby Gems or Perl distributions. Each system has a notion of-distributable packages, and has tools to manage the process of-distributing and installing packages.--Hackage is an online archive of Cabal packages. It is roughly comparable-to CPAN but with rather fewer packages (around 5,000 vs 28,000).--Cabal is often compared with autoconf and automake and there is some-overlap in functionality. The most obvious similarity is that the-command line interface for actually configuring and building packages-follows the same steps and has many of the same configuration-parameters.--~~~~~~~~~~-./configure --prefix=...-make-make install-~~~~~~~~~~--compared to--~~~~~~~~~~-cabal configure --prefix=...-cabal build-cabal install-~~~~~~~~~~--Cabal's build system for simple packages is considerably less flexible-than make/automake, but has builtin knowledge of how to build Haskell-code and requires very little manual configuration. Cabal's simple build-system is also portable to Windows, without needing a Unix-like-environment such as cygwin/mingwin.--Compared to autoconf, Cabal takes a somewhat different approach to-package configuration. Cabal's approach is designed for automated-package management. Instead of having a configure script that tests for-whether dependencies are available, Cabal packages specify their-dependencies. There is some scope for optional and conditional-dependencies. By having package authors specify dependencies it makes it-possible for tools to install a package and all of its dependencies-automatically. It also makes it possible to translate (in a-mostly-automatically way) into another package format like RPM or deb-which also have automatic dependency resolution.--[Haskell]:  http://www.haskell.org/-[Hackage]:  http://hackage.haskell.org/
+ cabal/Cabal/doc/index.rst view
@@ -0,0 +1,13 @@++Welcome to the Cabal User Guide+===============================++.. toctree::+   :maxdepth: 2+   :numbered:++   intro+   config-and-install+   concepts-and-development+   bugs-and-stability+   nix-local-build-overview
− cabal/Cabal/doc/installing-packages.markdown 
@@ -1,1288 +0,0 @@-% Cabal User Guide--# Configuration #--## Overview ##--The global configuration file for `cabal-install` is `~/.cabal/config`. If you-do not have this file, `cabal` will create it for you on the first call to-`cabal update`. Alternatively, you can explicitly ask `cabal` to create it for-you using--> `cabal user-config update`--Most of the options in this configuration file are also available as command-line arguments, and the corresponding documentation can be used to lookup their-meaning. The created configuration file only specifies values for a handful of-options. Most options are left at their default value, which it documents;-for instance,--~~~~~~~~~~~~~~~~--- executable-stripping: True-~~~~~~~~~~~~~~~~--means that the configuration file currently does not specify a value for the-`executable-stripping` option (the line is commented out), and that the default-is `True`; if you wanted to disable stripping of executables by default, you-would change this line to--~~~~~~~~~~~~~~~~-executable-stripping: False-~~~~~~~~~~~~~~~~--You can also use `cabal user-config update` to migrate configuration files-created by older versions of `cabal`.--## Repository specification ##--An important part of the configuration if the specification of the repository.-When `cabal` creates a default config file, it configures the repository to-be the central Hackage server:--~~~~~~~~~~~~~~~~-repository hackage.haskell.org-  url: http://hackage.haskell.org/-~~~~~~~~~~~~~~~~--The name of the repository is given on the first line, and can be anything;-packages downloaded from this repository will be cached under-`~/.cabal/packages/hackage.haskell.org` (or whatever name you specify; you can-change the prefix by changing the value of `remote-repo-cache`). If you want,-you can configure multiple repositories, and `cabal` will combine them and be-able to download packages from any of them.--### Using secure repositories ###--For repositories that support the TUF security infrastructure (this includes-Hackage), you can enable secure access to the repository by specifying:--~~~~~~~~~~~~~~~~-repository hackage.haskell.org-  url: http://hackage.haskell.org/-  secure: True-  root-keys: <root-key-IDs>-  key-threshold: <key-threshold>-~~~~~~~~~~~~~~~~--The `<root-key-IDs>` and `<key-threshold>` values are used for bootstrapping. As-part of the TUF infrastructure the repository will contain a file `root.json`-(for instance,-[http://hackage.haskell.org/root.json](http://hackage.haskell.org/root.json))-which the client needs to do verification. However, how  can `cabal` verify the-`root.json` file _itself_? This is known as bootstrapping: if you specify a list-of root key IDs and a corresponding  threshold, `cabal` will verify that the-downloaded `root.json` file has been  signed with at least `<key-threshold>`-keys from your set of `<root-key-IDs>`.--You can, but are not recommended to, omit these two fields. In that case `cabal`-will download the `root.json` field and use it without verification. Although-this bootstrapping step is then unsafe, all subsequent access is secure-(provided that the downloaded `root.json` was not tempered with). Of course,-adding `root-keys` and `key-threshold` to your repository specification only-shifts the problem, because now you somehow need to make sure that the key IDs-you received were the right ones. How that is done is however outside the scope-of `cabal` proper.--More information about the security infrastructure can be found at-[https://github.com/well-typed/hackage-security](https://github.com/well-typed/hackage-security).--### Legacy repositories ###--Currently `cabal` supports two kinds of &ldquo;legacy&rdquo; repositories. The-first is specified using--~~~~~~~~~~~~~~~~-remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive-~~~~~~~~~~~~~~~~--This is just syntactic sugar for--~~~~~~~~~~~~~~~~-repository hackage.haskell.org-  url: hackage.haskell.org:http://hackage.haskell.org/packages/archive-~~~~~~~~~~~~~~~~--although, in (and only in) the specific case of Hackage, the URL-`http://hackage.haskell.org/packages/archive` will be silently translated to-`http://hackage.haskell.org/`.--The second kind of legacy repositories are so-called &ldquo;local&rdquo;-repositories:--~~~~~~~~~~~~~~~~-local-repo: my-local-repo:/path/to/local/repo-~~~~~~~~~~~~~~~~--This can be used to access repositories on the local file system. However, the-layout of these local repositories is different from the layout of remote-repositories, and usage of these local repositories is deprecated.--### Secure local repositories ###--If you want to use repositories on your local file system, it is recommended-instead to use a _secure_ local repository:--~~~~~~~~~~~~~~~~-repository my-local-repo-  url: file:/path/to/local/repo-  secure: True-  root-keys: <root-key-IDs>-  key-threshold: <key-threshold>-~~~~~~~~~~~~~~~~--The layout of these secure local repos matches the layout of remote repositories-exactly; the-[hackage-repo-tool](http://hackage.haskell.org/package/hackage-repo-tool) can be-used to create and manage such repositories.--# Building and installing packages #--After you've unpacked a Cabal package, you can build it by moving into-the root directory of the package and running the `cabal` tool there:--> `cabal [command] [option...]`--The _command_ argument selects a particular step in the build/install process.--You can also get a summary of the command syntax with--> `cabal help`--Alternatively, you can also use the `Setup.hs` or `Setup.lhs` script:--> `runhaskell Setup.hs [command] [option...]`--For the summary of the command syntax, run:--> `cabal help`--or--> `runhaskell Setup.hs --help`--## Building and installing a system package ##--~~~~~~~~~~~~~~~~-runhaskell Setup.hs configure --ghc-runhaskell Setup.hs build-runhaskell Setup.hs install-~~~~~~~~~~~~~~~~--The first line readies the system to build the tool using GHC; for-example, it checks that GHC exists on the system.  The second line-performs the actual building, while the last both copies the build-results to some permanent place and registers the package with GHC.--## Building and installing a user package ##--~~~~~~~~~~~~~~~~-runhaskell Setup.hs configure --user-runhaskell Setup.hs build-runhaskell Setup.hs install-~~~~~~~~~~~~~~~~--The package is installed under the user's home directory and is-registered in the user's package database (`--user`).--## Installing packages from Hackage ##--The `cabal` tool also can download, configure, build and install a [Hackage]-package and all of its dependencies in a single step. To do this, run:--~~~~~~~~~~~~~~~~-cabal install [PACKAGE...]-~~~~~~~~~~~~~~~~--To browse the list of available packages, visit the [Hackage] web site.--## Developing with sandboxes ##--By default, any dependencies of the package are installed into the global or-user package databases (e.g. using `cabal install --only-dependencies`). If-you're building several different packages that have incompatible dependencies,-this can cause the build to fail. One way to avoid this problem is to build each-package in an isolated environment ("sandbox"), with a sandbox-local package-database. Because sandboxes are per-project, inconsistent dependencies can be-simply disallowed.--For more on sandboxes, see also-[this article](http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html).--### Sandboxes: basic usage ###--To initialise a fresh sandbox in the current directory, run `cabal sandbox-init`. All subsequent commands (such as `build` and `install`) from this point-will use the sandbox.--~~~~~~~~~~~~~~~-$ cd /path/to/my/haskell/library-$ cabal sandbox init                   # Initialise the sandbox-$ cabal install --only-dependencies    # Install dependencies into the sandbox-$ cabal build                          # Build your package inside the sandbox-~~~~~~~~~~~~~~~--It can be useful to make a source package available for installation in the-sandbox - for example, if your package depends on a patched or an unreleased-version of a library. This can be done with the `cabal sandbox add-source`-command - think of it as "local [Hackage]". If an add-source dependency is later-modified, it is reinstalled automatically.--~~~~~~~~~~~~~~~-$ cabal sandbox add-source /my/patched/library # Add a new add-source dependency-$ cabal install --dependencies-only            # Install it into the sandbox-$ cabal build                                  # Build the local package-$ $EDITOR /my/patched/library/Source.hs        # Modify the add-source dependency-$ cabal build                                  # Modified dependency is automatically reinstalled-~~~~~~~~~~~~~~~--Normally, the sandbox settings (such as optimisation level) are inherited from-the main Cabal config file (`$HOME/cabal/config`). Sometimes, though, you need-to change some settings specifically for a single sandbox. You can do this by-creating a `cabal.config` file in the same directory with your-`cabal.sandbox.config` (which was created by `sandbox init`). This file has the-same syntax as the main Cabal config file.--~~~~~~~~~~~~~~~-$ cat cabal.config-documentation: True-constraints: foo == 1.0, bar >= 2.0, baz-$ cabal build                                  # Uses settings from the cabal.config file-~~~~~~~~~~~~~~~--When you have decided that you no longer want to build your package inside a-sandbox, just delete it:--~~~~~~~~~~~~~~~-$ cabal sandbox delete                       # Built-in command-$ rm -rf .cabal-sandbox cabal.sandbox.config # Alternative manual method-~~~~~~~~~~~~~~~--### Sandboxes: advanced usage ###--The default behaviour of the `add-source` command is to track modifications done-to the added dependency and reinstall the sandbox copy of the package when-needed. Sometimes this is not desirable: in these cases you can use `add-source---snapshot`, which disables the change tracking. In addition to `add-source`,-there are also `list-sources` and `delete-source` commands.--Sometimes one wants to share a single sandbox between multiple packages. This-can be easily done with the `--sandbox` option:--~~~~~~~~~~~~~~~-$ mkdir -p /path/to/shared-sandbox-$ cd /path/to/shared-sandbox-$ cabal sandbox init --sandbox .-$ cd /path/to/package-a-$ cabal sandbox init --sandbox /path/to/shared-sandbox-$ cd /path/to/package-b-$ cabal sandbox init --sandbox /path/to/shared-sandbox-~~~~~~~~~~~~~~~--Note that `cabal sandbox init --sandbox .` puts all sandbox files into the-current directory. By default, `cabal sandbox init` initialises a new sandbox in-a newly-created subdirectory of the current working directory-(`./.cabal-sandbox`).--Using multiple different compiler versions simultaneously is also supported, via-the `-w` option:--~~~~~~~~~~~~~~~-$ cabal sandbox init-$ cabal install --only-dependencies -w /path/to/ghc-1 # Install dependencies for both compilers-$ cabal install --only-dependencies -w /path/to/ghc-2-$ cabal configure -w /path/to/ghc-1                   # Build with the first compiler-$ cabal build-$ cabal configure -w /path/to/ghc-2                   # Build with the second compiler-$ cabal build-~~~~~~~~~~~~~~~--It can be occasionally useful to run the compiler-specific package manager tool-(e.g. `ghc-pkg`) tool on the sandbox package DB directly (for example, you may-need to unregister some packages). The `cabal sandbox hc-pkg` command is a-convenient wrapper that runs the compiler-specific package manager tool with the-arguments:--~~~~~~~~~~~~~~~-$ cabal -v sandbox hc-pkg list-Using a sandbox located at /path/to/.cabal-sandbox-'ghc-pkg' '--global' '--no-user-package-conf'-    '--package-conf=/path/to/.cabal-sandbox/i386-linux-ghc-7.4.2-packages.conf.d'-    'list'-[...]-~~~~~~~~~~~~~~~--The `--require-sandbox` option makes all sandbox-aware commands-(`install`/`build`/etc.) exit with error if there is no sandbox present. This-makes it harder to accidentally modify the user package database. The option can-be also turned on via the per-user configuration file (`~/.cabal/config`) or the-per-project one (`$PROJECT_DIR/cabal.config`). The error can be squelched with-`--no-require-sandbox`.--The option `--sandbox-config-file` allows to specify the location of the-`cabal.sandbox.config` file (by default, `cabal` searches for it in the current-directory). This provides the same functionality as shared sandboxes, but-sometimes can be more convenient. Example:--~~~~~~~~~~~~~~~-$ mkdir my/sandbox-$ cd my/sandbox-$ cabal sandbox init-$ cd /path/to/my/project-$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install-# Uses the sandbox located at /path/to/my/sandbox/.cabal-sandbox-$ cd ~-$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install-# Still uses the same sandbox-~~~~~~~~~~~~~~~--The sandbox config file can be also specified via the `CABAL_SANDBOX_CONFIG`-environment variable.--Finally, the flag `--ignore-sandbox` lets you temporarily ignore an existing-sandbox:--~~~~~~~~~~~~~~~-$ mkdir my/sandbox-$ cd my/sandbox-$ cabal sandbox init-$ cabal --ignore-sandbox install text-# Installs 'text' in the user package database ('~/.cabal').-~~~~~~~~~~~~~~~--## Creating a binary package ##--When creating binary packages (e.g. for Red Hat or Debian) one needs to-create a tarball that can be sent to another system for unpacking in the-root directory:--~~~~~~~~~~~~~~~~-runhaskell Setup.hs configure --prefix=/usr-runhaskell Setup.hs build-runhaskell Setup.hs copy --destdir=/tmp/mypkg-tar -czf mypkg.tar.gz /tmp/mypkg/-~~~~~~~~~~~~~~~~--If the package contains a library, you need two additional steps:--~~~~~~~~~~~~~~~~-runhaskell Setup.hs register --gen-script-runhaskell Setup.hs unregister --gen-script-~~~~~~~~~~~~~~~~--This creates shell scripts `register.sh` and `unregister.sh`, which must-also be sent to the target system.  After unpacking there, the package-must be registered by running the `register.sh` script. The-`unregister.sh` script would be used in the uninstall procedure of the-package. Similar steps may be used for creating binary packages for-Windows.---The following options are understood by all commands:--`--help`, `-h` or `-?`-:   List the available options for the command.--`--verbose=`_n_ or `-v`_n_-:   Set the verbosity level (0-3). The normal level is 1; a missing _n_-    defaults to 2.--The various commands and the additional options they support are-described below. In the simple build infrastructure, any other options-will be reported as errors.--## setup configure ##--Prepare to build the package.  Typically, this step checks that the-target platform is capable of building the package, and discovers-platform-specific features that are needed during the build.--The user may also adjust the behaviour of later stages using the options-listed in the following subsections.  In the simple build-infrastructure, the values supplied via these options are recorded in a-private file read by later stages.--If a user-supplied `configure` script is run (see the section on-[system-dependent-parameters](developing-packages.html#system-dependent-parameters) or on-[complex packages](developing-packages.html#more-complex-packages)), it-is passed the `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`,-`--datadir`, `--libexecdir` and `--sysconfdir` options. In addition the-value of the `--with-compiler` option is passed in a `--with-hc` option-and all options specified with `--configure-option=` are passed on.--### Programs used for building ###--The following options govern the programs used to process the source-files of a package:--`--ghc` or `-g`, `--jhc`, `--lhc`, `--uhc`-:   Specify which Haskell implementation to use to build the package.-    At most one of these flags may be given. If none is given, the-    implementation under which the setup script was compiled or-    interpreted is used.--`--with-compiler=`_path_ or `-w`_path_-:   Specify the path to a particular compiler. If given, this must match-    the implementation selected above. The default is to search for the-    usual name of the selected implementation.--    This flag also sets the default value of the `--with-hc-pkg` option-    to the package tool for this compiler. Check the output of `setup-    configure -v` to ensure that it finds the right package tool (or use-    `--with-hc-pkg` explicitly).---`--with-hc-pkg=`_path_-:   Specify the path to the package tool, e.g. `ghc-pkg`. The package-    tool must be compatible with the compiler specified by-    `--with-compiler`. If this option is omitted, the default value is-    determined from the compiler selected.--`--with-`_`prog`_`=`_path_-:   Specify the path to the program _prog_. Any program known to Cabal-    can be used in place of _prog_. It can either be a fully path or the-    name of a program that can be found on the program search path. For-    example: `--with-ghc=ghc-6.6.1` or-    `--with-cpphs=/usr/local/bin/cpphs`.-    The full list of accepted programs is not enumerated in this user guide.-    Rather, run `cabal install --help` to view the list.--`--`_`prog`_`-options=`_options_-:   Specify additional options to the program _prog_. Any program known-    to Cabal can be used in place of _prog_. For example:-    `--alex-options="--template=mytemplatedir/"`. The _options_ is split-    into program options based on spaces. Any options containing embedded-    spaced need to be quoted, for example-    `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative-    that takes only one option at a time but avoids the need to quote,-    use `--`_`prog`_`-option` instead.--`--`_`prog`_`-option=`_option_-:   Specify a single additional option to the program _prog_. For-    passing an option that contain embedded spaces, such as a file name-    with embedded spaces, using this rather than `--`_`prog`_`-options`-    means you do not need an additional level of quoting. Of course if-    you are using a command shell you may still need to quote, for-    example `--foo-options="--bar=C:\Program File\Bar"`.--All of the options passed with either `--`_`prog`_`-options` or-`--`_`prog`_`-option` are passed in the order they were specified on the-configure command line.--### Installation paths ###--The following options govern the location of installed files from a-package:--`--prefix=`_dir_-:   The root of the installation. For example for a global install you-    might use `/usr/local` on a Unix system, or `C:\Program Files` on a-    Windows system. The other installation paths are usually-    subdirectories of _prefix_, but they don't have to be.--    In the simple build system, _dir_ may contain the following path-    variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`,-    `$arch`, `$abi`, `$abitag`--`--bindir=`_dir_-:   Executables that the user might invoke are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$pkgid`, `$pkg`, `$version`, `$compiler`,-    `$os`, `$arch`, `$abi`, `$abitag--`--libdir=`_dir_-:   Object-code libraries are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$bindir`, `$pkgid`, `$pkg`, `$version`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--libexecdir=`_dir_-:   Executables that are not expected to be invoked directly by the user-    are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`,-    `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--datadir`=_dir_-:   Architecture-independent data files are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--sysconfdir=`_dir_-:   Installation directory for the configuration files.--    In the simple build system, _dir_ may contain the following path variables:-    `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, `$version`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--In addition the simple build system supports the following installation path options:--`--libsubdir=`_dir_-:   A subdirectory of _libdir_ in which libraries are actually-    installed. For example, in the simple build system on Unix, the-    default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the-    package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so-    libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`.--    _dir_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--datasubdir=`_dir_-:   A subdirectory of _datadir_ in which data files are actually-    installed.--    _dir_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--docdir=`_dir_-:   Documentation files are installed relative to this directory.--    _dir_ may contain the following path variables: `$prefix`, `$bindir`,-    `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--htmldir=`_dir_-:   HTML documentation files are installed relative to this directory.--    _dir_ may contain the following path variables: `$prefix`, `$bindir`,-    `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$docdir`, `$pkgid`,-    `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--program-prefix=`_prefix_-:   Prepend _prefix_ to installed program names.--    _prefix_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--program-suffix=`_suffix_-:   Append _suffix_ to installed program names. The most obvious use for-    this is to append the program's version number to make it possible-    to install several versions of a program at once:-    `--program-suffix='$version'`.--    _suffix_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--#### Path variables in the simple build system ####--For the simple build system, there are a number of variables that can be-used when specifying installation paths. The defaults are also specified-in terms of these variables. A number of the variables are actually for-other paths, like `$prefix`. This allows paths to be specified relative-to each other rather than as absolute paths, which is important for-building relocatable packages (see [prefix-independence](#prefix-independence)).--`$prefix`-:   The path variable that stands for the root of the installation. For-    an installation to be relocatable, all other installation paths must-    be relative to the `$prefix` variable.--`$bindir`-:   The path variable that expands to the path given by the `--bindir`-    configure option (or the default).--`$libdir`-:   As above but for `--libdir`--`$libsubdir`-:   As above but for `--libsubdir`--`$datadir`-:   As above but for `--datadir`--`$datasubdir`-:   As above but for `--datasubdir`--`$docdir`-:   As above but for `--docdir`--`$pkgid`-:   The name and version of the package, e.g. `mypkg-0.2`--`$pkg`-:   The name of the package, e.g. `mypkg`--`$version`-:   The version of the package, e.g. `0.2`--`$compiler`-:   The compiler being used to build the package, e.g. `ghc-6.6.1`--`$os`-:   The operating system of the computer being used to build the-    package, e.g. `linux`, `windows`, `osx`, `freebsd` or `solaris`--`$arch`-:   The architecture of the computer being used to build the package, e.g.-    `i386`, `x86_64`, `ppc` or `sparc`--`$abitag`-:   An optional tag that a compiler can use for telling incompatible ABI's-    on the same architecture apart. GHCJS encodes the underlying GHC version-    in the ABI tag.--`$abi`-:   A shortcut for getting a path that completely identifies the platform in terms-    of binary compatibility. Expands to the same value as `$arch-$os-compiler-$abitag`-    if the compiler uses an abi tag, `$arch-$os-$compiler` if it doesn't.--#### Paths in the simple build system ####--For the simple build system, the following defaults apply:--Option                     Windows Default                                           Unix Default--------                    ----------------                                          --------------`--prefix` (global)        `C:\Program Files\Haskell`                                `/usr/local`-`--prefix` (per-user)      `C:\Documents And Settings\user\Application Data\cabal`   `$HOME/.cabal`-`--bindir`                 `$prefix\bin`                                             `$prefix/bin`-`--libdir`                 `$prefix`                                                 `$prefix/lib`-`--libsubdir` (others)     `$pkgid\$compiler`                                        `$pkgid/$compiler`-`--libexecdir`             `$prefix\$pkgid`                                          `$prefix/libexec`-`--datadir` (executable)   `$prefix`                                                 `$prefix/share`-`--datadir` (library)      `C:\Program Files\Haskell`                                `$prefix/share`-`--datasubdir`             `$pkgid`                                                  `$pkgid`-`--docdir`                 `$prefix\doc\$pkgid`                                      `$datadir/doc/$pkgid`-`--sysconfdir`             `$prefix\etc`                                             `$prefix/etc`-`--htmldir`                `$docdir\html`                                            `$docdir/html`-`--program-prefix`         (empty)                                                   (empty)-`--program-suffix`         (empty)                                                   (empty)---#### Prefix-independence ####--On Windows it is possible to obtain the pathname of the running program. This-means that we can construct an installable executable package that is-independent of its absolute install location. The executable can find its-auxiliary files by finding its own path and knowing the location of the other-files relative to `$bindir`.  Prefix-independence is particularly useful: it-means the user can choose the install location (i.e. the value of `$prefix`) at-install-time, rather than having to bake the path into the binary when it is-built.--In order to achieve this, we require that for an executable on Windows,-all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with-`$prefix`. If this is not the case then the compiled executable will-have baked-in all absolute paths.--The application need do nothing special to achieve prefix-independence.-If it finds any files using `getDataFileName` and the [other functions-provided for the-purpose](developing-packages.html#accessing-data-files-from-package-code),-the files will be accessed relative to the location of the current-executable.--A library cannot (currently) be prefix-independent, because it will be-linked into an executable whose file system location bears no relation-to the library package.--### Controlling Flag Assignments ###--Flag assignments (see the [resolution of conditions and-flags](developing-packages.html#resolution-of-conditions-and-flags)) can-be controlled with the following command line options.--`-f` _flagname_ or `-f` `-`_flagname_-:   Force the specified flag to `true` or `false` (if preceded with a `-`). Later-    specifications for the same flags will override earlier, i.e.,-    specifying `-fdebug -f-debug` is equivalent to `-f-debug`--`--flags=`_flagspecs_-:   Same as `-f`, but allows specifying multiple flag assignments at-    once. The parameter is a space-separated list of flag names (to-    force a flag to `true`), optionally preceded by a `-` (to force a-    flag to `false`). For example, `--flags="debug -feature1 feature2"` is-    equivalent to `-fdebug -f-feature1 -ffeature2`.--### Building Test Suites ###--`--enable-tests`-:   Build the test suites defined in the package description file during the-    `build` stage. Check for dependencies required by the test suites. If the-    package is configured with this option, it will be possible to run the test-    suites with the `test` command after the package is built.--`--disable-tests`-:   (default) Do not build any test suites during the `build` stage.-    Do not check for dependencies required only by the test suites. It will not-    be possible to invoke the `test` command without reconfiguring the package.--`--enable-coverage`-:   Build libraries and executables (including test suites) with Haskell-    Program Coverage enabled. Running the test suites will automatically-    generate coverage reports with HPC.--`--disable-coverage`-:   (default) Do not enable Haskell Program Coverage.--### Miscellaneous options ##--`--user`-:   Does a per-user installation. This changes the [default installation-    prefix](#paths-in-the-simple-build-system). It also allow-    dependencies to be satisfied by the user's package database, in-    addition to the global database. This also implies a default of-    `--user` for any subsequent `install` command, as packages-    registered in the global database should not depend on packages-    registered in a user's database.--`--global`-:   (default) Does a global installation. In this case package-    dependencies must be satisfied by the global package database. All-    packages in the user's package database will be ignored. Typically-    the final installation step will require administrative privileges.--`--package-db=`_db_-:   Allows package dependencies to be satisfied from this additional-    package database _db_ in addition to the global package database.-    All packages in the user's package database will be ignored. The-    interpretation of _db_ is implementation-specific. Typically it will-    be a file or directory. Not all implementations support arbitrary-    package databases.--`--default-user-config=` _file_-:   Allows a "default" `cabal.config` freeze file to be passed in-    manually. This file will only be used if one does not exist in the-    project directory already. Typically, this can be set from the global-    cabal `config` file so as to provide a default set of partial-    constraints to be used by projects, providing a way for users to peg-    themselves to stable package collections.--`--enable-optimization`[=_n_] or `-O`[_n_]-:   (default) Build with optimization flags (if available). This is-    appropriate for production use, taking more time to build faster-    libraries and programs.--    The optional _n_ value is the optimisation level. Some compilers-    support multiple optimisation levels. The range is 0 to 2. Level 0-    is equivalent to `--disable-optimization`, level 1 is the default if-    no _n_ parameter is given. Level 2 is higher optimisation if the-    compiler supports it. Level 2 is likely to lead to longer compile-    times and bigger generated code.--`--disable-optimization`-:   Build without optimization. This is suited for development: building-    will be quicker, but the resulting library or programs will be slower.--`--enable-profiling`-:   Build libraries and executables with profiling enabled (for compilers-    that support profiling as a separate mode). For this to work, all-    libraries used by this package must also have been built with profiling-    support. For libraries this involves building an additional instance of-    the library in addition to the normal non-profiling instance. For-    executables it changes the single executable to be built in profiling mode.--    This flag covers both libraries and executables, but can be overridden-    by the `--enable-library-profiling` flag.--    See also the `--profiling-detail` flag below.--`--disable-profiling`-:   (default) Do not enable profiling in generated libraries and executables.--`--enable-library-profiling` or `-p`-:   As with `--enable-profiling` above, but it applies only for libraries. So-    this generates an additional profiling instance of the library in addition-    to the normal non-profiling instance.--    The `--enable-profiling` flag controls the profiling mode for both-    libraries and executables, but if different modes are desired for-    libraries versus executables then use `--enable-library-profiling` as well.--`--disable-library-profiling`-:   (default) Do not generate an additional profiling version of the-    library.--`--profiling-detail`[=_level_]-:   Some compilers that support profiling, notably GHC, can allocate costs to-    different parts of the program and there are different levels of-    granularity or detail with which this can be done. In particular for GHC-    this concept is called "cost centers", and GHC can automatically add cost-    centers, and can do so in different ways.--    This flag covers both libraries and executables, but can be overridden-    by the `--library-profiling-detail` flag.--    Currently this setting is ignored for compilers other than GHC. The levels-    that cabal currently supports are:--    `default`-    :    For GHC this uses `exported-functions` for libraries and-         `toplevel-functions` for executables.--    `none`-    :    No costs will be assigned to any code within this component.--    `exported-functions`-    :    Costs will be assigned at the granularity of all top level functions-         exported from each module. In GHC specifically, this is for non-inline-         functions.--    `toplevel-functions`-    :    Costs will be assigned at the granularity of all top level functions-         in each module, whether they are exported from the module or not.-         In GHC specifically, this is for non-inline functions.--    `all-functions`-    :    Costs will be assigned at the granularity of all functions in each-         module, whether top level or local. In GHC specifically, this is for-         non-inline toplevel or where-bound functions or values.--    This flag is new in Cabal-1.24. Prior versions used the equivalent of-    `none` above.--`--library-profiling-detail`[=_level_]-:   As with `--profiling-detail` above, but it applies only for libraries.--    The level for both libraries and executables is set by the-    `--profiling-detail` flag, but if different levels are desired for-    libraries versus executables then use `--library-profiling-detail` as well.---`--enable-library-vanilla`-:   (default) Build ordinary libraries (as opposed to profiling-    libraries). This is independent of the `--enable-library-profiling`-    option. If you enable both, you get both.--`--disable-library-vanilla`-:   Do not build ordinary libraries. This is useful in conjunction with-    `--enable-library-profiling` to build only profiling libraries,-    rather than profiling and ordinary libraries.--`--enable-library-for-ghci`-:   (default) Build libraries suitable for use with GHCi.--`--disable-library-for-ghci`-:   Not all platforms support GHCi and indeed on some platforms, trying-    to build GHCi libs fails. In such cases this flag can be used as a-    workaround.--`--enable-split-objs`-:   Use the GHC `-split-objs` feature when building the library. This-    reduces the final size of the executables that use the library by-    allowing them to link with only the bits that they use rather than-    the entire library. The downside is that building the library takes-    longer and uses considerably more memory.--`--disable-split-objs`-:   (default) Do not use the GHC `-split-objs` feature. This makes-    building the library quicker but the final executables that use the-    library will be larger.--`--enable-executable-stripping`-:   (default) When installing binary executable programs, run the-    `strip` program on the binary. This can considerably reduce the size-    of the executable binary file. It does this by removing debugging-    information and symbols. While such extra information is useful for-    debugging C programs with traditional debuggers it is rarely helpful-    for debugging binaries produced by Haskell compilers.--    Not all Haskell implementations generate native binaries. For such-    implementations this option has no effect.--`--disable-executable-stripping`-:   Do not strip binary executables during installation. You might want-    to use this option if you need to debug a program using gdb, for-    example if you want to debug the C parts of a program containing-    both Haskell and C code. Another reason is if your are building a-    package for a system which has a policy of managing the stripping-    itself (such as some Linux distributions).--`--enable-shared`-:   Build shared library. This implies a separate compiler run to-    generate position independent code as required on most platforms.--`--disable-shared`-:   (default) Do not build shared library.--`--enable-executable-dynamic`-:   Link executables dynamically. The executable's library dependencies should-    be built as shared objects. This implies `--enable-shared` unless-    `--disable-shared` is explicitly specified.--`--disable-executable-dynamic`-:   (default) Link executables statically.--`--configure-option=`_str_-:   An extra option to an external `configure` script, if one is used-    (see the section on [system-dependent-    parameters](developing-packages.html#system-dependent-parameters)).-    There can be several of these options.--`--extra-include-dirs`[=_dir_]-:   An extra directory to search for C header files. You can use this-    flag multiple times to get a list of directories.--    You might need to use this flag if you have standard system header-    files in a non-standard location that is not mentioned in the-    package's `.cabal` file. Using this option has the same affect as-    appending the directory _dir_ to the `include-dirs` field in each-    library and executable in the package's `.cabal` file. The advantage-    of course is that you do not have to modify the package at all.-    These extra directories will be used while building the package and-    for libraries it is also saved in the package registration-    information and used when compiling modules that use the library.--`--extra-lib-dirs`[=_dir_]-:   An extra directory to search for system libraries files. You can use-    this flag multiple times to get a list of directories.--`--extra-framework-dirs`[=_dir_]-:   An extra directory to search for frameworks (OS X only). You can use this-    flag multiple times to get a list of directories.--    You might need to use this flag if you have standard system-    libraries in a non-standard location that is not mentioned in the-    package's `.cabal` file. Using this option has the same affect as-    appending the directory _dir_ to the `extra-lib-dirs` field in each-    library and executable in the package's `.cabal` file. The advantage-    of course is that you do not have to modify the package at all.-    These extra directories will be used while building the package and-    for libraries it is also saved in the package registration-    information and used when compiling modules that use the library.--`--allow-newer`[=_pkgs_]-:   Selectively relax upper bounds in dependencies without editing the-    package description.--    If you want to install a package A that depends on B >= 1.0 && < 2.0, but-    you have the version 2.0 of B installed, you can compile A against B 2.0 by-    using `cabal install --allow-newer=B A`. This works for the whole package-    index: if A also depends on C that in turn depends on B < 2.0, C's-    dependency on B will be also relaxed.--    Example:--    ~~~~~~~~~~~~~~~~-    $ cd foo-    $ cabal configure-    Resolving dependencies...-    cabal: Could not resolve dependencies:-    [...]-    $ cabal configure --allow-newer-    Resolving dependencies...-    Configuring foo...-    ~~~~~~~~~~~~~~~~--    Additional examples:--    ~~~~~~~~~~~~~~~~-    # Relax upper bounds in all dependencies.-    $ cabal install --allow-newer foo--    # Relax upper bounds only in dependencies on bar, baz and quux.-    $ cabal install --allow-newer=bar,baz,quux foo--    # Relax the upper bound on bar and force bar==2.1.-    $ cabal install --allow-newer=bar --constraint="bar==2.1" foo-    ~~~~~~~~~~~~~~~~--    It's also possible to limit the scope of `--allow-newer` to single-    packages with the `--allow-newer=scope:dep` syntax. This means that the-    dependency on `dep` will be relaxed only for the package `scope`.--    Example:--    ~~~~~~~~~~~~~~~~-    # Relax upper bound in foo's dependency on base; also relax upper bound in-    # every package's dependency on lens.-    $ cabal install --allow-newer=foo:base,lens--    # Relax upper bounds in foo's dependency on base and bar's dependency-    # on time; also relax the upper bound in the dependency on lens specified by-    # any package.-    $ cabal install --allow-newer=foo:base,lens --allow-newer=bar:time-    ~~~~~~~~~~~~~~~~--    Finally, one can enable `--allow-newer` permanently by setting `allow-newer:-    True` in the `~/.cabal/config` file. Enabling 'allow-newer' selectively is-    also supported in the config file (`allow-newer: foo, bar, baz:base`).--`--constraint=`_constraint_-:   Restrict solutions involving a package to a given version range.-    For example, `cabal install --constraint="bar==2.1"` will only consider-    install plans that do not use `bar` at all, or `bar` of version 2.1.--    As a special case, `cabal install --constraint="bar -none"` prevents `bar`-    from being used at all (`-none` abbreviates `> 1 && < 1`); `cabal install-    --constraint="bar installed"` prevents reinstallation of the `bar` package;-    `cabal install --constraint="bar +foo -baz"` specifies that the flag `foo`-    should be turned on and the `baz` flag should be turned off.--## setup build ##--Perform any preprocessing or compilation needed to make this package ready for installation.--This command takes the following options:----_prog_-options=_options_, --_prog_-option=_option_-:   These are mostly the same as the [options configure-    step](#setup-configure). Unlike the options specified at the-    configure step, any program options specified at the build step are-    not persistent but are used for that invocation only. They options-    specified at the build step are in addition not in replacement of-    any options specified at the configure step.--## setup haddock ##--Build the documentation for the package using [haddock][]. By default,-only the documentation for the exposed modules is generated (but see the-`--executables` and `--internal` flags below).--This command takes the following options:--`--hoogle`-:   Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be-    converted by [Hoogle](http://www.haskell.org/hoogle/) into a-    database for searching. This is equivalent to running  [haddock][]-    with the `--hoogle` flag.--`--html-location=`_url_-:   Specify a template for the location of HTML documentation for-    prerequisite packages.  The substitutions ([see-    listing](#paths-in-the-simple-build-system)) are applied to the-    template to obtain a location for each package, which will be used-    by hyperlinks in the generated documentation. For example, the-    following command generates links pointing at [Hackage] pages:--    > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html'--    Here the argument is quoted to prevent substitution by the shell. If-    this option is omitted, the location for each package is obtained-    using the package tool (e.g. `ghc-pkg`).--`--executables`-:   Also run [haddock][] for the modules of all the executable programs.-    By default [haddock][] is run only on the exported modules.--`--internal`-:   Run [haddock][] for the all modules, including unexposed ones, and-    make [haddock][] generate documentation for unexported symbols as-    well.--`--css=`_path_-:   The argument _path_ denotes a CSS file, which is passed to-    [haddock][] and used to set the style of the generated-    documentation. This is only needed to override the default style-    that [haddock][] uses.--`--hyperlink-source`-:   Generate [haddock][] documentation integrated with [HsColour][].-    First, [HsColour][] is run to generate colourised code. Then-    [haddock][] is run to generate HTML documentation.  Each entity-    shown in the documentation is linked to its definition in the-    colourised code.--`--hscolour-css=`_path_-:   The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in--    > runhaskell Setup.hs hscolour --css=_path_--## setup hscolour ##--Produce colourised code in HTML format using [HsColour][]. Colourised-code for exported modules is put in `dist/doc/html/`_pkgid_`/src`.--This command takes the following options:--`--executables`-:   Also run [HsColour][] on the sources of all executable programs.-    Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`.--`--css=`_path_-:   Use the given CSS file for the generated HTML files. The CSS file-    defines the colours used to colourise code. Note that this copies-    the given CSS file to the directory with the generated HTML files-    (renamed to `hscolour.css`) rather than linking to it.--## setup install ##--Copy the files into the install locations and (for library packages)-register the package with the compiler, i.e. make the modules it-contains available to programs.--The [install locations](#installation-paths) are determined by options-to `setup configure`.--This command takes the following options:--`--global`-:   Register this package in the system-wide database. (This is the-    default, unless the `--user` option was supplied to the `configure`-    command.)--`--user`-:   Register this package in the user's local package database. (This is-    the default if the `--user` option was supplied to the `configure`-    command.)--## setup copy ##--Copy the files without registering them.  This command is mainly of use-to those creating binary packages.--This command takes the following option:--`--destdir=`_path_--Specify the directory under which to place installed files.  If this is-not given, then the root directory is assumed.--## setup register ##--Register this package with the compiler, i.e. make the modules it-contains available to programs. This only makes sense for library-packages. Note that the `install` command incorporates this action.  The-main use of this separate command is in the post-installation step for a-binary package.--This command takes the following options:--`--global`-:   Register this package in the system-wide database. (This is the default.)---`--user`-:   Register this package in the user's local package database.---`--gen-script`-:   Instead of registering the package, generate a script containing-    commands to perform the registration.  On Unix, this file is called-    `register.sh`, on Windows, `register.bat`.  This script might be-    included in a binary bundle, to be run after the bundle is unpacked-    on the target system.--`--gen-pkg-config`[=_path_]-:   Instead of registering the package, generate a package registration-    file. This only applies to compilers that support package-    registration files which at the moment is only GHC. The file should-    be used with the compiler's mechanism for registering packages. This-    option is mainly intended for packaging systems. If possible use the-    `--gen-script` option instead since it is more portable across-    Haskell implementations. The _path_ is-    optional and can be used to specify a particular output file to-    generate. Otherwise, by default the file is the package name and-    version with a `.conf` extension.--`--inplace`-:   Registers the package for use directly from the build tree, without-    needing to install it.  This can be useful for testing: there's no-    need to install the package after modifying it, just recompile and-    test.--    This flag does not create a build-tree-local package database.  It-    still registers the package in one of the user or global databases.--    However, there are some caveats.  It only works with GHC-    (currently).  It only works if your package doesn't depend on having-    any supplemental files installed --- plain Haskell libraries should-    be fine.--## setup unregister ##--Deregister this package with the compiler.--This command takes the following options:--`--global`-:   Deregister this package in the system-wide database. (This is the default.)--`--user`-:   Deregister this package in the user's local package database.--`--gen-script`-:   Instead of deregistering the package, generate a script containing-    commands to perform the deregistration.  On Unix, this file is-    called `unregister.sh`, on Windows, `unregister.bat`. This script-    might be included in a binary bundle, to be run on the target-    system.--## setup clean ##--Remove any local files created during the `configure`, `build`,-`haddock`, `register` or `unregister` steps, and also any files and-directories listed in the `extra-tmp-files` field.--This command takes the following options:--`--save-configure` or `-s`-:   Keeps the configuration information so it is not necessary to run-    the configure step again before building.--## setup test ##--Run the test suites specified in the package description file.  Aside from-the following flags, Cabal accepts the name of one or more test suites on the-command line after `test`.  When supplied, Cabal will run only the named test-suites, otherwise, Cabal will run all test suites in the package.--`--builddir=`_dir_-:   The directory where Cabal puts generated build files (default: `dist`).-    Test logs will be located in the `test` subdirectory.--`--human-log=`_path_-:   The template used to name human-readable test logs; the path is relative-    to `dist/test`.  By default, logs are named according to the template-    `$pkgid-$test-suite.log`, so that each test suite will be logged to its own-    human-readable log file.  Template variables allowed are: `$pkgid`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`, `$test-suite`, and `$result`.--`--machine-log=`_path_-:   The path to the machine-readable log, relative to `dist/test`.  The default-    template is `$pkgid.log`.  Template variables allowed are: `$pkgid`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` and `$result`.--`--show-details=`_filter_-:   Determines if the results of individual test cases are shown on the-    terminal.  May be `always` (always show), `never` (never show), `failures`-    (show only failed results), or `streaming` (show all results in real time).--`--test-options=`_options_-:   Give extra options to the test executables.--`--test-option=`_option_-:   give an extra option to the test executables.  There is no need to quote-    options containing spaces because a single option is assumed, so options-    will not be split on spaces.--## setup sdist ##--Create a system- and compiler-independent source distribution in a file-_package_-_version_`.tar.gz` in the `dist` subdirectory, for-distribution to package builders.  When unpacked, the commands listed in-this section will be available.--The files placed in this distribution are the package description file,-the setup script, the sources of the modules named in the package-description file, and files named in the `license-file`, `main-is`,-`c-sources`, `js-sources`, `data-files`, `extra-source-files` and-`extra-doc-files` fields.--This command takes the following option:--`--snapshot`-:   Append today's date (in "YYYYMMDD" format) to the version number for-    the generated source package.  The original package is unaffected.---[dist-simple]:  ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html-[dist-make]:    ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html-[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License-[extension]:    ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType-[alex]:       http://www.haskell.org/alex/-[autoconf]:   http://www.gnu.org/software/autoconf/-[c2hs]:       http://www.cse.unsw.edu.au/~chak/haskell/c2hs/-[cpphs]:      http://projects.haskell.org/cpphs/-[greencard]:  http://hackage.haskell.org/package/greencard-[haddock]:    http://www.haskell.org/haddock/-[HsColour]:   http://www.cs.york.ac.uk/fp/darcs/hscolour/-[happy]:      http://www.haskell.org/happy/-[Hackage]:    http://hackage.haskell.org/-[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/
+ cabal/Cabal/doc/installing-packages.rst view
@@ -0,0 +1,1619 @@+Configuration+=============++.. highlight:: cabal++Overview+--------++The global configuration file for ``cabal-install`` is+``~/.cabal/config``. If you do not have this file, ``cabal`` will create+it for you on the first call to ``cabal update``. Alternatively, you can+explicitly ask ``cabal`` to create it for you using++.. code-block:: console++    $ cabal user-config update++Most of the options in this configuration file are also available as+command line arguments, and the corresponding documentation can be used+to lookup their meaning. The created configuration file only specifies+values for a handful of options. Most options are left at their default+value, which it documents; for instance,++::++    -- executable-stripping: True++means that the configuration file currently does not specify a value for+the ``executable-stripping`` option (the line is commented out), and+that the default is ``True``; if you wanted to disable stripping of+executables by default, you would change this line to++::++    executable-stripping: False++You can also use ``cabal user-config update`` to migrate configuration+files created by older versions of ``cabal``.++Repository specification+------------------------++An important part of the configuration if the specification of the+repository. When ``cabal`` creates a default config file, it configures+the repository to be the central Hackage server:++::++    repository hackage.haskell.org+      url: http://hackage.haskell.org/++The name of the repository is given on the first line, and can be+anything; packages downloaded from this repository will be cached under+``~/.cabal/packages/hackage.haskell.org`` (or whatever name you specify;+you can change the prefix by changing the value of+``remote-repo-cache``). If you want, you can configure multiple+repositories, and ``cabal`` will combine them and be able to download+packages from any of them.++Using secure repositories+^^^^^^^^^^^^^^^^^^^^^^^^^++For repositories that support the TUF security infrastructure (this+includes Hackage), you can enable secure access to the repository by+specifying:++::++    repository hackage.haskell.org+      url: http://hackage.haskell.org/+      secure: True+      root-keys: <root-key-IDs>+      key-threshold: <key-threshold>++The ``<root-key-IDs>`` and ``<key-threshold>`` values are used for+bootstrapping. As part of the TUF infrastructure the repository will+contain a file ``root.json`` (for instance,+http://hackage.haskell.org/root.json) which the client needs to do+verification. However, how can ``cabal`` verify the ``root.json`` file+*itself*? This is known as bootstrapping: if you specify a list of root+key IDs and a corresponding threshold, ``cabal`` will verify that the+downloaded ``root.json`` file has been signed with at least+``<key-threshold>`` keys from your set of ``<root-key-IDs>``.++You can, but are not recommended to, omit these two fields. In that case+``cabal`` will download the ``root.json`` field and use it without+verification. Although this bootstrapping step is then unsafe, all+subsequent access is secure (provided that the downloaded ``root.json``+was not tempered with). Of course, adding ``root-keys`` and+``key-threshold`` to your repository specification only shifts the+problem, because now you somehow need to make sure that the key IDs you+received were the right ones. How that is done is however outside the+scope of ``cabal`` proper.++More information about the security infrastructure can be found at+https://github.com/well-typed/hackage-security.++Legacy repositories+^^^^^^^^^^^^^^^^^^^++Currently ``cabal`` supports two kinds of “legacy” repositories. The+first is specified using++::++    remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive++This is just syntactic sugar for++::++    repository hackage.haskell.org+      url: hackage.haskell.org:http://hackage.haskell.org/packages/archive++although, in (and only in) the specific case of Hackage, the URL+``http://hackage.haskell.org/packages/archive`` will be silently+translated to ``http://hackage.haskell.org/``.++The second kind of legacy repositories are so-called “local”+repositories:++::++    local-repo: my-local-repo:/path/to/local/repo++This can be used to access repositories on the local file system.+However, the layout of these local repositories is different from the+layout of remote repositories, and usage of these local repositories is+deprecated.++Secure local repositories+^^^^^^^^^^^^^^^^^^^^^^^^^++If you want to use repositories on your local file system, it is+recommended instead to use a *secure* local repository:++::++    repository my-local-repo+      url: file:/path/to/local/repo+      secure: True+      root-keys: <root-key-IDs>+      key-threshold: <key-threshold>++The layout of these secure local repos matches the layout of remote+repositories exactly; the :hackage-pkg:`hackage-repo-tool`+can be used to create and manage such repositories.++.. _installing-packages:++Building and installing packages+================================++.. highlight:: console++After you've unpacked a Cabal package, you can build it by moving into+the root directory of the package and running the ``cabal`` tool there:++::++    $ cabal [command] [option...]++The *command* argument selects a particular step in the build/install+process.++You can also get a summary of the command syntax with++::++    $ cabal help++Alternatively, you can also use the ``Setup.hs`` or ``Setup.lhs``+script:++::++    $ runhaskell Setup.hs [command] [option...]++For the summary of the command syntax, run:++::++    $ cabal help++or++::++    $ runhaskell Setup.hs --help++Building and installing a system package+----------------------------------------++::++    $ runhaskell Setup.hs configure --ghc+    $ runhaskell Setup.hs build+    $ runhaskell Setup.hs install++The first line readies the system to build the tool using GHC; for+example, it checks that GHC exists on the system. The second line+performs the actual building, while the last both copies the build+results to some permanent place and registers the package with GHC.++Building and installing a user package+--------------------------------------++::++    $ runhaskell Setup.hs configure --user+    $ runhaskell Setup.hs build+    $ runhaskell Setup.hs install++The package is installed under the user's home directory and is+registered in the user's package database (:option:`setup configure --user`).++Installing packages from Hackage+--------------------------------++The ``cabal`` tool also can download, configure, build and install a+Hackage_ package and all of its+dependencies in a single step. To do this, run:++::++   $ cabal install [PACKAGE...]++To browse the list of available packages, visit the+Hackage_ web site.++Developing with sandboxes+-------------------------++By default, any dependencies of the package are installed into the+global or user package databases (e.g. using+``cabal install --only-dependencies``). If you're building several+different packages that have incompatible dependencies, this can cause+the build to fail. One way to avoid this problem is to build each+package in an isolated environment ("sandbox"), with a sandbox-local+package database. Because sandboxes are per-project, inconsistent+dependencies can be simply disallowed.++For more on sandboxes, see also `this+article <http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html>`__.++Sandboxes: basic usage+^^^^^^^^^^^^^^^^^^^^^^++To initialise a fresh sandbox in the current directory, run+``cabal sandbox init``. All subsequent commands (such as ``build`` and+``install``) from this point will use the sandbox.++::++    $ cd /path/to/my/haskell/library+    $ cabal sandbox init                   # Initialise the sandbox+    $ cabal install --only-dependencies    # Install dependencies into the sandbox+    $ cabal build                          # Build your package inside the sandbox++It can be useful to make a source package available for installation in+the sandbox - for example, if your package depends on a patched or an+unreleased version of a library. This can be done with the+``cabal sandbox add-source`` command - think of it as "local Hackage_".+If an add-source dependency is later modified, it is reinstalled automatically.++::++    $ cabal sandbox add-source /my/patched/library # Add a new add-source dependency+    $ cabal install --dependencies-only            # Install it into the sandbox+    $ cabal build                                  # Build the local package+    $ $EDITOR /my/patched/library/Source.hs        # Modify the add-source dependency+    $ cabal build                                  # Modified dependency is automatically reinstalled++Normally, the sandbox settings (such as optimisation level) are+inherited from the main Cabal config file (``$HOME/cabal/config``).+Sometimes, though, you need to change some settings specifically for a+single sandbox. You can do this by creating a ``cabal.config`` file in+the same directory with your ``cabal.sandbox.config`` (which was created+by ``sandbox init``). This file has the same syntax as the main Cabal+config file.++::++    $ cat cabal.config+    documentation: True+    constraints: foo == 1.0, bar >= 2.0, baz+    $ cabal build                                  # Uses settings from the cabal.config file++When you have decided that you no longer want to build your package+inside a sandbox, just delete it:++::++    $ cabal sandbox delete                       # Built-in command+    $ rm -rf .cabal-sandbox cabal.sandbox.config # Alternative manual method++Sandboxes: advanced usage+^^^^^^^^^^^^^^^^^^^^^^^^^++The default behaviour of the ``add-source`` command is to track+modifications done to the added dependency and reinstall the sandbox+copy of the package when needed. Sometimes this is not desirable: in+these cases you can use ``add-source --snapshot``, which disables the+change tracking. In addition to ``add-source``, there are also+``list-sources`` and ``delete-source`` commands.++Sometimes one wants to share a single sandbox between multiple packages.+This can be easily done with the ``--sandbox`` option:++::++    $ mkdir -p /path/to/shared-sandbox+    $ cd /path/to/shared-sandbox+    $ cabal sandbox init --sandbox .+    $ cd /path/to/package-a+    $ cabal sandbox init --sandbox /path/to/shared-sandbox+    $ cd /path/to/package-b+    $ cabal sandbox init --sandbox /path/to/shared-sandbox++Note that ``cabal sandbox init --sandbox .`` puts all sandbox files into+the current directory. By default, ``cabal sandbox init`` initialises a+new sandbox in a newly-created subdirectory of the current working+directory (``./.cabal-sandbox``).++Using multiple different compiler versions simultaneously is also+supported, via the ``-w`` option:++::++    $ cabal sandbox init+    $ cabal install --only-dependencies -w /path/to/ghc-1 # Install dependencies for both compilers+    $ cabal install --only-dependencies -w /path/to/ghc-2+    $ cabal configure -w /path/to/ghc-1                   # Build with the first compiler+    $ cabal build+    $ cabal configure -w /path/to/ghc-2                   # Build with the second compiler+    $ cabal build++It can be occasionally useful to run the compiler-specific package+manager tool (e.g. ``ghc-pkg``) tool on the sandbox package DB directly+(for example, you may need to unregister some packages). The+``cabal sandbox hc-pkg`` command is a convenient wrapper that runs the+compiler-specific package manager tool with the arguments:++::++    $ cabal -v sandbox hc-pkg list+    Using a sandbox located at /path/to/.cabal-sandbox+    'ghc-pkg' '--global' '--no-user-package-conf'+        '--package-conf=/path/to/.cabal-sandbox/i386-linux-ghc-7.4.2-packages.conf.d'+        'list'+    [...]++The ``--require-sandbox`` option makes all sandbox-aware commands+(``install``/``build``/etc.) exit with error if there is no sandbox+present. This makes it harder to accidentally modify the user package+database. The option can be also turned on via the per-user+configuration file (``~/.cabal/config``) or the per-project one+(``$PROJECT_DIR/cabal.config``). The error can be squelched with+``--no-require-sandbox``.++The option ``--sandbox-config-file`` allows to specify the location of+the ``cabal.sandbox.config`` file (by default, ``cabal`` searches for it+in the current directory). This provides the same functionality as+shared sandboxes, but sometimes can be more convenient. Example:++::++    $ mkdir my/sandbox+    $ cd my/sandbox+    $ cabal sandbox init+    $ cd /path/to/my/project+    $ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install+    # Uses the sandbox located at /path/to/my/sandbox/.cabal-sandbox+    $ cd ~+    $ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install+    # Still uses the same sandbox++The sandbox config file can be also specified via the+``CABAL_SANDBOX_CONFIG`` environment variable.++Finally, the flag ``--ignore-sandbox`` lets you temporarily ignore an+existing sandbox:++::++    $ mkdir my/sandbox+    $ cd my/sandbox+    $ cabal sandbox init+    $ cabal --ignore-sandbox install text+    # Installs 'text' in the user package database ('~/.cabal').++Creating a binary package+-------------------------++When creating binary packages (e.g. for Red Hat or Debian) one needs to+create a tarball that can be sent to another system for unpacking in the+root directory:++::++    $ runhaskell Setup.hs configure --prefix=/usr+    $ runhaskell Setup.hs build+    $ runhaskell Setup.hs copy --destdir=/tmp/mypkg+    $ tar -czf mypkg.tar.gz /tmp/mypkg/++If the package contains a library, you need two additional steps:++::++    $ runhaskell Setup.hs register --gen-script+    $ runhaskell Setup.hs unregister --gen-script++This creates shell scripts ``register.sh`` and ``unregister.sh``, which+must also be sent to the target system. After unpacking there, the+package must be registered by running the ``register.sh`` script. The+``unregister.sh`` script would be used in the uninstall procedure of the+package. Similar steps may be used for creating binary packages for+Windows.++The following options are understood by all commands:++.. program:: setup++.. option:: --help, -h or -?++    List the available options for the command.++.. option:: --verbose=n or -v n++    Set the verbosity level (0-3). The normal level is 1; a missing *n*+    defaults to 2.++    There is also an extended version of this command which can be+    used to fine-tune the verbosity of output.  It takes the+    form ``[silent|normal|verbose|debug]``\ *flags*, where *flags*+    is a list of ``+`` flags which toggle various aspects of+    output.  At the moment, only ``+callsite`` and ``+callstack``+    are supported, which respectively toggle call site and call+    stack printing (these are only supported if Cabal+    is built with a sufficiently recent GHC.)++The various commands and the additional options they support are+described below. In the simple build infrastructure, any other options+will be reported as errors.++.. _setup-configure:++setup configure+---------------++.. program:: setup configure++Prepare to build the package. Typically, this step checks that the+target platform is capable of building the package, and discovers+platform-specific features that are needed during the build.++The user may also adjust the behaviour of later stages using the options+listed in the following subsections. In the simple build infrastructure,+the values supplied via these options are recorded in a private file+read by later stages.++If a user-supplied ``configure`` script is run (see the section on+`system-dependent+parameters <developing-packages.html#system-dependent-parameters>`__ or+on `complex+packages <developing-packages.html#more-complex-packages>`__), it is+passed the :option:`--with-hc-pkg`, :option:`--prefix`, :option:`--bindir`,+:option:`--libdir`, :option:`--dynlibdir`, :option:`--datadir`, :option:`--libexecdir` and+:option:`--sysconfdir` options. In addition the value of the+:option:`--with-compiler` option is passed in a :option:`--with-hc-pkg` option+and all options specified with :option:`--configure-option` are passed on.++In Cabal 2.0, support for a single positional argument was added to+``setup configure`` This makes Cabal configure a the specific component+to be configured. Specified names can be qualified with ``lib:`` or+``exe:`` in case just a name is ambiguous (as would be the case for a+package named ``p`` which has a library and an executable named ``p``.)+This has the following effects:++-  Subsequent invocations of ``cabal build``, ``register``, etc. operate only+   on the configured component.++-  Cabal requires all "internal" dependencies (e.g., an executable+   depending on a library defined in the same package) must be found in+   the set of databases via :option:`--package-db` (and related flags): these+   dependencies are assumed to be up-to-date. A dependency can be+   explicitly specified using :option:`--dependency` simply by giving the name+   of the internal library; e.g., the dependency for an internal library+   named ``foo`` is given as+   ``--dependency=pkg-internal=pkg-1.0-internal-abcd``.++-  Only the dependencies needed for the requested component are+   required. Similarly, when :option:`--exact-configuration` is specified,+   it's only necessary to specify :option:`--dependency` for the component.+   (As mentioned previously, you *must* specify internal dependencies as+   well.)++-  Internal ``build-tools`` dependencies are expected to be in the+   ``PATH`` upon subsequent invocations of ``setup``.++Full details can be found in the `Componentized Cabal+proposal <https://github.com/ezyang/ghc-proposals/blob/master/proposals/0000-componentized-cabal.rst>`__.++Programs used for building+^^^^^^^^^^^^^^^^^^^^^^^^^^++The following options govern the programs used to process the source+files of a package:++.. option:: --ghc or -g, --jhc, --lhc, --uhc++    Specify which Haskell implementation to use to build the package. At+    most one of these flags may be given. If none is given, the+    implementation under which the setup script was compiled or+    interpreted is used.++.. option:: --with-compiler=path or -w *path*++    Specify the path to a particular compiler. If given, this must match+    the implementation selected above. The default is to search for the+    usual name of the selected implementation.++    This flag also sets the default value of the :option:`--with-hc-pkg`+    option to the package tool for this compiler. Check the output of+    ``setup configure -v`` to ensure that it finds the right package+    tool (or use :option:`--with-hc-pkg` explicitly).++.. option:: --with-hc-pkg=path++    Specify the path to the package tool, e.g. ``ghc-pkg``. The package+    tool must be compatible with the compiler specified by+    :option:`--with-compiler`. If this option is omitted, the default value is+    determined from the compiler selected.++.. option:: --with-prog=path++    Specify the path to the program *prog*. Any program known to Cabal+    can be used in place of *prog*. It can either be a fully path or the+    name of a program that can be found on the program search path. For+    example: ``--with-ghc=ghc-6.6.1`` or+    ``--with-cpphs=/usr/local/bin/cpphs``. The full list of accepted+    programs is not enumerated in this user guide. Rather, run+    ``cabal install --help`` to view the list.++.. option:: --prog-options=options++    Specify additional options to the program *prog*. Any program known+    to Cabal can be used in place of *prog*. For example:+    ``--alex-options="--template=mytemplatedir/"``. The *options* is+    split into program options based on spaces. Any options containing+    embedded spaced need to be quoted, for example+    ``--foo-options='--bar="C:\Program File\Bar"'``. As an alternative+    that takes only one option at a time but avoids the need to quote,+    use :option:`--prog-option` instead.++.. option:: --prog-option=option++    Specify a single additional option to the program *prog*. For+    passing an option that contain embedded spaces, such as a file name+    with embedded spaces, using this rather than :option:`--prog-options`+    means you do not need an additional level of quoting. Of course if you+    are using a command shell you may still need to quote, for example+    ``--foo-options="--bar=C:\Program File\Bar"``.++All of the options passed with either :option:`--prog-options`+or :option:`--prog-option` are passed in the order they were+specified on the configure command line.++Installation paths+^^^^^^^^^^^^^^^^^^++The following options govern the location of installed files from a+package:++.. option:: --prefix=dir++    The root of the installation. For example for a global install you+    might use ``/usr/local`` on a Unix system, or ``C:\Program Files``+    on a Windows system. The other installation paths are usually+    subdirectories of *prefix*, but they don't have to be.++    In the simple build system, *dir* may contain the following path+    variables: ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``,+    ``$os``, ``$arch``, ``$abi``, ``$abitag``++.. option:: --bindir=dir++    Executables that the user might invoke are installed here.++    In the simple build system, *dir* may contain the following path+    variables: ``$prefix``, ``$pkgid``, ``$pkg``, ``$version``,+    ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag``++.. option:: --libdir=dir++    Object-code libraries are installed here.++    In the simple build system, *dir* may contain the following path+    variables: ``$prefix``, ``$bindir``, ``$pkgid``, ``$pkg``,+    ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++.. option:: --dynlibdir=dir++    Dynamic libraries are installed here.++    By default, this is set to `$libdir/$abi`, which is usually not equal to+    `$libdir/$libsubdir`.++    In the simple build system, *dir* may contain the following path+    variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$pkgid``, ``$pkg``,+    ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++.. option:: --libexecdir=dir++    Executables that are not expected to be invoked directly by the user+    are installed here.++    In the simple build system, *dir* may contain the following path+    variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``,+    ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``,+    ``$arch``, ``$abi``, ``$abitag``++.. option:: --datadir=dir++    Architecture-independent data files are installed here.++    In the simple build system, *dir* may contain the following path+    variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``,+    ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``,+    ``$arch``, ``$abi``, ``$abitag``++.. option:: --sysconfdir=dir++    Installation directory for the configuration files.++    In the simple build system, *dir* may contain the following path+    variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``,+    ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``,+    ``$arch``, ``$abi``, ``$abitag``++In addition the simple build system supports the following installation+path options:++.. option:: --libsubdir=dir++    A subdirectory of *libdir* in which libraries are actually+    installed. For example, in the simple build system on Unix, the+    default *libdir* is ``/usr/local/lib``, and *libsubdir* contains the+    package identifier and compiler, e.g. ``mypkg-0.2/ghc-6.4``, so+    libraries would be installed in+    ``/usr/local/lib/mypkg-0.2/ghc-6.4``.++    *dir* may contain the following path variables: ``$pkgid``,+    ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++.. option:: --datasubdir=dir++    A subdirectory of *datadir* in which data files are actually+    installed.++    *dir* may contain the following path variables: ``$pkgid``,+    ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++.. option:: --docdir=dir++    Documentation files are installed relative to this directory.++    *dir* may contain the following path variables: ``$prefix``,+    ``$bindir``, ``$libdir``, ``$libsubdir``, ``$datadir``,+    ``$datasubdir``, ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``,+    ``$os``, ``$arch``, ``$abi``, ``$abitag``++.. option:: --htmldir=dir++    HTML documentation files are installed relative to this directory.++    *dir* may contain the following path variables: ``$prefix``,+    ``$bindir``, ``$libdir``, ``$libsubdir``, ``$datadir``,+    ``$datasubdir``, ``$docdir``, ``$pkgid``, ``$pkg``, ``$version``,+    ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag``++.. option:: --program-prefix=prefix++    Prepend *prefix* to installed program names.++    *prefix* may contain the following path variables: ``$pkgid``,+    ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++.. option:: --program-suffix=suffix++    Append *suffix* to installed program names. The most obvious use for+    this is to append the program's version number to make it possible+    to install several versions of a program at once:+    ``--program-suffix='$version'``.++    *suffix* may contain the following path variables: ``$pkgid``,+    ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++Path variables in the simple build system+"""""""""""""""""""""""""""""""""""""""""++For the simple build system, there are a number of variables that can be+used when specifying installation paths. The defaults are also specified+in terms of these variables. A number of the variables are actually for+other paths, like ``$prefix``. This allows paths to be specified+relative to each other rather than as absolute paths, which is important+for building relocatable packages (see `prefix+independence <#prefix-independence>`__).++$prefix+    The path variable that stands for the root of the installation. For+    an installation to be relocatable, all other installation paths must+    be relative to the ``$prefix`` variable.+$bindir+    The path variable that expands to the path given by the :option:`--bindir`+    configure option (or the default).+$libdir+    As above but for :option:`--libdir`+$libsubdir+    As above but for :option:`--libsubdir`+$dynlibdir+    As above but for :option:`--dynlibdir`+$datadir+    As above but for :option:`--datadir`+$datasubdir+    As above but for :option:`--datasubdir`+$docdir+    As above but for :option:`--docdir`+$pkgid+    The name and version of the package, e.g. ``mypkg-0.2``+$pkg+    The name of the package, e.g. ``mypkg``+$version+    The version of the package, e.g. ``0.2``+$compiler+    The compiler being used to build the package, e.g. ``ghc-6.6.1``+$os+    The operating system of the computer being used to build the+    package, e.g. ``linux``, ``windows``, ``osx``, ``freebsd`` or+    ``solaris``+$arch+    The architecture of the computer being used to build the package,+    e.g. ``i386``, ``x86_64``, ``ppc`` or ``sparc``+$abitag+    An optional tag that a compiler can use for telling incompatible+    ABI's on the same architecture apart. GHCJS encodes the underlying+    GHC version in the ABI tag.+$abi+    A shortcut for getting a path that completely identifies the+    platform in terms of binary compatibility. Expands to the same value+    as ``$arch-$os-compiler-$abitag`` if the compiler uses an abi tag,+    ``$arch-$os-$compiler`` if it doesn't.++Paths in the simple build system+""""""""""""""""""""""""""""""""++For the simple build system, the following defaults apply:++.. list-table:: Default installation paths++    * - Option+      - Unix Default+      - Windows Default+    * - :option:`--prefix` (global)+      - ``/usr/local``+      - ``%PROGRAMFILES%\Haskell``+    * - :option:`--prefix` (per-user)+      - ``$HOME/.cabal``+      - ``%APPDATA%\cabal``+    * - :option:`--bindir`+      - ``$prefix/bin``+      - ``$prefix\bin``+    * - :option:`--libdir`+      - ``$prefix/lib``+      - ``$prefix``+    * - :option:`--libsubdir` (others)+      - ``$pkgid/$compiler``+      - ``$pkgid\$compiler``+    * - :option:`--dynlibdir`+      - ``$libdir/$abi``+      - ``$libdir\$abi``+    * - :option:`--libexecdir`+      - ``$prefix/libexec``+      - ``$prefix\$pkgid``+    * - :option:`--datadir` (executable)+      - ``$prefix/share``+      - ``$prefix``+    * - :option:`--datadir` (library)+      - ``$prefix/share``+      - ``%PROGRAMFILES%\Haskell``+    * - :option:`--datasubdir`+      - ``$pkgid``+      - ``$pkgid``+    * - :option:`--docdir`+      - ``$datadir/doc/$pkgid``+      - ``$prefix\doc\$pkgid``+    * - :option:`--sysconfdir`+      - ``$prefix/etc``+      - ``$prefix\etc``+    * - :option:`--htmldir`+      - ``$docdir/html``+      - ``$docdir\html``+    * - :option:`--program-prefix`+      - (empty)+      - (empty)+    * - :option:`--program-suffix`+      - (empty)+      - (empty)++Prefix-independence+"""""""""""""""""""++On Windows it is possible to obtain the pathname of the running program.+This means that we can construct an installable executable package that+is independent of its absolute install location. The executable can find+its auxiliary files by finding its own path and knowing the location of+the other files relative to ``$bindir``. Prefix-independence is+particularly useful: it means the user can choose the install location+(i.e. the value of ``$prefix``) at install-time, rather than having to+bake the path into the binary when it is built.++In order to achieve this, we require that for an executable on Windows,+all of ``$bindir``, ``$libdir``, ``$dynlibdir``, ``$datadir`` and ``$libexecdir`` begin+with ``$prefix``. If this is not the case then the compiled executable+will have baked-in all absolute paths.++The application need do nothing special to achieve prefix-independence.+If it finds any files using ``getDataFileName`` and the `other functions+provided for the+purpose <developing-packages.html#accessing-data-files-from-package-code>`__,+the files will be accessed relative to the location of the current+executable.++A library cannot (currently) be prefix-independent, because it will be+linked into an executable whose file system location bears no relation+to the library package.++Controlling Flag Assignments+^^^^^^^^^^^^^^^^^^^^^^^^^^^^++Flag assignments (see the `resolution of conditions and+flags <developing-packages.html#resolution-of-conditions-and-flags>`__)+can be controlled with the following command line options.++.. option:: -f flagname or -f -flagname++    Force the specified flag to ``true`` or ``false`` (if preceded with+    a ``-``). Later specifications for the same flags will override+    earlier, i.e., specifying ``-fdebug -f-debug`` is equivalent to+    ``-f-debug``++.. option:: --flags=flagspecs++    Same as ``-f``, but allows specifying multiple flag assignments at+    once. The parameter is a space-separated list of flag names (to+    force a flag to ``true``), optionally preceded by a ``-`` (to force+    a flag to ``false``). For example,+    ``--flags="debug -feature1 feature2"`` is equivalent to+    ``-fdebug -f-feature1 -ffeature2``.++Building Test Suites+^^^^^^^^^^^^^^^^^^^^++.. option:: --enable-tests++    Build the test suites defined in the package description file during+    the ``build`` stage. Check for dependencies required by the test+    suites. If the package is configured with this option, it will be+    possible to run the test suites with the ``test`` command after the+    package is built.++.. option:: --disable-tests++    (default) Do not build any test suites during the ``build`` stage.+    Do not check for dependencies required only by the test suites. It+    will not be possible to invoke the ``test`` command without+    reconfiguring the package.++.. option:: --enable-coverage++    Build libraries and executables (including test suites) with Haskell+    Program Coverage enabled. Running the test suites will automatically+    generate coverage reports with HPC.++.. option:: --disable-coverage++    (default) Do not enable Haskell Program Coverage.++Miscellaneous options+^^^^^^^^^^^^^^^^^^^^^++.. option:: --user++    Does a per-user installation. This changes the `default installation+    prefix <#paths-in-the-simple-build-system>`__. It also allow+    dependencies to be satisfied by the user's package database, in+    addition to the global database. This also implies a default of+    ``--user`` for any subsequent ``install`` command, as packages+    registered in the global database should not depend on packages+    registered in a user's database.++.. option:: --global++    (default) Does a global installation. In this case package+    dependencies must be satisfied by the global package database. All+    packages in the user's package database will be ignored. Typically+    the final installation step will require administrative privileges.++.. option:: --package-db=db++    Allows package dependencies to be satisfied from this additional+    package database *db* in addition to the global package database.+    All packages in the user's package database will be ignored. The+    interpretation of *db* is implementation-specific. Typically it will+    be a file or directory. Not all implementations support arbitrary+    package databases.++    This pushes an extra db onto the db stack. The :option:`--global` and+    :option:`--user` mode switches add the respective [Global] and [Global,+    User] dbs to the initial stack. There is a compiler-implementation+    constraint that the global db must appear first in the stack, and if+    the user one appears at all, it must appear immediately after the+    global db.++    To reset the stack, use ``--package-db=clear``.++.. option:: --ipid=ipid++    Specifies the *installed package identifier* of the package to be+    built; this identifier is passed on to GHC and serves as the basis+    for linker symbols and the ``id`` field in a ``ghc-pkg``+    registration. When a package has multiple components, the actual+    component identifiers are derived off of this identifier (e.g., an+    internal library ``foo`` from package ``p-0.1-abcd`` will get the+    identifier ``p-0.1-abcd-foo``.++.. option:: --cid=cid++    Specifies the *component identifier* of the component being built;+    this is only valid if you are configuring a single component.++.. option:: --default-user-config=file++    Allows a "default" ``cabal.config`` freeze file to be passed in+    manually. This file will only be used if one does not exist in the+    project directory already. Typically, this can be set from the+    global cabal ``config`` file so as to provide a default set of+    partial constraints to be used by projects, providing a way for+    users to peg themselves to stable package collections.++.. option:: --enable-optimization[=n] or -O [n]++    (default) Build with optimization flags (if available). This is+    appropriate for production use, taking more time to build faster+    libraries and programs.++    The optional *n* value is the optimisation level. Some compilers+    support multiple optimisation levels. The range is 0 to 2. Level 0+    is equivalent to :option:`--disable-optimization`, level 1 is the+    default if no *n* parameter is given. Level 2 is higher optimisation+    if the compiler supports it. Level 2 is likely to lead to longer+    compile times and bigger generated code.++.. option:: --disable-optimization++    Build without optimization. This is suited for development: building+    will be quicker, but the resulting library or programs will be+    slower.++.. option:: --enable-profiling++    Build libraries and executables with profiling enabled (for+    compilers that support profiling as a separate mode). For this to+    work, all libraries used by this package must also have been built+    with profiling support. For libraries this involves building an+    additional instance of the library in addition to the normal+    non-profiling instance. For executables it changes the single+    executable to be built in profiling mode.++    This flag covers both libraries and executables, but can be+    overridden by the :option:`--enable-library-profiling` flag.++    See also the :option:`--profiling-detail` flag below.++.. option:: --disable-profiling++    (default) Do not enable profiling in generated libraries and+    executables.++.. option:: --enable-library-profiling or -p++    As with :option:`--enable-profiling` above, but it applies only for+    libraries. So this generates an additional profiling instance of the+    library in addition to the normal non-profiling instance.++    The :option:`--enable-profiling` flag controls the profiling mode for both+    libraries and executables, but if different modes are desired for+    libraries versus executables then use :option:`--enable-library-profiling`+    as well.++.. option:: --disable-library-profiling++    (default) Do not generate an additional profiling version of the library.++.. option:: --profiling-detail[=level]++    Some compilers that support profiling, notably GHC, can allocate+    costs to different parts of the program and there are different+    levels of granularity or detail with which this can be done. In+    particular for GHC this concept is called "cost centers", and GHC+    can automatically add cost centers, and can do so in different ways.++    This flag covers both libraries and executables, but can be+    overridden by the :option:`--library-profiling-detail` flag.++    Currently this setting is ignored for compilers other than GHC. The+    levels that cabal currently supports are:++    default+        For GHC this uses ``exported-functions`` for libraries and+        ``toplevel-functions`` for executables.+    none+        No costs will be assigned to any code within this component.+    exported-functions+        Costs will be assigned at the granularity of all top level+        functions exported from each module. In GHC specifically, this+        is for non-inline functions.+    toplevel-functions+        Costs will be assigned at the granularity of all top level+        functions in each module, whether they are exported from the+        module or not. In GHC specifically, this is for non-inline+        functions.+    all-functions+        Costs will be assigned at the granularity of all functions in+        each module, whether top level or local. In GHC specifically,+        this is for non-inline toplevel or where-bound functions or+        values.++    This flag is new in Cabal-1.24. Prior versions used the equivalent+    of ``none`` above.++.. option:: --library-profiling-detail[=level]++    As with :option:`--profiling-detail` above, but it applies only for+    libraries.++    The level for both libraries and executables is set by the+    :option:`--profiling-detail` flag, but if different levels are desired+    for libraries versus executables then use+    :option:`--library-profiling-detail` as well.++.. option:: --enable-library-vanilla++    (default) Build ordinary libraries (as opposed to profiling+    libraries). This is independent of the+    :option:`--enable-library-profiling` option. If you enable both, you get+    both.++.. option:: --disable-library-vanilla++    Do not build ordinary libraries. This is useful in conjunction with+    :option:`--enable-library-profiling` to build only profiling libraries,+    rather than profiling and ordinary libraries.++.. option:: --enable-library-for-ghci++    (default) Build libraries suitable for use with GHCi.++.. option:: --disable-library-for-ghci++    Not all platforms support GHCi and indeed on some platforms, trying+    to build GHCi libs fails. In such cases this flag can be used as a+    workaround.++.. option:: --enable-split-objs++    Use the GHC ``-split-objs`` feature when building the library. This+    reduces the final size of the executables that use the library by+    allowing them to link with only the bits that they use rather than+    the entire library. The downside is that building the library takes+    longer and uses considerably more memory.++.. option:: --disable-split-objs++    (default) Do not use the GHC ``-split-objs`` feature. This makes+    building the library quicker but the final executables that use the+    library will be larger.++.. option:: --enable-executable-stripping++    (default) When installing binary executable programs, run the+    ``strip`` program on the binary. This can considerably reduce the+    size of the executable binary file. It does this by removing+    debugging information and symbols. While such extra information is+    useful for debugging C programs with traditional debuggers it is+    rarely helpful for debugging binaries produced by Haskell compilers.++    Not all Haskell implementations generate native binaries. For such+    implementations this option has no effect.++.. option:: --disable-executable-stripping++    Do not strip binary executables during installation. You might want+    to use this option if you need to debug a program using gdb, for+    example if you want to debug the C parts of a program containing+    both Haskell and C code. Another reason is if your are building a+    package for a system which has a policy of managing the stripping+    itself (such as some Linux distributions).++.. option:: --enable-shared++    Build shared library. This implies a separate compiler run to+    generate position independent code as required on most platforms.++.. option:: --disable-shared++    (default) Do not build shared library.++.. option:: --enable-executable-dynamic++    Link executables dynamically. The executable's library dependencies+    should be built as shared objects. This implies :option:`--enable-shared`+    unless :option:`--disable-shared` is explicitly specified.++.. option:: --disable-executable-dynamic++   (default) Link executables statically.++.. option:: --configure-option=str++    An extra option to an external ``configure`` script, if one is used+    (see the section on `system-dependent+    parameters <developing-packages.html#system-dependent-parameters>`__).+    There can be several of these options.++.. option:: --extra-include-dirs[=dir]++    An extra directory to search for C header files. You can use this+    flag multiple times to get a list of directories.++    You might need to use this flag if you have standard system header+    files in a non-standard location that is not mentioned in the+    package's ``.cabal`` file. Using this option has the same affect as+    appending the directory *dir* to the ``include-dirs`` field in each+    library and executable in the package's ``.cabal`` file. The+    advantage of course is that you do not have to modify the package at+    all. These extra directories will be used while building the package+    and for libraries it is also saved in the package registration+    information and used when compiling modules that use the library.++.. option:: --extra-lib-dirs[=dir]++    An extra directory to search for system libraries files. You can use+    this flag multiple times to get a list of directories.++.. option:: --extra-framework-dirs[=dir]++    An extra directory to search for frameworks (OS X only). You can use+    this flag multiple times to get a list of directories.++    You might need to use this flag if you have standard system+    libraries in a non-standard location that is not mentioned in the+    package's ``.cabal`` file. Using this option has the same affect as+    appending the directory *dir* to the ``extra-lib-dirs`` field in+    each library and executable in the package's ``.cabal`` file. The+    advantage of course is that you do not have to modify the package at+    all. These extra directories will be used while building the package+    and for libraries it is also saved in the package registration+    information and used when compiling modules that use the library.++.. option:: --dependency[=pkgname=ipid]++    Specify that a particular dependency should used for a particular+    package name. In particular, it declares that any reference to+    *pkgname* in a ``build-depends`` should be resolved to *ipid*.++.. option:: --exact-configuration++    This changes Cabal to require every dependency be explicitly+    specified using :option:`--dependency`, rather than use Cabal's (very+    simple) dependency solver. This is useful for programmatic use of+    Cabal's API, where you want to error if you didn't specify enough+    :option:`--dependency` flags.++.. option:: --allow-newer[=pkgs], --allow-older[=pkgs]++    Selectively relax upper or lower bounds in dependencies without+    editing the package description respectively.++    The following description focuses on upper bounds and the+    :option:`--allow-newer` flag, but applies analogously to+    :option:`--allow-older` and lower bounds. :option:`--allow-newer`+    and :option:`--allow-older` can be used at the same time.++    If you want to install a package A that depends on B >= 1.0 && <+    2.0, but you have the version 2.0 of B installed, you can compile A+    against B 2.0 by using ``cabal install --allow-newer=B A``. This+    works for the whole package index: if A also depends on C that in+    turn depends on B < 2.0, C's dependency on B will be also relaxed.++    Example:++    ::++        $ cd foo+        $ cabal configure+        Resolving dependencies...+        cabal: Could not resolve dependencies:+        [...]+        $ cabal configure --allow-newer+        Resolving dependencies...+        Configuring foo...++    Additional examples:++    ::++        # Relax upper bounds in all dependencies.+        $ cabal install --allow-newer foo++        # Relax upper bounds only in dependencies on bar, baz and quux.+        $ cabal install --allow-newer=bar,baz,quux foo++        # Relax the upper bound on bar and force bar==2.1.+        $ cabal install --allow-newer=bar --constraint="bar==2.1" foo++    It's also possible to limit the scope of :option:`--allow-newer` to single+    packages with the ``--allow-newer=scope:dep`` syntax. This means+    that the dependency on ``dep`` will be relaxed only for the package+    ``scope``.++    Example:++    ::++        # Relax upper bound in foo's dependency on base; also relax upper bound in+        # every package's dependency on lens.+        $ cabal install --allow-newer=foo:base,lens++        # Relax upper bounds in foo's dependency on base and bar's dependency+        # on time; also relax the upper bound in the dependency on lens specified by+        # any package.+        $ cabal install --allow-newer=foo:base,lens --allow-newer=bar:time++    Finally, one can enable :option:`--allow-newer` permanently by setting+    ``allow-newer: True`` in the ``~/.cabal/config`` file. Enabling+    'allow-newer' selectively is also supported in the config file+    (``allow-newer: foo, bar, baz:base``).++.. option:: --constraint=constraint++    Restrict solutions involving a package to a given version range. For+    example, ``cabal install --constraint="bar==2.1"`` will only+    consider install plans that do not use ``bar`` at all, or ``bar`` of+    version 2.1.++    As a special case, ``cabal install --constraint="bar -none"``+    prevents ``bar`` from being used at all (``-none`` abbreviates+    ``> 1 && < 1``); ``cabal install --constraint="bar installed"``+    prevents reinstallation of the ``bar`` package;+    ``cabal install --constraint="bar +foo -baz"`` specifies that the+    flag ``foo`` should be turned on and the ``baz`` flag should be+    turned off.++.. option:: --preference=preference++    Specify a soft constraint on versions of a package. The solver will+    attempt to satisfy these preferences on a "best-effort" basis.++.. _setup-build:++setup build+-----------++Perform any preprocessing or compilation needed to make this package+ready for installation.++This command takes the following options:++.. program:: setup build++.. option:: --prog-options=options, --prog-option=option++    These are mostly the same as the `options configure+    step <#setup-configure>`__. Unlike the options specified at the+    configure step, any program options specified at the build step are+    not persistent but are used for that invocation only. They options+    specified at the build step are in addition not in replacement of+    any options specified at the configure step.++.. _setup-haddock:++setup haddock+-------------++.. program:: setup haddock++Build the documentation for the package using Haddock_.+By default, only the documentation for the exposed modules is generated+(but see the :option:`--executables` and :option:`--internal` flags below).++This command takes the following options:++.. option:: --hoogle++    Generate a file ``dist/doc/html/``\ *pkgid*\ ``.txt``, which can be+    converted by Hoogle_ into a+    database for searching. This is equivalent to running Haddock_+    with the ``--hoogle`` flag.++.. option:: --html-location=url++    Specify a template for the location of HTML documentation for+    prerequisite packages. The substitutions (`see+    listing <#paths-in-the-simple-build-system>`__) are applied to the+    template to obtain a location for each package, which will be used+    by hyperlinks in the generated documentation. For example, the+    following command generates links pointing at Hackage_ pages:++        setup haddock+        --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html'++    Here the argument is quoted to prevent substitution by the shell. If+    this option is omitted, the location for each package is obtained+    using the package tool (e.g. ``ghc-pkg``).++.. option:: --executables++    Also run Haddock_ for the modules of all the executable programs. By default+    Haddock_ is run only on the exported modules.++.. option:: --internal++    Run Haddock_ for the all+    modules, including unexposed ones, and make+    Haddock_ generate documentation+    for unexported symbols as well.++.. option:: --css=path++    The argument *path* denotes a CSS file, which is passed to+    Haddock_ and used to set the+    style of the generated documentation. This is only needed to+    override the default style that+    Haddock_ uses.++.. option:: --hyperlink-source++    Generate Haddock_ documentation integrated with HsColour_ . First,+    HsColour_ is run to generate colourised code. Then Haddock_ is run to+    generate HTML documentation. Each entity shown in the documentation is+    linked to its definition in the colourised code.++.. option:: --hscolour-css=path++    The argument *path* denotes a CSS file, which is passed to HsColour_ as in++        runhaskell Setup.hs hscolour --css=*path*++.. _setup-hscolour:++setup hscolour+--------------++Produce colourised code in HTML format using HsColour_. Colourised code for+exported modules is put in ``dist/doc/html/``\ *pkgid*\ ``/src``.++This command takes the following options:++.. program:: setup hscolour++.. option:: --executables++    Also run HsColour_ on the sources of all executable programs. Colourised+    code is put in ``dist/doc/html/``\ *pkgid*/*executable*\ ``/src``.++.. option:: --css=path++    Use the given CSS file for the generated HTML files. The CSS file+    defines the colours used to colourise code. Note that this copies+    the given CSS file to the directory with the generated HTML files+    (renamed to ``hscolour.css``) rather than linking to it.++.. _setup-install:++setup install+-------------++.. program:: setup install++Copy the files into the install locations and (for library packages)+register the package with the compiler, i.e. make the modules it+contains available to programs.++The `install locations <#installation-paths>`__ are determined by+options to `setup configure`_.++This command takes the following options:++.. option:: --global++    Register this package in the system-wide database. (This is the+    default, unless the :option:`setup configure --user` option was supplied+    to the ``configure`` command.)++.. option:: --user++    Register this package in the user's local package database. (This is+    the default if the :option:`setup configure --user` option was supplied+    to the ``configure`` command.)++.. _setup-copy:++setup copy+----------++Copy the files without registering them. This command is mainly of use+to those creating binary packages.++This command takes the following option:++.. program:: setup copy++.. option:: --destdir=path++   Specify the directory under which to place installed files. If this is+   not given, then the root directory is assumed.++.. _setup-register:++setup register+--------------++Register this package with the compiler, i.e. make the modules it+contains available to programs. This only makes sense for library+packages. Note that the ``install`` command incorporates this action.+The main use of this separate command is in the post-installation step+for a binary package.++This command takes the following options:++.. program:: setup register++.. option:: --global++    Register this package in the system-wide database. (This is the+    default.)++.. option:: --user++    Register this package in the user's local package database.++.. option:: --gen-script++    Instead of registering the package, generate a script containing+    commands to perform the registration. On Unix, this file is called+    ``register.sh``, on Windows, ``register.bat``. This script might be+    included in a binary bundle, to be run after the bundle is unpacked+    on the target system.++.. option:: --gen-pkg-config[=path]++    Instead of registering the package, generate a package registration+    file (or directory, in some circumstances). This only applies to+    compilers that support package registration files which at the+    moment is only GHC. The file should be used with the compiler's+    mechanism for registering packages. This option is mainly intended+    for packaging systems. If possible use the :option:`--gen-script` option+    instead since it is more portable across Haskell implementations.+    The *path* is optional and can be used to specify a particular+    output file to generate. Otherwise, by default the file is the+    package name and version with a ``.conf`` extension.++    This option outputs a directory if the package requires multiple+    registrations: this can occur if internal/convenience libraries are+    used. These configuration file names are sorted so that they can be+    registered in order.++.. option:: --inplace++    Registers the package for use directly from the build tree, without+    needing to install it. This can be useful for testing: there's no+    need to install the package after modifying it, just recompile and+    test.++    This flag does not create a build-tree-local package database. It+    still registers the package in one of the user or global databases.++    However, there are some caveats. It only works with GHC (currently).+    It only works if your package doesn't depend on having any+    supplemental files installed --- plain Haskell libraries should be+    fine.++.. _setup-unregister:++setup unregister+----------------++.. program:: setup unregister++Deregister this package with the compiler.++This command takes the following options:++.. option:: --global++    Deregister this package in the system-wide database. (This is the+    default.)++.. option:: --user++    Deregister this package in the user's local package database.++.. option:: --gen-script++    Instead of deregistering the package, generate a script containing+    commands to perform the deregistration. On Unix, this file is called+    ``unregister.sh``, on Windows, ``unregister.bat``. This script might+    be included in a binary bundle, to be run on the target system.++.. _setup-clean:++setup clean+-----------++Remove any local files created during the ``configure``, ``build``,+``haddock``, ``register`` or ``unregister`` steps, and also any files+and directories listed in the :pkg-field:`extra-tmp-files` field.++This command takes the following options:++.. program:: setup clean++.. option:: --save-configure, -s++    Keeps the configuration information so it is not necessary to run+    the configure step again before building.++setup test+----------++Run the test suites specified in the package description file. Aside+from the following flags, Cabal accepts the name of one or more test+suites on the command line after ``test``. When supplied, Cabal will run+only the named test suites, otherwise, Cabal will run all test suites in+the package.++.. program:: setup test++.. option:: --builddir=dir++    The directory where Cabal puts generated build files (default:+    ``dist``). Test logs will be located in the ``test`` subdirectory.++.. option:: --human-log=path++    The template used to name human-readable test logs; the path is+    relative to ``dist/test``. By default, logs are named according to+    the template ``$pkgid-$test-suite.log``, so that each test suite+    will be logged to its own human-readable log file. Template+    variables allowed are: ``$pkgid``, ``$compiler``, ``$os``,+    ``$arch``, ``$abi``, ``$abitag``, ``$test-suite``, and ``$result``.++.. option:: --machine-log=path++    The path to the machine-readable log, relative to ``dist/test``. The+    default template is ``$pkgid.log``. Template variables allowed are:+    ``$pkgid``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag``+    and ``$result``.++.. option:: --show-details=filter++    Determines if the results of individual test cases are shown on the+    terminal. May be ``always`` (always show), ``never`` (never show),+    ``failures`` (show only failed results), or ``streaming`` (show all+    results in real time).++.. option:: --test-options=options+    Give extra options to the test executables.++.. option:: --test-option=option++    give an extra option to the test executables. There is no need to+    quote options containing spaces because a single option is assumed,+    so options will not be split on spaces.++.. _setup-sdist:++setup sdist+-----------++Create a system- and compiler-independent source distribution in a file+*package*-*version*\ ``.tar.gz`` in the ``dist`` subdirectory, for+distribution to package builders. When unpacked, the commands listed in+this section will be available.++The files placed in this distribution are the package description file,+the setup script, the sources of the modules named in the package+description file, and files named in the ``license-file``, ``main-is``,+``c-sources``, ``js-sources``, ``data-files``, ``extra-source-files``+and ``extra-doc-files`` fields.++This command takes the following option:++.. program:: setup sdist++.. option:: --snapshot++    Append today's date (in "YYYYMMDD" format) to the version number for+    the generated source package. The original package is unaffected.+++.. include:: references.inc
+ cabal/Cabal/doc/intro.rst view
@@ -0,0 +1,200 @@+.. highlight:: console++Cabal is the standard package system for+Haskell_ software. It helps people to+configure, build and install Haskell software and to distribute it+easily to other users and developers.++There is a command line tool called ``cabal`` for working with Cabal+packages. It helps with installing existing packages and also helps+people developing their own packages. It can be used to work with local+packages or to install packages from online package archives, including+automatically installing dependencies. By default it is configured to+use Hackage_ which is Haskell's central+package archive that contains thousands of libraries and applications in+the Cabal package format.++Introduction+============++Cabal is a package system for Haskell software. The point of a package+system is to enable software developers and users to easily distribute,+use and reuse software. A package system makes it easier for developers+to get their software into the hands of users. Equally importantly, it+makes it easier for software developers to be able to reuse software+components written by other developers.++Packaging systems deal with packages and with Cabal we call them *Cabal+packages*. The Cabal package is the unit of distribution. Every Cabal+package has a name and a version number which are used to identify the+package, e.g. ``filepath-1.0``.++Cabal packages can depend on other Cabal packages. There are tools to+enable automated package management. This means it is possible for+developers and users to install a package plus all of the other Cabal+packages that it depends on. It also means that it is practical to make+very modular systems using lots of packages that reuse code written by+many developers.++Cabal packages are source based and are typically (but not necessarily)+portable to many platforms and Haskell implementations. The Cabal+package format is designed to make it possible to translate into other+formats, including binary packages for various systems.++When distributed, Cabal packages use the standard compressed tarball+format, with the file extension ``.tar.gz``, e.g.+``filepath-1.0.tar.gz``.++Note that packages are not part of the Haskell language, rather they are+a feature provided by the combination of Cabal and GHC (and several+other Haskell implementations).++A tool for working with packages+--------------------------------++There is a command line tool, called "``cabal``", that users and+developers can use to build and install Cabal packages. It can be used+for both local packages and for packages available remotely over the+network. It can automatically install Cabal packages plus any other+Cabal packages they depend on.++Developers can use the tool with packages in local directories, e.g.++::++    $ cd foo/+    $ cabal install++While working on a package in a local directory, developers can run the+individual steps to configure and build, and also generate documentation+and run test suites and benchmarks.++It is also possible to install several local packages at once, e.g.++::++    $ cabal install foo/ bar/++Developers and users can use the tool to install packages from remote+Cabal package archives. By default, the ``cabal`` tool is configured to+use the central Haskell package archive called+Hackage_ but it is possible to use it+with any other suitable archive.++::++    $ cabal install xmonad++This will install the ``xmonad`` package plus all of its dependencies.++In addition to packages that have been published in an archive,+developers can install packages from local or remote tarball files, for+example++::++    $ cabal install foo-1.0.tar.gz+    $ cabal install http://example.com/foo-1.0.tar.gz++Cabal provides a number of ways for a user to customise how and where a+package is installed. They can decide where a package will be installed,+which Haskell implementation to use and whether to build optimised code+or build with the ability to profile code. It is not expected that users+will have to modify any of the information in the ``.cabal`` file.++For full details, see the section on `building and installing+packages <installing-packages.html>`__.++Note that ``cabal`` is not the only tool for working with Cabal+packages. Due to the standardised format and a library for reading+``.cabal`` files, there are several other special-purpose tools.++What's in a package+-------------------++A Cabal package consists of:++-  Haskell software, including libraries, executables and tests+-  metadata about the package in a standard human and machine readable+   format (the "``.cabal``" file)+-  a standard interface to build the package (the "``Setup.hs``" file)++The ``.cabal`` file contains information about the package, supplied by+the package author. In particular it lists the other Cabal packages that+the package depends on.++For full details on what goes in the ``.cabal`` and ``Setup.hs`` files,+and for all the other features provided by the build system, see the+section on `developing packages <developing-packages.html>`__.++Cabal featureset+----------------++Cabal and its associated tools and websites covers:++-  a software build system+-  software configuration+-  packaging for distribution+-  automated package management++   -  natively using the ``cabal`` command line tool; or+   -  by translation into native package formats such as RPM or deb++-  web and local Cabal package archives++   -  central Hackage website with 1000's of Cabal packages++Some parts of the system can be used without others. In particular the+built-in build system for simple packages is optional: it is possible to+use custom build systems.++Similar systems+---------------++The Cabal system is roughly comparable with the system of Python Eggs,+Ruby Gems or Perl distributions. Each system has a notion of+distributable packages, and has tools to manage the process of+distributing and installing packages.++Hackage is an online archive of Cabal packages. It is roughly comparable+to CPAN but with rather fewer packages (around 5,000 vs 28,000).++Cabal is often compared with autoconf and automake and there is some+overlap in functionality. The most obvious similarity is that the+command line interface for actually configuring and building packages+follows the same steps and has many of the same configuration+parameters.++::++    $ ./configure --prefix=...+    $ make+    $ make install++compared to++::++    $ cabal configure --prefix=...+    $ cabal build+    $ cabal install++Cabal's build system for simple packages is considerably less flexible+than make/automake, but has builtin knowledge of how to build Haskell+code and requires very little manual configuration. Cabal's simple build+system is also portable to Windows, without needing a Unix-like+environment such as cygwin/mingwin.++Compared to autoconf, Cabal takes a somewhat different approach to+package configuration. Cabal's approach is designed for automated+package management. Instead of having a configure script that tests for+whether dependencies are available, Cabal packages specify their+dependencies. There is some scope for optional and conditional+dependencies. By having package authors specify dependencies it makes it+possible for tools to install a package and all of its dependencies+automatically. It also makes it possible to translate (in a+mostly-automatically way) into another package format like RPM or deb+which also have automatic dependency resolution.+++.. include:: references.inc
− cabal/Cabal/doc/misc.markdown 
@@ -1,109 +0,0 @@-% Cabal User Guide--# Reporting bugs and deficiencies #--Please report any flaws or feature requests in the [bug tracker][].--For general discussion or queries email the libraries mailing list-<libraries@haskell.org>. There is also a development mailing list-<cabal-devel@haskell.org>.--[bug tracker]: https://github.com/haskell/cabal/issues--# Stability of Cabal interfaces #--The Cabal library and related infrastructure is still under active-development. New features are being added and limitations and bugs are-being fixed. This requires internal changes and often user visible-changes as well. We therefore cannot promise complete future-proof-stability, at least not without halting all development work.--This section documents the aspects of the Cabal interface that we can-promise to keep stable and which bits are subject to change.--## Cabal file format ##--This is backwards compatible and mostly forwards compatible. New fields-can be added without breaking older versions of Cabal. Fields can be-deprecated without breaking older packages.--## Command-line interface ##--### Very Stable Command-line interfaces ###--* `./setup configure`-  * `--prefix`-  * `--user`-  * `--ghc`, `--uhc`-  * `--verbose`-  * `--prefix`--* `./setup build`-* `./setup install`-* `./setup register`-* `./setup copy`--### Stable Command-line interfaces ###--### Unstable command-line ###--## Functions and Types ##--The Cabal library follows the [Package Versioning Policy][PVP]. This-means that within a stable major release, for example 1.2.x, there will-be no incompatible API changes. But minor versions increments, for-example 1.2.3, indicate compatible API additions.--The Package Versioning Policy does not require any API guarantees-between major releases, for example between 1.2.x and 1.4.x. In practise-of course not everything changes between major releases. Some parts of-the API are more prone to change than others. The rest of this section-gives some informal advice on what level of API stability you can expect-between major releases.--[PVP]: http://www.haskell.org/haskellwiki/Package_versioning_policy--### Very Stable API ###--* `defaultMain`--* `defaultMainWithHooks defaultUserHooks`--  But regular `defaultMainWithHooks` isn't stable since `UserHooks`-  changes.--### Semi-stable API ###--* `UserHooks` The hooks API will change in the future--* `Distribution.*` is mostly declarative information about packages and-   is somewhat stable.--### Unstable API ###--Everything under `Distribution.Simple.*` has no stability guarantee.--## Hackage ##--The index format is a partly stable interface. It consists of a tar.gz-file that contains directories with `.cabal` files in. In future it may-contain more kinds of files so do not assume every file is a `.cabal`-file. Incompatible revisions to the format would involve bumping the-name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc.---[dist-simple]:  ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html-[dist-make]:    ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html-[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License-[extension]:    ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType-[alex]:       http://www.haskell.org/alex/-[autoconf]:   http://www.gnu.org/software/autoconf/-[c2hs]:       http://www.cse.unsw.edu.au/~chak/haskell/c2hs/-[cpphs]:      http://projects.haskell.org/cpphs/-[greencard]:  http://hackage.haskell.org/package/greencard-[haddock]:    http://www.haskell.org/haddock/-[HsColour]:   http://www.cs.york.ac.uk/fp/darcs/hscolour/-[happy]:      http://www.haskell.org/happy/-[Hackage]:    http://hackage.haskell.org/-[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/
+ cabal/Cabal/doc/misc.rst view
@@ -0,0 +1,103 @@+Reporting bugs and deficiencies+===============================++Please report any flaws or feature requests in the `bug+tracker <https://github.com/haskell/cabal/issues>`__.++For general discussion or queries email the libraries mailing list+libraries@haskell.org. There is also a development mailing list+cabal-devel@haskell.org.++Stability of Cabal interfaces+=============================++The Cabal library and related infrastructure is still under active+development. New features are being added and limitations and bugs are+being fixed. This requires internal changes and often user visible+changes as well. We therefore cannot promise complete future-proof+stability, at least not without halting all development work.++This section documents the aspects of the Cabal interface that we can+promise to keep stable and which bits are subject to change.++Cabal file format+-----------------++This is backwards compatible and mostly forwards compatible. New fields+can be added without breaking older versions of Cabal. Fields can be+deprecated without breaking older packages.++Command-line interface+----------------------++Very Stable Command-line interfaces+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-  ``./setup configure``+-  ``--prefix``+-  ``--user``+-  ``--ghc``, ``--uhc``+-  ``--verbose``+-  ``--prefix``++-  ``./setup build``+-  ``./setup install``+-  ``./setup register``+-  ``./setup copy``++Stable Command-line interfaces+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unstable command-line+~~~~~~~~~~~~~~~~~~~~~++Functions and Types+-------------------++The Cabal library follows the `Package Versioning Policy`_.+This means that within a stable major release, for example 1.2.x, there+will be no incompatible API changes. But minor versions increments, for+example 1.2.3, indicate compatible API additions.++The Package Versioning Policy does not require any API guarantees+between major releases, for example between 1.2.x and 1.4.x. In practise+of course not everything changes between major releases. Some parts of+the API are more prone to change than others. The rest of this section+gives some informal advice on what level of API stability you can expect+between major releases.++Very Stable API+~~~~~~~~~~~~~~~++-  ``defaultMain``++-  ``defaultMainWithHooks defaultUserHooks``++But regular ``defaultMainWithHooks`` isn't stable since ``UserHooks``+changes.++Semi-stable API+~~~~~~~~~~~~~~~++-  ``UserHooks`` The hooks API will change in the future++-  ``Distribution.*`` is mostly declarative information about packages+   and is somewhat stable.++Unstable API+~~~~~~~~~~~~++Everything under ``Distribution.Simple.*`` has no stability guarantee.++Hackage+-------++The index format is a partly stable interface. It consists of a tar.gz+file that contains directories with ``.cabal`` files in. In future it+may contain more kinds of files so do not assume every file is a+``.cabal`` file. Incompatible revisions to the format would involve+bumping the name of the index file, i.e., ``00-index.tar.gz``,+``01-index.tar.gz`` etc.+++.. include:: references.inc
+ cabal/Cabal/doc/nix-local-build-overview.rst view
@@ -0,0 +1,32 @@+Nix-style Local Builds+======================++``cabal new-build``, also known as Nix-style local builds, is a new+command inspired by Nix that comes with cabal-install 1.24. Nix-style+local builds combine the best of non-sandboxed and sandboxed Cabal:++1. Like sandboxed Cabal today, we build sets of independent local+   packages deterministically and independent of any global state.+   new-build will never tell you that it can't build your package+   because it would result in a "dangerous reinstall." Given a+   particular state of the Hackage index, your build is completely+   reproducible. For example, you no longer need to compile packages+   with profiling ahead of time; just request profiling and new-build+   will rebuild all its dependencies with profiling automatically.++2. Like non-sandboxed Cabal today, builds of external packages are+   cached in ``~/.cabal/store``, so that a package can be built once,+   and then reused anywhere else it is also used. No need to continually+   rebuild dependencies whenever you make a new sandbox: dependencies+   which can be shared, are shared.++Nix-style local builds work with all versions of GHC supported by+cabal-install 1.24, which currently is GHC 7.0 and later.++Some features described in this manual are not implemented. If you need+them, please give us a shout and we'll prioritize accordingly.++++.. toctree::+   nix-local-build
+ cabal/Cabal/doc/nix-local-build.rst view
@@ -0,0 +1,1701 @@+.. highlight:: console++Quickstart+==========++Suppose that you are in a directory containing a single Cabal package+which you wish to build. You can configure and build it using Nix-style+local builds with this command (configuring is not necessary):++::++    $ cabal new-build++To open a GHCi shell with this package, use this command:++::++    $ cabal new-repl++Developing multiple packages+----------------------------++Many Cabal projects involve multiple packages which need to be built+together. To build multiple Cabal packages, you need to first create a+``cabal.project`` file which declares where all the local package+directories live. For example, in the Cabal repository, there is a root+directory with a folder per package, e.g., the folders ``Cabal`` and+``cabal-install``. The ``cabal.project`` file specifies each folder as+part of the project:++.. code-block:: cabal++    packages: Cabal/+              cabal-install/++The expectation is that a ``cabal.project`` is checked into your source+control, to be used by all developers of a project. If you need to make+local changes, they can be placed in ``cabal.project.local`` (which+should not be checked in.)++Then, to build every component of every package, from the top-level+directory, run the command: (Warning: cabal-install-1.24 does NOT have+this behavior; you will need to upgrade to HEAD.)++::++    $ cabal new-build++To build a specific package, you can either run ``new-build`` from the+directory of the package in question:++::++    $ cd cabal-install+    $ cabal new-build++or you can pass the name of the package as an argument to+``cabal new-build`` (this works in any subdirectory of the project):++::++    $ cabal new-build cabal-install++You can also specify a specific component of the package to build. For+example, to build a test suite named ``package-tests``, use the command:++::++    $ cabal new-build package-tests++Targets can be qualified with package names. So to request+``package-tests`` *from* the ``Cabal`` package, use+``Cabal:package-tests``.++Unlike sandboxes, there is no need to setup a sandbox or ``add-source``+projects; just check in ``cabal.project`` to your repository and+``new-build`` will just work.++Cookbook+========++How can I profile my library/application?+-----------------------------------------++First, make sure you have HEAD; 1.24 is affected by :issue:`3790`,+which means that if any project which transitively depends on a+package which has a Custom setup built against Cabal 1.22 or earlier+will silently not work.++Create or edit your ``cabal.project.local``, adding the following+line::++    profiling: True++Now, ``cabal new-build`` will automatically build all libraries and+executables with profiling.  You can fine-tune the profiling settings+for each package using :cfg-field:`profiling-detail`::++    package p+        profiling-detail: toplevel-functions++Alternately, you can call ``cabal new-build --enable-profiling`` to+temporarily build with profiling.++How it works+============++Local versus external packages+------------------------------++One of the primary innovations of Nix-style local builds is the+distinction between local packages, which users edit and recompile and+must be built per-project, versus external packages, which can be cached+across projects. To be more precise:++1. A **local package** is one that is listed explicitly in the+   ``packages``, ``optional-packages`` or ``extra-packages`` field of a+   project. Usually, these refer to packages whose source code lives+   directly in a folder in your project (although, you can list an+   arbitrary Hackage package in ``extra-packages`` to force it to be+   treated as local).++Local packages, as well as the external packages (below) which depend on+them, are built **inplace**, meaning that they are always built+specifically for the project and are not installed globally. Inplace+packages are not cached and not given unique hashes, which makes them+suitable for packages which you want to edit and recompile.++2. An **external package** is any package which is not listed in the+   ``packages`` field. The source code for external packages is usually+   retrieved from Hackage.++When an external package does not depend on an inplace package, it can+be built and installed to a **global** store, which can be shared across+projects. These build products are identified by a hash that over all of+the inputs which would influence the compilation of a package (flags,+dependency selection, etc.). Just as in Nix, these hashes uniquely+identify the result of a build; if we compute this identifier and we+find that we already have this ID built, we can just use the already+built version.++The global package store is ``~/.cabal/store``; if you need to clear+your store for whatever reason (e.g., to reclaim disk space or because+the global store is corrupted), deleting this directory is safe+(``new-build`` will just rebuild everything it needs on its next+invocation).++This split motivates some of the UI choices for Nix-style local build+commands. For example, flags passed to ``cabal new-build`` are only+applied to *local* packages, so that adding a flag to+``cabal new-build`` doesn't necessitate a rebuild of *every* transitive+dependency in the global package store.++In cabal-install HEAD, Nix-style local builds also take advantage of a+new Cabal library feature, `per-component+builds <https://github.com/ezyang/ghc-proposals/blob/master/proposals/0000-componentized-cabal.rst>`__,+where each component of a package is configured and built separately.+This can massively speed up rebuilds of packages with lots of components+(e.g., a package that defines multiple executables), as only one+executable needs to be rebuilt. Packages that use Custom setup scripts+are not currently built on a per-component basis.++Where are my build products?+----------------------------++A major deficiency in the current implementation of new-build is that+there is no programmatic way to access the location of build products.+The location of the build products is intended to be an internal+implementation detail of new-build, but we also understand that many+unimplemented features (e.g., ``new-test``) can only be reasonably+worked around by accessing build products directly.++The location where build products can be found varies depending on the+version of cabal-install:++-  In cabal-install-1.24, the dist directory for a package ``p-0.1`` is+   stored in ``dist-newstyle/build/p-0.1``. For example, if you built an+   executable or test suite named ``pexe``, it would be located at+   ``dist-newstyle/build/p-0.1/build/pexe/pexe``.++-  In cabal-install HEAD, the dist directory for a package ``p-0.1``+   defining a library built with GHC 8.0.1 on 64-bit Linux is+   ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1``. When+   per-component builds are enabled (any non-Custom package), a+   subcomponent like an executable or test suite named ``pexe`` will be+   stored at+   ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/c/pexe``; thus,+   the full path of the executable is+   ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/c/pexe/build/pexe/pexe``+   (you can see why we want this to be an implementation detail!)++The paths are a bit longer in HEAD but the benefit is that you can+transparently have multiple builds with different versions of GHC. We+plan to add the ability to create aliases for certain build+configurations, and more convenient paths to access particularly useful+build products like executables.++Caching+-------++Nix-style local builds sport a robust caching system which help reduce+the time it takes to execute a rebuild cycle. While the details of how+``cabal-install`` does caching are an implementation detail and may+change in the future, knowing what gets cached is helpful for+understanding the performance characteristics of invocations to+``new-build``. The cached intermediate results are stored in+``dist-newstyle/cache``; this folder can be safely deleted to clear the+cache.++The following intermediate results are cached in the following files in+this folder (the most important two are first):++``solver-plan`` (binary)+    The result of calling the dependency solver, assuming that the+    Hackage index, local ``cabal.project`` file, and local ``cabal``+    files are unmodified. (Notably, we do NOT have to dependency solve+    again if new build products are stored in the global store; the+    invocation of the dependency solver is independent of what is+    already available in the store.)+``source-hashes`` (binary)+    The hashes of all local source files. When all local source files of+    a local package are unchanged, ``cabal new-build`` will skip+    invoking ``setup build`` entirely (saving us from a possibly+    expensive call to ``ghc --make``). The full list of source files+    participating in compilation are determined using+    ``setup sdist --list-sources`` (thus, if you do not list all your+    source files in a Cabal file, you may fail to recompile when you+    edit them.)+``config`` (same format as ``cabal.project``)+    The full project configuration, merged from ``cabal.project`` (and+    friends) as well as the command line arguments.+``compiler`` (binary)+    The configuration of the compiler being used to build the project.+``improved-plan`` (binary)+    Like ``solver-plan``, but with all non-inplace packages improved+    into pre-existing copies from the store.++Note that every package also has a local cache managed by the Cabal+build system, e.g., in ``$distdir/cache``.++There is another useful file in ``dist-newstyle/cache``, ``plan.json``,+which is a JSON serialization of the computed install plan. (TODO: docs)++Commands+========++We now give an in-depth description of all the commands, describing the+arguments and flags they accept.++cabal new-configure+-------------------++``cabal new-configure`` takes a set of arguments and writes a+``cabal.project.local`` file based on the flags passed to this command.+``cabal new-configure FLAGS; cabal new-build`` is roughly equivalent to+``cabal new-build FLAGS``, except that with ``new-configure`` the flags+are persisted to all subsequent calls to ``new-build``.++``cabal new-configure`` is intended to be a convenient way to write out+a ``cabal.project.local`` for simple configurations; e.g.,+``cabal new-configure -w ghc-7.8`` would ensure that all subsequent+builds with ``cabal new-build`` are performed with the compiler+``ghc-7.8``. For more complex configuration, we recommend writing the+``cabal.project.local`` file directly (or placing it in+``cabal.project``!)++``cabal new-configure`` inherits options from ``Cabal``. semantics:++-  Any flag accepted by ``./Setup configure``.++-  Any flag accepted by ``cabal configure`` beyond+   ``./Setup configure``, namely ``--cabal-lib-version``,+   ``--constraint``, ``--preference`` and ``--solver.``++-  Any flag accepted by ``cabal install`` beyond ``./Setup configure``.++-  Any flag accepted by ``./Setup haddock``.++The options of all of these flags apply only to *local* packages in a+project; this behavior is different than that of ``cabal install``,+which applies flags to every package that would be built. The motivation+for this is to avoid an innocuous addition to the flags of a package+resulting in a rebuild of every package in the store (which might need+to happen if a flag actually applied to every transitive dependency). To+apply options to an external package, use a ``package`` stanza in a+``cabal.project`` file.++cabal new-build+---------------++``cabal new-build`` takes a set of targets and builds them. It+automatically handles building and installing any dependencies of these+targets.++A target can take any of the following forms:++-  A package target: ``package``, which specifies that all enabled+   components of a package to be built. By default, test suites and+   benchmarks are *not* enabled, unless they are explicitly requested+   (e.g., via ``--enable-tests``.)++-  A component target: ``[package:][ctype:]component``, which specifies+   a specific component (e.g., a library, executable, test suite or+   benchmark) to be built.++In component targets, ``package:`` and ``ctype:`` (valid component types+are ``lib``, ``exe``, ``test`` and ``bench``) can be used to+disambiguate when multiple packages define the same component, or the+same component name is used in a package (e.g., a package ``foo``+defines both an executable and library named ``foo``). We always prefer+interpreting a target as a package name rather than as a component name.++Some example targets:++::++    $ cabal new-build lib:foo-pkg       # build the library named foo-pkg+    $ cabal new-build foo-pkg:foo-tests # build foo-tests in foo-pkg++(There is also syntax for specifying module and file targets, but it+doesn't currently do anything.)++Beyond a list of targets, ``cabal new-build`` accepts all the flags that+``cabal new-configure`` takes. Most of these flags are only taken into+consideration when building local packages; however, some flags may+cause extra store packages to be built (for example,+``--enable-profiling`` will automatically make sure profiling libraries+for all transitive dependencies are built and installed.)++cabal new-repl+--------------++``cabal new-repl TARGET`` loads all of the modules of the target into+GHCi as interpreted bytecode. It takes the same flags as+``cabal new-build``.++Currently, it is not supported to pass multiple targets to ``new-repl``+(``new-repl`` will just successively open a separate GHCi session for+each target.)++cabal new-freeze+----------------++``cabal new-freeze`` writes out a ``cabal.project.freeze`` file which+records all of the versions and flags which that are picked by the+solver under the current index and flags. A ``cabal.project.freeze``+file has the same syntax as ``cabal.project`` and looks something like+this:++.. highlight:: cabal++::++    constraints: HTTP ==4000.3.3,+                 HTTP +warp-tests -warn-as-error -network23 +network-uri -mtl1 -conduit10,+                 QuickCheck ==2.9.1,+                 QuickCheck +templatehaskell,+                 -- etc...+++For end-user executables, it is recommended that you distribute the+``cabal.project.freeze`` file in your source repository so that all+users see a consistent set of dependencies. For libraries, this is not+recommended: users often need to build against different versions of+libraries than what you developed against.++Unsupported commands+--------------------++The following commands are not currently supported:++``cabal new-test`` (:issue:`3638`)+    Workaround: run the test executable directly (see `Where are my+    build products <#where-are-my-build-products>`__?)++``cabal new-bench`` (:issue:`3638`)+    Workaround: run the benchmark executable directly (see `Where are my+    build products <#where-are-my-build-products>`__?)++``cabal new-run`` (:issue:`3638`)+    Workaround: run the executable directly (see `Where are my build+    products <#where-are-my-build-products>`__?)++``cabal new-exec``+    Workaround: if you wanted to execute GHCi, consider using+    ``cabal new-repl`` instead. Otherwise, use ``-v`` to find the list+    of flags GHC is being invoked with and pass it manually.++``cabal new-haddock`` (:issue:`3535`)+    Workaround: run+    ``cabal act-as-setup -- haddock --builddir=dist-newstyle/build/pkg-0.1``+    (or execute the Custom setup script directly).++``cabal new-install`` (:issue:`3737`)+    Workaround: no good workaround at the moment. (But note that you no+    longer need to install libraries before building!)++Configuring builds with cabal.project+=====================================++``cabal.project`` files support a variety of options which configure the+details of your build. The general syntax of a ``cabal.project`` file is+similar to that of a Cabal file: there are a number of fields, some of+which live inside stanzas:++::++    packages: */*.cabal+    with-compiler: /opt/ghc/8.0.1/bin/ghc++    package cryptohash+      optimization: False++In general, the accepted field names coincide with the accepted command+line flags that ``cabal install`` and other commands take. For example,+``cabal new-configure --enable-profiling`` will write out a project+file with ``profiling: True``.++The full configuration of a project is determined by combining the+following sources (later entries override earlier ones):++1. ``~/.cabal/config`` (the user-wide global configuration)++2. ``cabal.project`` (the project configuratoin)++3. ``cabal.project.freeze`` (the output of ``cabal new-freeze``)++4. ``cabal.project.local`` (the output of ``cabal new-configure``)+++Specifying the local packages+-----------------------------++The following top-level options specify what the local packages of a+project are:++.. cfg-field:: packages: package location list (space or comma separated)+    :synopsis: Project packages.++    :default: ``./*.cabal``++    Specifies the list of package locations which contain the local+    packages to be built by this project. Package locations can take the+    following forms:++    1. They can specify a Cabal file, or a directory containing a Cabal+       file, e.g., ``packages: Cabal cabal-install/cabal-install.cabal``.++    2. They can specify a glob-style wildcards, which must match one or+       more (a) directories containing a (single) Cabal file, (b) Cabal+       files (extension ``.cabal``), or (c) [STRIKEOUT:tarballs which+       contain Cabal packages (extension ``.tar.gz``)] (not implemented+       yet). For example, to match all Cabal files in all+       subdirectories, as well as the Cabal projects in the parent+       directories ``foo`` and ``bar``, use+       ``packages: */*.cabal ../{foo,bar}/``++    3. [STRIKEOUT:They can specify an ``http``, ``https`` or ``file``+       URL, representing the path to a remote tarball to be downloaded+       and built.] (not implemented yet)++    There is no command line variant of this field; see :issue:`3585`.++.. cfg-field:: optional-packages: package location list (space or comma-separated)+    :synopsis: Optional project packages.++    :default: ``./*/*.cabal``++    Like :cfg-field:`packages`, specifies a list of package locations+    containing local packages to be built. Unlike :cfg-field:`packages`,+    if we glob for a package, it is permissible for the glob to match against+    zero packages. The intended use-case for :cfg-field:`optional-packages`+    is to make it so that vendored packages can be automatically picked up if+    they are placed in a subdirectory, but not error if there aren't any.++    There is no command line variant of this field.++.. cfg-field:: extra-packages: package list with version bounds (comma separated)+    :synopsis: Adds external pacakges as local++    [STRIKEOUT:Specifies a list of external packages from Hackage which+    should be considered local packages.] (Not implemented)++    There is no command line variant of this field.++[STRIKEOUT:There is also a stanza ``source-repository-package`` for+specifying packages from an external version control.] (Not+implemented.)++All local packages are *vendored*, in the sense that if other packages+(including external ones from Hackage) depend on a package with the name+of a local package, the local package is preferentially used.  This+motivates the default settings::++    packages: ./*.cabal+    optional-packages: ./*/*.cabal++...any package can be vendored simply by making a checkout in the+top-level project directory, as might be seen in this hypothetical+directory layout::++    foo.cabal+    foo-helper/     # local package+    unix/           # vendored external package++All of these options support globs. ``cabal new-build`` has its own glob+format:++-  Anywhere in a path, as many times as you like, you can specify an+   asterisk ``*`` wildcard. E.g., ``*/*.cabal`` matches all ``.cabal``+   files in all immediate subdirectories. Like in glob(7), asterisks do+   not match hidden files unless there is an explicit period, e.g.,+   ``.*/foo.cabal`` will match ``.private/foo.cabal`` (but+   ``*/foo.cabal`` will not).++-  You can use braces to specify specific directories; e.g.,+   ``{vendor,pkgs}/*.cabal`` matches all Cabal files in the ``vendor``+   and ``pkgs`` subdirectories.++Formally, the format described by the following BNF:++.. code-block:: abnf++    FilePathGlob    ::= FilePathRoot FilePathGlobRel+    FilePathRoot    ::= {- empty -}        # relative to cabal.project+                      | "/"                # Unix root+                      | [a-zA-Z] ":" [/\\] # Windows root+                      | "~"                # home directory+    FilePathGlobRel ::= Glob "/"  FilePathGlobRel # Unix directory+                      | Glob "\\" FilePathGlobRel # Windows directory+                      | Glob         # file+                      | {- empty -}  # trailing slash+    Glob      ::= GlobPiece *+    GlobPiece ::= "*"            # wildcard+                | [^*{},/\\] *   # literal string+                | "\\" [*{},]    # escaped reserved character+                | "{" Glob "," ... "," Glob "}" # union (match any of these)++Global configuration options+----------------------------++The following top-level configuration options are not specific to any+package, and thus apply globally:++.. cfg-field:: verbose: nat+               --verbose=n, -vn+    :synopsis: Build verbosity level.++    :default: 1++    Control the verbosity of ``cabal`` commands, valid values are from 0+    to 3.++    The command line variant of this field is ``--verbose=2``; a short+    form ``-v2`` is also supported.++.. cfg-field:: jobs: nat or $ncpus+               --jobs=n, -jn, --jobs=$ncpus+    :synopsis: Number of builds running in parallel.++    :default: 1++    Run *nat* jobs simultaneously when building. If ``$ncpus`` is+    specified, run the number of jobs equal to the number of CPUs.+    Package building is often quite parallel, so turning on parallelism+    can speed up build times quite a bit!++    The command line variant of this field is ``--jobs=2``; a short form+    ``-j2`` is also supported; a bare ``--jobs`` or ``-j`` is equivalent+    to ``--jobs=$ncpus``.++.. cfg-field::  keep-going: boolean+                --keep-going+    :synopsis: Try to continue building on failure.++    :default: False++    If true, after a build failure, continue to build other unaffected+    packages.++    The command line variant of this field is ``--keep-going``.+++Solver configuration options+----------------------------++The following settings control the behavior of the dependency solver:++.. cfg-field:: constraints: constraints list (comma separated)+               --constrant="pkg >= 2.0"+    :synopsis: Extra dependencies constraints.++    Add extra constraints to the version bounds, flag settings, and+    other properties a solver can pick for a package. For example, to+    only consider install plans that do not use ``bar`` at all, or use+    ``bar-2.1``, write:++    ::++        constraints: bar == 2.1++    Version bounds have the same syntax as ``build-depends``. You can+    also specify flag assignments:++    ::++        -- Require bar to be installed with the foo flag turned on and+        -- the baz flag turned off+        constraints: bar +foo -baz++        -- Require that bar NOT be present in the install plan. Note:+        -- this is just syntax sugar for '> 1 && < 1', and is supported+        -- by build-depends.+        constraints: bar -none++    A package can be specified multiple times in ``constraints``, in+    which case the specified constraints are intersected. This is+    useful, since the syntax does not allow you to specify multiple+    constraints at once. For example, to specify both version bounds and+    flag assignments, you would write:++    ::++        constraints: bar == 2.1,+                     bar +foo -baz,++    There are also some more specialized constraints, which most people+    don't generally need:++    ::++        -- Require bar to be preinstalled in the global package database+        -- (this does NOT include the Nix-local build global store.)+        constraints: bar installed++        -- Require the local source copy of bar to be used+        -- (Note: By default, if we have a local package we will+        -- automatically use it, so it generally not be necessary to+        -- specify this)+        constraints: bar source++        -- Require that bar be solved with test suites and benchmarks enabled+        -- (Note: By default, new-build configures the solver to make+        -- a best-effort attempt to enable these stanzas, so this generally+        -- should not be necessary.)+        constraints: bar test,+                     bar bench++    The command line variant of this field is+    ``--constraint="pkg >= 2.0"``; to specify multiple constraints, pass+    the flag multiple times.++.. cfg-field:: preferences: preference (comma separated)+               --preference="pkg >= 2.0"+    :synopsis: Prefered dependency versions.++    Like :cfg-field:`constraints`, but the solver will attempt to satisfy+    these preferences on a best-effort basis. The resulting install is locally+    optimal with respect to preferences; specifically, no single package+    could be replaced with a more preferred version that still satisfies+    the hard constraints.++    Operationally, preferences can cause the solver to attempt certain+    version choices of a package before others, which can improve+    dependency solver runtime.++    One way to use :cfg-field:`preferences` is to take a known working set of+    constraints (e.g., via ``cabal new-freeze``) and record them as+    preferences. In this case, the solver will first attempt to use this+    configuration, and if this violates hard constraints, it will try to+    find the minimal number of upgrades to satisfy the hard constraints+    again.++    The command line variant of this field is+    ``--preference="pkg >= 2.0"``; to specify multiple preferences, pass+    the flag multiple times.++.. cfg-field:: allow-newer: none, all or list of scoped package names (space or comma separated)+               --allow-newer, --allow-newer=[none,all,pkg]+    :synopsis: Lift dependencies upper bound constaints.++    :default: ``none``++    Allow the solver to pick an newer version of some packages than+    would normally be permitted by than the :pkg-field:`build-depends` bounds+    of packages in the install plan. This option may be useful if the+    dependency solver cannot otherwise find a valid install plan.++    For example, to relax ``pkg``\ s :pkg-field:`build-depends` upper bound on+    ``dep-pkg``, write a scoped package name of the form:++    ::++        allow-newer: pkg:dep-pkg++    This syntax is recommended, as it is often only a single package+    whose upper bound is misbehaving. In this case, the upper bounds of+    other packages should still be respected; indeed, relaxing the bound+    can break some packages which test the selected version of packages.++    However, in some situations (e.g., when attempting to build packages+    on a new version of GHC), it is useful to disregard *all*+    upper-bounds, with respect to a package or all packages. This can be+    done by specifying just a package name, or using the keyword ``all``+    to specify all packages:++    ::++        -- Disregard upper bounds involving the dependencies on+        -- packages bar, baz and quux+        allow-newer: bar, baz, quux++        -- Disregard all upper bounds when dependency solving+        allow-newer: all++    :cfg-field:`allow-newer` is often used in conjunction with a constraint+    (in the cfg-field:`constraints` field) forcing the usage of a specific,+    newer version of a package.++    The command line variant of this field is ``--allow-newer=bar``. A+    bare ``--allow-newer`` is equivalent to ``--allow-newer=all``.++.. cfg-field:: allow-older: none, all, list of scoped package names (space or comma separated)+               --allow-older, --allow-older=[none,all,pkg]+    :synopsis: Lift dependency lower bound constaints.++    :default: ``none``++    Like :cfg-field:`allow-newer`, but applied to lower bounds rather than+    upper bounds.++    The command line variant of this field is ``--allow-older=all``. A+    bare ``--allow-older`` is equivalent to ``--allow-older=all``.+++.. cfg-field:: index-state: HEAD, unix-timestamp, ISO8601 UTC timestamp.+   :synopsis: Use source package index state as it existed at a previous time.+   :since: 1.25++   :default: ``HEAD``++   This allows to change the source package index state the solver uses+   to compute install-plans. This is particularly useful in+   combination with freeze-files in order to also freeze the state the+   package index was in at the time the install-plan was frozen.++   ::++      -- UNIX timestamp format example+      index-state: @1474739268++      -- ISO8601 UTC timestamp format example+      -- This format is used by 'cabal new-configure'+      -- for storing `--index-state` values.+      index-state: 2016-09-24T17:47:48Z+++Package configuration options+-----------------------------++Package options affect the building of specific packages. There are two+ways a package option can be specified:++-  They can be specified at the top-level, in which case they apply only+   to **local package**, or++-  They can be specified inside a ``package`` stanza, in which case they+   apply to the build of the package, whether or not it is local or+   external.++For example, the following options specify that :cfg-field:`optimization`+should be turned off for all local packages, and that ``bytestring`` (possibly+an external dependency) should be built with ``-fno-state-hack``::++    optimization: False++    package bytestring+        ghc-options: -fno-state-hack++``ghc-options`` is not specifically described in this documentation,+but is one of many fields for configuring programs.  They take the form+``progname-options`` and ``progname-location``, and+can only be set inside package stanzas.  (TODO: They are not supported+at top-level, see :issue:`3579`.)++At the moment, there is no way to specify an option to apply to all+external packages or all inplace packages. Additionally, it is only+possible to specify these options on the command line for all local+packages (there is no per-package command line interface.)++Some flags were added by more recent versions of the Cabal library. This+means that they are NOT supported by packages which use Custom setup+scripts that require a version of the Cabal library older than when the+feature was added.++.. cfg-field:: flags: list of +flagname or -flagname (space separated)+               --flags="+foo -bar", -ffoo, -f-bar+    :synopsis: Enable or disable package flags.++    Force all flags specified as ``+flagname`` to be true, and all flags+    specified as ``-flagname`` to be false. For example, to enable the+    flag ``foo`` and disable ``bar``, set:++    ::++        flags: +foo -bar++    If there is no leading punctuation, it is assumed that the flag+    should be enabled; e.g., this is equivalent:++    ::++        flags: foo -bar++    Flags are *per-package*, so it doesn't make much sense to specify+    flags at the top-level, unless you happen to know that *all* of your+    local packages support the same named flags. If a flag is not+    supported by a package, it is ignored.++    See also the solver configuration field :cfg-field:`constraints`.++    The command line variant of this flag is ``--flags``. There is also+    a shortened form ``-ffoo -f-bar``.++    A common mistake is to say ``cabal new-build -fhans``, where+    ``hans`` is a flag for a transitive dependency that is not in the+    local package; in this case, the flag will be silently ignored. If+    ``haskell-tor`` is the package you want this flag to apply to, try+    ``--constraint="haskell-tor +hans"`` instead.++.. cfg-field:: with-compiler: executable+               --with-compiler=executable+    :synopsis: Path to compiler executable.++    Specify the path to a particular compiler to be used. If not an+    absolute path, it will be resolved according to the :envvar:`PATH`+    environment. The type of the compiler (GHC, GHCJS, etc) must be+    consistent with the setting of the :cfg-field:`compiler` field.++    The most common use of this option is to specify a different version+    of your compiler to be used; e.g., if you have ``ghc-7.8`` in your+    path, you can specify ``with-compiler: ghc-7.8`` to use it.++    This flag also sets the default value of :cfg-field:`with-hc-pkg`, using+    the heuristic that it is named ``ghc-pkg-7.8`` (if your executable name+    is suffixed with a version number), or is the executable named+    ``ghc-pkg`` in the same directory as the ``ghc`` directory. If this+    heuristic does not work, set :cfg-field:`with-hc-pkg` explicitly.++    For inplace packages, ``cabal new-build`` maintains a separate build+    directory for each version of GHC, so you can maintain multiple+    build trees for different versions of GHC without clobbering each+    other.++    At the moment, it's not possible to set :cfg-field:`with-compiler` on a+    per-package basis, but eventually we plan on relaxing this+    restriction. If this is something you need, give us a shout.++    The command line variant of this flag is+    ``--with-compiler=ghc-7.8``; there is also a short version+    ``-w ghc-7.8``.++.. cfg-field:: with-hc-pkg: executable+               --with-hc-pkg=executable+    :synopsis: Specifies package tool.++    Specify the path to the package tool, e.g., ``ghc-pkg``. This+    package tool must be compatible with the compiler specified by+    :cfg-field:`with-compiler` (generally speaking, it should be precisely+    the tool that was distributed with the compiler). If this option is+    omitted, the default value is determined from :cfg-field:`with-compiler`.++    The command line variant of this flag is+    ``--with-hc-pkg=ghc-pkg-7.8``.++.. cfg-field:: optimization: nat+               --enable-optimization+               --disable-optimization+    :synopsis: Build with optimization.++    :default: ``1``++    Build with optimization. This is appropriate for production use,+    taking more time to build faster libraries and programs.++    The optional *nat* value is the optimisation level. Some compilers+    support multiple optimisation levels. The range is 0 to 2. Level 0+    disables optimization, level 1 is the default. Level 2 is higher+    optimisation if the compiler supports it. Level 2 is likely to lead+    to longer compile times and bigger generated code. If you are not+    planning to run code, turning off optimization will lead to better+    build times and less code to be rebuilt when a module changes.++    We also accept ``True`` (equivalent to 1) and ``False`` (equivalent+    to 0).++    Note that as of GHC 8.0, GHC does not recompile when optimization+    levels change (see :ghc-ticket:`10923`), so if+    you change the optimization level for a local package you may need+    to blow away your old build products in order to rebuild with the+    new optimization level.++    The command line variant of this flag is ``-O2`` (with ``-O1``+    equivalent to ``-O``). There are also long-form variants+    ``--enable-optimization`` and ``--disable-optimization``.++.. cfg-field:: configure-options: args (space separated)+               --configure-option=arg+    :synopsis: Options to pass to configure script.++    A list of extra arguments to pass to the external ``./configure``+    script, if one is used. This is only useful for packages which have+    the ``Configure`` build type. See also the section on+    `system-dependent+    parameters <developing-packages.html#system-dependent-parameters>`__.++    The command line variant of this flag is ``--configure-option=arg``,+    which can be specified multiple times to pass multiple options.++.. cfg-field:: compiler: ghc, ghcjs, jhc, lhc, uhc or haskell-suite+               --compiler=compiler+    :synopsis: Compiler to build with.++    :default: ``ghc``++    Specify which compiler toolchain to be used. This is independent of+    ``with-compiler``, because the choice of toolchain affects Cabal's+    build logic.++    The command line variant of this flag is ``--compiler=ghc``.++.. cfg-field:: tests: boolean+               --enable-tests+               --disable-tests+    :synopsis: Build tests.++    :default: ``False``++    Force test suites to be enabled. For most users this should not be+    needed, as we always attempt to solve for test suite dependencies,+    even when this value is ``False``; furthermore, test suites are+    automatically enabled if they are requested as a built target.++    The command line variant of this flag is ``--enable-tests`` and+    ``--disable-tests``.++.. cfg-field:: benchmarks: boolean+               --enable-benchmarks+               --disable-benchmarks+    :synopsis: Build benchmarks.++    :default: ``False``++    Force benchmarks to be enabled. For most users this should not be+    needed, as we always attempt to solve for benchmark dependencies,+    even when this value is ``False``; furthermore, benchmarks are+    automatically enabled if they are requested as a built target.++    The command line variant of this flag is ``--enable-benchmarks`` and+    ``--disable-benchmarks``.++.. cfg-field:: extra-prog-path: paths (newline or comma separated)+               --extra-prog-path=PATH+    :synopsis: Add directories to program search path.+    :since: 1.18++    A list of directories to search for extra required programs. Most+    users should not need this, as programs like ``happy`` and ``alex``+    will automatically be installed and added to the path. This can be+    useful if a ``Custom`` setup script relies on an exotic extra+    program.++    The command line variant of this flag is ``--extra-prog-path=PATH``,+    which can be specified multiple times.++.. cfg-field:: run-tests: boolean+               --run-tests+    :synopsis: Run package test suite upon installation.++    :default: ``False``++    Run the package test suite upon installation. This is useful for+    saying "When this package is installed, check that the test suite+    passes, terminating the rest of the build if it is broken."++    .. warning::++      One deficiency: the :cfg-field:`run-tests` setting of a package is NOT+      recorded as part of the hash, so if you install something without+      :cfg-field:`run-tests` and then turn on ``run-tests``, we won't+      subsequently test the package. If this is causing you problems, give+      us a shout.++    The command line variant of this flag is ``--run-tests``.++Object code options+^^^^^^^^^^^^^^^^^^^++.. cfg-field:: debug-info: boolean+               --enable-debug-info+               --disable-debug-info+    :synopsis: Build with debug info enabled.+    :since: 1.22++    :default: False++    If the compiler (e.g., GHC 7.10 and later) supports outputing OS+    native debug info (e.g., DWARF), setting ``debug-info: True`` will+    instruct it to do so. See the GHC wiki page on :ghc-wiki:`DWARF`+    for more information about this feature.++    (This field also accepts numeric syntax, but as of GHC 8.0 this+    doesn't do anything.)++    The command line variant of this flag is ``--enable-debug-info`` and+    ``--disable-debug-info``.++.. cfg-field:: split-objs: boolean+               --enable-split-objs+               --disable-split-objs+    :synopsis: Use GHC split objects feature.++    :default: False++    Use the GHC ``-split-objs`` feature when building the library. This+    reduces the final size of the executables that use the library by+    allowing them to link with only the bits that they use rather than+    the entire library. The downside is that building the library takes+    longer and uses considerably more memory.++    The command line variant of this flag is ``--enable-split-objs`` and+    ``--disable-split-objs``.++.. cfg-field:: executable-stripping: boolean+               --enable-executable-stripping+               --disable-executable-stripping+    :synopsis: Strip installed programs.++    :default: True++    When installing binary executable programs, run the ``strip``+    program on the binary. This can considerably reduce the size of the+    executable binary file. It does this by removing debugging+    information and symbols.++    Not all Haskell implementations generate native binaries. For such+    implementations this option has no effect.++    (TODO: Check what happens if you combine this with ``debug-info``.)++    The command line variant of this flag is+    ``--enable-executable-stripping`` and+    ``--disable-executable-stripping``.++.. cfg-field:: library-stripping: boolean+               --enable-library-stripping+               --disable-library-stripping+    :synopsis: Strip installed libraries.+    :since: 1.19++    When installing binary libraries, run the ``strip`` program on the+    binary, saving space on the file system. See also+    ``executable-stripping``.++    The command line variant of this flag is+    ``--enable-library-stripping`` and ``--disable-library-stripping``.++Executable options+^^^^^^^^^^^^^^^^^^++.. cfg-field:: program-prefix: prefix+               --program-prefix=prefix+    :synopsis: Prepend prefix to program names.++    [STRIKEOUT:Prepend *prefix* to installed program names.] (Currently+    implemented in a silly and not useful way. If you need this to work+    give us a shout.)++    *prefix* may contain the following path variables: ``$pkgid``,+    ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++    The command line variant of this flag is ``--program-prefix=foo-``.++.. cfg-field:: program-suffix: suffix+               --program-suffix=suffix+    :synopsis: Append refix to program names.++    [STRIKEOUT:Append *suffix* to installed program names.] (Currently+    implemented in a silly and not useful way. If you need this to work+    give us a shout.)++    The most obvious use for this is to append the program's version+    number to make it possible to install several versions of a program+    at once: ``program-suffix: $version``.++    *suffix* may contain the following path variables: ``$pkgid``,+    ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``,+    ``$abitag``++    The command line variant of this flag is+    ``--program-suffix='$version'``.++Dynamic linking options+^^^^^^^^^^^^^^^^^^^^^^^++.. cfg-field:: shared: boolean+               --enable-shared+               --disable-shared+    :synopsis: Build shared library.++    :default: False++    Build shared library. This implies a separate compiler run to+    generate position independent code as required on most platforms.++    The command line variant of this flag is ``--enable-shared`` and+    ``--disable-shared``.++.. cfg-field:: executable-dynamic: boolean+               --enable-executable-dynamic+               --disable-executable-dynamic+    :synopsis: Link executables dynamically.++    :default: False++    Link executables dynamically. The executable's library dependencies+    should be built as shared objects. This implies ``shared: True``+    unless ``shared: False`` is explicitly specified.++    The command line variant of this flag is+    ``--enable-executable-dynamic`` and+    ``--disable-executable-dynamic``.++.. cfg-field:: library-for-ghci: boolean+               --enable-library-for-ghci+               --disable-library-for-ghci+    :synopsis: Build libraries suitable for use with GHCi.++    :default: True++    Build libraries suitable for use with GHCi. This involves an extra+    linking step after the build.++    Not all platforms support GHCi and indeed on some platforms, trying+    to build GHCi libs fails. In such cases, consider setting+    ``library-for-ghci: False``.++    The command line variant of this flag is+    ``--enable-library-for-ghci`` and ``--disable-library-for-ghci``.++.. cfg-field:: relocatable:+               --relocatable+    :synopsis: Build relocatable package.+    :since: 1.21++    :default: False++    [STRIKEOUT:Build a package which is relocatable.] (TODO: It is not+    clear what this actually does, or if it works at all.)++    The command line variant of this flag is ``--relocatable``.++Foreign function interface options+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++.. cfg-field:: extra-include-dirs: directories (comma or newline separated list)+               --extra-include-dirs=DIR+    :synopsis: Adds C header search path.++    An extra directory to search for C header files. You can use this+    flag multiple times to get a list of directories.++    You might need to use this flag if you have standard system header+    files in a non-standard location that is not mentioned in the+    package's ``.cabal`` file. Using this option has the same affect as+    appending the directory *dir* to the :pkg-field:`include-dirs` field in each+    library and executable in the package's ``.cabal`` file. The+    advantage of course is that you do not have to modify the package at+    all. These extra directories will be used while building the package+    and for libraries it is also saved in the package registration+    information and used when compiling modules that use the library.++    The command line variant of this flag is+    ``--extra-include-dirs=DIR``, which can be specified multiple times.++.. cfg-field:: extra-lib-dirs: directories (comma or newline separated list)+               --extra-lib-dirs=DIR+    :synopsis: Adds library search directory.++    An extra directory to search for system libraries files.++    The command line variant of this flag is ``--extra-lib-dirs=DIR``,+    which can be specified multiple times.++.. cfg-field:: extra-framework-dirs: directories (comma or newline separated list)+               --extra-framework-dirs=DIR+    :synopsis: Adds framework search directory (OS X only).++    An extra directory to search for frameworks (OS X only).++    You might need to use this flag if you have standard system+    libraries in a non-standard location that is not mentioned in the+    package's ``.cabal`` file. Using this option has the same affect as+    appending the directory *dir* to the :cfg-field:`extra-lib-dirs` field in+    each library and executable in the package's ``.cabal`` file. The+    advantage of course is that you do not have to modify the package at+    all. These extra directories will be used while building the package+    and for libraries it is also saved in the package registration+    information and used when compiling modules that use the library.++    The command line variant of this flag is+    ``--extra-framework-dirs=DIR``, which can be specified multiple+    times.++Profiling options+^^^^^^^^^^^^^^^^^++.. cfg-field:: profiling: boolean+               --enable-profiling+               --disable-profiling+    :synopsis: Enable profiling builds.+    :since: 1.21++    :default: False++    Build libraries and executables with profiling enabled (for+    compilers that support profiling as a separate mode). It is only+    necessary to specify :cfg-field:`profiling` for the specific package you+    want to profile; ``cabal new-build`` will ensure that all of its+    transitive dependencies are built with profiling enabled.++    To enable profiling for only libraries or executables, see+    :cfg-field:`library-profiling` and :cfg-field:`executable-profiling`.++    For useful profiling, it can be important to control precisely what+    cost centers are allocated; see :cfg-field:`profiling-detail`.++    The command line variant of this flag is ``--enable-profiling`` and+    ``--disable-profiling``.++.. cfg-field:: profiling-detail: level+               --profiling-detail=level+    :synopsis: Profiling detail level.+    :since: 1.23++    Some compilers that support profiling, notably GHC, can allocate+    costs to different parts of the program and there are different+    levels of granularity or detail with which this can be done. In+    particular for GHC this concept is called "cost centers", and GHC+    can automatically add cost centers, and can do so in different ways.++    This flag covers both libraries and executables, but can be+    overridden by the ``library-profiling-detail`` field.++    Currently this setting is ignored for compilers other than GHC. The+    levels that cabal currently supports are:++    default+        For GHC this uses ``exported-functions`` for libraries and+        ``toplevel-functions`` for executables.+    none+        No costs will be assigned to any code within this component.+    exported-functions+        Costs will be assigned at the granularity of all top level+        functions exported from each module. In GHC, this+        is for non-inline functions.  Corresponds to ``-fprof-auto-exported``.+    toplevel-functions+        Costs will be assigned at the granularity of all top level+        functions in each module, whether they are exported from the+        module or not. In GHC specifically, this is for non-inline+        functions.  Corresponds to ``-fprof-auto-top``.+    all-functions+        Costs will be assigned at the granularity of all functions in+        each module, whether top level or local. In GHC specifically,+        this is for non-inline toplevel or where-bound functions or+        values.  Corresponds to ``-fprof-auto``.++    The command line variant of this flag is+    ``--profiling-detail=none``.++.. cfg-field:: library-profiling-detail: level+               --library-profiling-detail=level+    :synopsis: Libraries profiling detail level.+    :since: 1.23++    Like :cfg-field:`profiling-detail`, but applied only to libraries++    The command line variant of this flag is+    ``--library-profiling-detail=none``.++.. cfg-field:: library-vanilla: boolean+               --enable-library-vanilla+               --disable-library-vanilla+    :synopsis: Build libraries without profiling.++    :default: True++    Build ordinary libraries (as opposed to profiling libraries).+    Mostly, you can set this to False to avoid building ordinary+    libraries when you are profiling.++    The command line variant of this flag is+    ``--enable-library-vanilla`` and ``--disable-library-vanilla``.++.. cfg-field:: library-profiling: boolean+               --enable-library-profiling+               --disable-library-profiling+    :synopsis: Build libraries with profiling enabled.+    :since: 1.21++    :default: False++    Build libraries with profiling enabled.  You probably want+    to use :cfg-field:`profiling` instead.++    The command line variant of this flag is+    ``--enable-library-profiling`` and ``--disable-library-profiling``.++.. cfg-field:: executable-profiling: boolean+               --enable-executable-profiling+               --disable-executable-profiling+    :synopsis: Build executables with profiling enabled.+    :since: 1.21++    :default: False++    Build executables with profiling enabled. You probably want+    to use :cfg-field:`profiling` instead.++    The command line variant of this flag is+    ``--enable-executable-profiling`` and+    ``--disable-executable-profiling``.++Coverage options+^^^^^^^^^^^^^^^^++.. cfg-field:: coverage: boolean+               --enable-coverage+               --disable-coverage+    :synopsis: Build with coverage enabled.+    :since: 1.21++    :default: False++    Build libraries and executables (including test suites) with Haskell+    Program Coverage enabled. Running the test suites will automatically+    generate coverage reports with HPC.++    The command line variant of this flag is ``--enable-coverage`` and+    ``--disable-coverage``.++.. cfg-field:: library-coverage: boolean+               --enable-library-coverage+               --disable-library-coverage+    :since: 1.21+    :deprecated:++    :default: False++    Deprecated, use :cfg-field:`coverage`.++    The command line variant of this flag is+    ``--enable-library-coverage`` and ``--disable-library-coverage``.++Haddock options+^^^^^^^^^^^^^^^++Documentation building support is fairly sparse at the moment. Let us+know if it's a priority for you!++.. cfg-field:: documentation: boolean+               --enable-documentation+               --disable-documentation+    :synopsis: Enable building of documentation.++    :default: False++    Enables building of Haddock documentation++    The command line variant of this flag is ``--enable-documentation``+    and ``--disable-documentation``.++.. cfg-field:: doc-index-file: templated path+               --doc-index-file=TEMPLATE+    :synopsis: Path to haddock templates.++    A central index of Haddock API documentation (template cannot use+    ``$pkgid``), which should be updated as documentation is built.++    The command line variant of this flag is+    ``--doc-index-file=TEMPLATE``++The following commands are equivalent to ones that would be passed when+running ``setup haddock``. (TODO: Where does the documentation get put.)++.. cfg-field:: haddock-hoogle: boolean+    :synopsis: Generate Hoogle file.++    :default: False++    Generate a text file which can be converted by Hoogle_+    into a database for searching. This is equivalent to running ``haddock``+    with the ``--hoogle`` flag.++    The command line variant of this flag is ``--hoogle`` (for the+    ``haddock`` command).++.. cfg-field:: haddock-html: boolean+    :synopsis: Build HTML documentation.++    :default: True++    Build HTML documentation.++    The command line variant of this flag is ``--html`` (for the+    ``haddock`` command).++.. cfg-field:: haddock-html-location: templated path+    :synopsis: Haddock HTML templates location.++    Specify a template for the location of HTML documentation for+    prerequisite packages. The substitutions are applied to the template+    to obtain a location for each package, which will be used by+    hyperlinks in the generated documentation. For example, the+    following command generates links pointing at [Hackage] pages:++    ::++        html-location: 'http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html'++    Here the argument is quoted to prevent substitution by the shell. If+    this option is omitted, the location for each package is obtained+    using the package tool (e.g. ``ghc-pkg``).++    The command line variant of this flag is ``--html-location`` (for+    the ``haddock`` subcommand).++.. cfg-field:: haddock-executables: boolean+    :synopsis: Generate documentation for executables.++    :default: False++    Run haddock on all executable programs.++    The command line variant of this flag is ``--executables`` (for the+    ``haddock`` subcommand).++.. cfg-field:: haddock-tests: boolean+    :synopsis: Generate documentation for tests.++    :default: False++    Run haddock on all test suites.++    The command line variant of this flag is ``--tests`` (for the+    ``haddock`` subcommand).++.. cfg-field:: haddock-benchmarks: boolean+    :synopsis: Generate documentation for benchmarks.++    :default: False++    Run haddock on all benchmarks.++    The command line variant of this flag is ``--benchmarks`` (for the+    ``haddock`` subcommand).++.. cfg-field:: haddock-all: boolean+    :synopsis: Generate documentation for everything++    :default: False++    Run haddock on all components.++    The command line variant of this flag is ``--all`` (for the+    ``haddock`` subcommand).++.. cfg-field:: haddock-internal: boolean+    :synopsis: Generate documentation for internal modules++    :default: False++    Build haddock documentation which includes unexposed modules and+    symbols.++    The command line variant of this flag is ``--internal`` (for the+    ``haddock`` subcommand).++.. cfg-field:: haddock-css: path+    :synopsis: Location of Haddoc CSS file.++    The CSS file that should be used to style the generated+    documentation (overriding haddock's default.)++    The command line variant of this flag is ``--css`` (for the+    ``haddock`` subcommand).++.. cfg-field:: haddock-hyperlink-source: boolean+    :synopsis: Generate hyperlinked source code for documentation++    :default: False++    Generated hyperlinked source code using `HsColour`_, and have+    Haddock documentation link to it.++    The command line variant of this flag is ``--hyperlink-source`` (for+    the ``haddock`` subcommand).++.. cfg-field:: haddock-hscolour-css: path+    :synopsis: Location of CSS file for HsColour++    The CSS file that should be used to style the generated hyperlinked+    source code (from `HsColour`_).++    The command line variant of this flag is ``--hscolour-css`` (for the+    ``haddock`` subcommand).++.. cfg-field:: haddock-contents-location: URL+    :synopsis: URL for contents page.++    A baked-in URL to be used as the location for the contents page.++    The command line variant of this flag is ``--contents-location``+    (for the ``haddock`` subcommand).++.. cfg-field:: haddock-keep-temp-files: boolean+    :synopsis: Keep temporary Haddock files.++    Keep temporary files.++    The command line variant of this flag is ``--keep-temp-files`` (for+    the ``haddock`` subcommand).++Advanced global configuration options+-------------------------------------++.. cfg-field:: http-transport: curl, wget, powershell, or plain-http+               --http-transport=transport+    :synopsis: Transport to use with http(s) requests.++    :default: ``curl``++    Set a transport to be used when making http(s) requests.++    The command line variant of this field is ``--http-transport=curl``.++.. cfg-field:: ignore-expiry: boolean+               --ignore-expiry+    :synopsis: Ignore Hackage expiration dates.++    :default: False++    If ``True``, we will ignore expiry dates on metadata from Hackage.++    In general, you should not set this to ``True`` as it will leave you+    vulnerable to stale cache attacks. However, it may be temporarily+    useful if the main Hackage server is down, and we need to rely on+    mirrors which have not been updated for longer than the expiry+    period on the timestamp.++    The command line variant of this field is ``--ignore-expiry``.++.. cfg-field:: remote-repo-cache: directory+               --remote-repo-cache=DIR+    :synopsis: Location of packages cache.++    :default: ``~/.cabal/packages``++    [STRIKEOUT:The location where packages downloaded from remote+    repositories will be cached.] Not implemented yet.++    The command line variant of this flag is+    ``--remote-repo-cache=DIR``.++.. cfg-field:: logs-dir: directory+               --logs-dir=DIR+    :synopsis: Directory to store build logs.++    :default: ``~/.cabal/logs``++    [STRIKEOUT:The location where build logs for packages are stored.]+    Not implemented yet.++    The command line variant of this flag is ``--logs-dir=DIR``.++.. cfg-field:: build-summary: template filepath+               --build-summary=TEMPLATE+    :synopsis: Build summaries location.++    :default: ``~/.cabal/logs/build.log``++    [STRIKEOUT:The file to save build summaries. Valid variables which+    can be used in the path are ``$pkgid``, ``$compiler``, ``$os`` and+    ``$arch``.] Not implemented yet.++    The command line variant of this flag is+    ``--build-summary=TEMPLATE``.++.. cfg-field:: local-repo: directory+               --local-repo=DIR+    :deprecated:++    [STRIKEOUT:The location of a local repository.] Deprecated. See+    "Legacy repositories."++    The command line variant of this flag is ``--local-repo=DIR``.++.. cfg-field:: world-file: path+               --world-file=FILE+    :deprecated:++    [STRIKEOUT:The location of the world file.] Deprecated.++    The command line variant of this flag is ``--world-file=FILE``.++Undocumented fields: ``root-cmd``, ``symlink-bindir``, ``build-log``,+``remote-build-reporting``, ``report-planned-failure``, ``one-shot``,+``offline``.++Advanced solver options+^^^^^^^^^^^^^^^^^^^^^^^++Most users generally won't need these.++.. cfg-field:: solver: modular+               --solver=modular+    :synopsis: Which solver to use.++    This field is reserved to allow the specification of alternative+    dependency solvers. At the moment, the only accepted option is+    ``modular``.++    The command line variant of this field is ``--solver=modular``.++.. cfg-field:: max-backjumps: nat+               --max-backjumps=N+    :synopsis: Maximum number of solver backjumps.++    :default: 2000++    Maximum number of backjumps (backtracking multiple steps) allowed+    while solving. Set -1 to allow unlimited backtracking, and 0 to+    disable backtracking completely.++    The command line variant of this field is ``--max-backjumps=2000``.++.. cfg-field:: reorder-goals: boolean+               --reorder-goals+               --no-reorder-goals+    :synopsis: Allow solver to reorder goals.++    :default: False++    When enabled, the solver will reorder goals according to certain+    heuristics. Slows things down on average, but may make backtracking+    faster for some packages. It's unlikely to help for small projects,+    but for big install plans it may help you find a plan when otherwise+    this is not possible. See :issue:`1780` for more commentary.++    The command line variant of this field is ``--(no-)reorder-goals``.++.. cfg-field:: count-conflicts: boolean+               --count-conflicts+               --no-count-conflicts+    :synopsis: Solver prefers versions with less conflicts.++    :default: True++    Try to speed up solving by preferring goals that are involved in a+    lot of conflicts.++    The command line variant of this field is+    ``--(no-)count-conflicts``.++.. cfg-field:: strong-flags: boolean+               --strong-flags+               --no-strong-flags+    :synopsis: Do not defer flag choices when solving.++    :default: False++    Do not defer flag choices. (TODO: Better documentation.)++    The command line variant of this field is ``--(no-)strong-flags``.++.. cfg-field:: cabal-lib-version: version+               --cabal-lib-version=version+    :synopsis: Version of Cabal library used to build package.++    This field selects the version of the Cabal library which should be+    used to build packages. This option is intended primarily for+    internal development use (e.g., forcing a package to build with a+    newer version of Cabal, to test a new version of Cabal.) (TODO:+    Specify its semantics more clearly.)++    The command line variant of this field is+    ``--cabal-lib-version=1.24.0.1``.+++.. include:: references.inc
+ cabal/Cabal/doc/references.inc view
@@ -0,0 +1,22 @@+.. -*- rst -*-+   This file contains commonly used link-references+   See also "extlinks" in conf.py++.. _`Package Versioning Policy`:+.. _PVP: http://pvp.haskell.org/++.. _Hackage: http://hackage.haskell.org/++.. _Haskell: http://www.haskell.org/++.. _Haddock: http://www.haskell.org/haddock/++.. _Alex: http://www.haskell.org/alex/++.. _Happy: http://www.haskell.org/happy/++.. _Hoogle: http://www.haskell.org/hoogle/++.. _HsColour: http://www.cs.york.ac.uk/fp/darcs/hscolour/++.. _cpphs: http://projects.haskell.org/cpphs/
+ cabal/Cabal/misc/gen-authors.sh view
@@ -0,0 +1,3 @@+#! /bin/sh++git shortlog -se | cut -f 2-
+ cabal/Cabal/misc/gen-extra-source-files.hs view
@@ -0,0 +1,119 @@+#!/usr/bin/env runhaskell+{-# LANGUAGE PackageImports #-}++-- NB: Force an installed Cabal package to be used, NOT+-- some local files which have these names (as would be+-- the case if we were in the Cabal source directory.)+import "Cabal" Distribution.PackageDescription+import "Cabal" Distribution.PackageDescription.Parse (ParseResult (..), parsePackageDescription)+import "Cabal" Distribution.Verbosity                (silent)+import qualified "Cabal" Distribution.ModuleName as ModuleName++import Data.List                             (isPrefixOf, isSuffixOf, sort)+import System.Environment                    (getArgs, getProgName)+import System.FilePath                       (takeExtension, takeFileName)+import System.Process                        (readProcess)++import qualified System.IO               as IO++main' :: FilePath -> IO ()+main' fp = do+    -- Read cabal file, so we can determine test modules+    contents <- strictReadFile fp+    cabal <- case parsePackageDescription contents of+        ParseOk _ x      -> pure x+        ParseFailed errs -> fail (show errs)++    -- We skip some files+    let testModuleFiles = getOtherModulesFiles cabal+    let skipPredicates' = skipPredicates ++ map (==) testModuleFiles++    -- Read all files git knows about under "tests" and "PackageTests" (cabal-testsuite)+    files0 <- lines <$> readProcess "git" ["ls-files", "tests", "PackageTests"] ""++    -- Filter+    let files1 = filter (\f -> takeExtension f `elem` whitelistedExtensionss ||+                               takeFileName f `elem` whitelistedFiles)+                        files0+    let files2 = filter (\f -> not $ any ($ dropTestsDir f) skipPredicates') files1+    let files3 = sort files2+    let files = files3++    -- Read current file+    let inputLines  = lines contents+        linesBefore = takeWhile (/= topLine) inputLines+        linesAfter  = dropWhile (/= bottomLine) inputLines++    -- Output+    let outputLines = linesBefore ++ [topLine] ++ map ("  " ++) files ++ linesAfter+    writeFile fp (unlines outputLines)+++topLine, bottomLine :: String+topLine = "  -- BEGIN gen-extra-source-files"+bottomLine = "  -- END gen-extra-source-files"++dropTestsDir :: FilePath -> FilePath+dropTestsDir fp+    | pfx `isPrefixOf` fp = drop (length pfx) fp+    | otherwise           = fp+  where+    pfx = "tests/"++whitelistedFiles :: [FilePath]+whitelistedFiles = [ "ghc", "ghc-pkg", "ghc-7.10", "ghc-pkg-7.10", "ghc-pkg-ghc-7.10" ]++whitelistedExtensionss :: [String]+whitelistedExtensionss = map ('.' : )+    [ "hs", "lhs", "c", "h", "sh", "cabal", "hsc", "err", "out", "in", "project" ]++getOtherModulesFiles :: GenericPackageDescription -> [FilePath]+getOtherModulesFiles gpd = mainModules ++ map fromModuleName otherModules'+  where+    testSuites        :: [TestSuite]+    testSuites        = map (foldMapCondTree id . snd) (condTestSuites gpd)++    mainModules       = concatMap (mainModule   . testInterface) testSuites+    otherModules'     = concatMap (otherModules . testBuildInfo) testSuites++    fromModuleName mn = ModuleName.toFilePath mn ++ ".hs"++    mainModule (TestSuiteLibV09 _ mn) = [fromModuleName mn]+    mainModule (TestSuiteExeV10 _ fp) = [fp]+    mainModule _                      = []++skipPredicates :: [FilePath -> Bool]+skipPredicates =+    [ isSuffixOf "register.sh"+    ]+  where+    -- eq = (==)++main :: IO ()+main = do+    args <- getArgs+    case args of+        [fp] -> main' fp+        _    -> do+            progName <- getProgName+            putStrLn "Error too few arguments!"+            putStrLn $ "Usage: " ++ progName ++ " FILE"+            putStrLn "  where FILE is Cabal.cabal, cabal-testsuite.cabal or cabal-install.cabal"++strictReadFile :: FilePath -> IO String+strictReadFile fp = do+    handle <- IO.openFile fp IO.ReadMode+    contents <- get handle+    IO.hClose handle+    return contents+  where+    get h = IO.hGetContents h >>= \s -> length s `seq` return s++foldMapCondTree :: Monoid m => (a -> m) -> CondTree v c a -> m+foldMapCondTree f (CondNode x _ cs)+    = mappend (f x)+    -- list, 3-tuple+maybe+    $ (foldMap . foldMapTriple . foldMapCondTree) f cs+  where+    foldMapTriple :: Monoid x => (b -> x) -> (a, b, Maybe b) -> x+    foldMapTriple f (_, x, y) = mappend (f x) (foldMap f y)
− cabal/Cabal/misc/gen-extra-source-files.sh 
@@ -1,22 +0,0 @@-#!/bin/sh--if [ "$#" -ne 1 ]; then-    echo "Error: too few arguments!"-    echo "Usage: $0 FILE"-    exit 1-fi--set -ex--find tests -type f \( -name '*.hs' -or -name '*.lhs' -or -name '*.c' -or -name '*.sh' \-    -or -name '*.cabal' -or -name '*.hsc' -or -name '*.err' -or -name '*.out' -or -name "ghc*" \) -and -not -regex ".*/dist.*/.*" \-    | awk '/Check.hs$|UnitTests|PackageTester|autogen|PackageTests.hs|IntegrationTests.hs|CreatePipe|^tests\/Test/ { next } { print }' \-    | LC_ALL=C sort \-    | sed -e 's/^/  /' \-    > source-file-list--lead='^  -- BEGIN gen-extra-source-files'-tail='^  -- END gen-extra-source-files'-# cribbed off of http://superuser.com/questions/440013/how-to-replace-part-of-a-text-file-between-markers-with-another-text-file-sed -i.bak -e "/$lead/,/$tail/{ /$lead/{p; r source-file-list-              }; /$tail/p; d }" $1
cabal/Cabal/misc/travis-diff-files.sh view
@@ -1,3 +1,3 @@ #!/bin/sh-git status > /dev/null # See https://github.com/haskell/cabal/pull/3088#commitcomment-15818452+git status > /dev/null # See 09a71929e433f36b27fd6a4938469d3bbbd5e191 git diff-files -p --exit-code
− cabal/HACKING.md 
@@ -1,159 +0,0 @@-Contributing to Cabal-=====================--If you want to hack on Cabal, don't be intimidated!--* Read the [guide to the source-  code](https://github.com/haskell/cabal/wiki/Source-Guide).--* Subscribe to the [mailing-  list](http://www.haskell.org/mailman/listinfo/cabal-devel).--* Browse the [list of open issues](https://github.com/haskell/cabal/issues).--* There are other resources listed on the [development-  wiki](https://github.com/haskell/cabal/wiki).--* See [Cabal/tests/README.md] for information about writing package tests.--Of particular value are the open issues list and the cabal-devel mailing-list, which is a good place to ask questions.--[Cabal/tests/README.md]: Cabal/tests/README.md--Setting up on a Unix-like system-----------------------------------The instructions below have been compiled into a Bash script which can-do the setup in a fully automated fashion. See the file `setup-dev.sh`-in the root directory of this Git repository.--Building Cabal from git cloned sources and running the tests---------------------------------------------------------------_The steps below will make use of sandboxes for building. The process might be-somewhat different when you do not want to use sandboxes._--Building Cabal from source requires the following:--* Glorious/Glasgow Haskell Compiler (ghc).-* An existing (relatively recent) `cabal` binary (e.g. obtained as part of the-Haskell Platform, bootstrapped from the-[source tarball on Hackage](http://hackage.haskell.org/package/cabal-install) or-installed from your Linux vendor).-* The sources. For example, you might want to--    ~~~~-    cd ~/MyHaskellCode-    git clone https://github.com/haskell/cabal.git-    cd cabal-    ~~~~--    to download the git repository to ~/MyHaskellCode/cabal.--To build and test the `Cabal` library, do:--1. Move to `Cabal` directory:--    ~~~~-    cd Cabal-    ~~~~--2. Create a sandbox, and fill it with the necessary dependencies:--    ~~~~-    cabal sandbox init-    cabal install --only-dependencies --enable-tests-    ~~~~--3. Unfortunately, because of way the bootstrapping works for cabal,-    we cannot use `cabal` for the next steps;-    we need to use Setup instead.-    So, compile Setup.hs:--    ~~~~-    ghc --make -threaded Setup.hs-    ~~~~--4. However, we _do_ want to use the sandbox package database that was created-    by cabal.-    We need its path later, so we have to find out where it is,-    for example with:--    ~~~~-    cabal exec -- sh -c "echo \$GHC_PACKAGE_PATH" | sed 's/:.*//'-    ~~~~--    the result should be something like--    ~~~~-    ~/MyHaskellCode/cabal/Cabal/.cabal-sandbox/$SOMESTUFF-packages.conf.d-    ~~~~--    (or, as a relative path with my setup:)--    ~~~~-    .cabal-sandbox/x86_64-linux-ghc-7.8.4-packages.conf.d-    ~~~~--    We will refer to this as `PACKAGEDB`.--5. Configure and build Cabal, and run all tests:--    ~~~~-    ./Setup configure --enable-tests --package-db=$PACKAGEDB-    ./Setup build-    ./Setup test-    ~~~~--The steps for building and testing the `cabal-install` executable are almost-identical; only the first two steps are different:--1. Move to the `cabal-install` directory:--    ~~~~-    cd cabal-install-    ~~~~--2. Create a sandbox, and fill it with the necessary dependencies.-    For this, we need to add the Cabal library from the repository as an-    add-source dependency:--    ~~~~-    cabal sandbox init-    cabal sandbox add-source ../Cabal/-    cabal install --only-dependencies --enable-tests-    ~~~~--(In addition, the absolute sandbox path will be slightly different-because we have to use the `cabal-install` sandbox, not the Cabal one. If you-use the relative path, you are set.)--Coding Conventions---------------------Use spaces, not tabs. Use lines no longer than 80 characters. If you modify a-file, please follow the style conventions used in that file. When you add a new-top-level definition, please also add a Haddock comment. Use explicit import-lists for third-party and standard library imports. Use of GHC extensions is-allowed (except Template Haskell), provided that the dependencies policy is-respected. In general, try to adhere to [this style guide][guide].--[guide]: https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md--Dependencies policy----------------------Cabal's policy is to support being built by versions of GHC that are up-to 3 years old.--The Cabal library must be buildable out-of-the-box, i.e., the-dependency versions required by Cabal must have shipped with GHC for-at least 3 years. Cabal may use newer libraries if they are available,-as long as there is a suitable fallback when only older versions-exist.--cabal-install must be buildable by versions of GHC that are up to 3-years old. It need not be buildable out-of-the-box, so cabal-install-may depend on newer versions of libraries if they can still be-compiled by 3-year-old versions of GHC.
cabal/LICENSE view
@@ -1,4 +1,5 @@-Copyright (c) 2011, Duncan Coutts and Ian Lynagh.+Copyright (c) 2003-2016, Cabal Development Team.+See the AUTHORS file for the full list of copyright holders.  See */LICENSE for the copyright holders of the subcomponents.
cabal/README.md view
@@ -1,12 +1,222 @@-# Cabal [![Hackage version](https://img.shields.io/hackage/v/Cabal.svg?label=Hackage)](https://hackage.haskell.org/package/Cabal) [![Build Status](https://secure.travis-ci.org/haskell/cabal.svg?branch=master)](http://travis-ci.org/haskell/cabal) [![Windows build status](https://ci.appveyor.com/api/projects/status/yotutrf4i4wn5d9y/branch/master?svg=true)](https://ci.appveyor.com/project/23Skidoo/cabal)+# Cabal [![Hackage version](https://img.shields.io/hackage/v/Cabal.svg?label=Hackage)](https://hackage.haskell.org/package/Cabal) [![Stackage version](https://www.stackage.org/package/Cabal/badge/lts?label=Stackage)](https://www.stackage.org/package/Cabal) [![Build Status](https://secure.travis-ci.org/haskell/cabal.svg?branch=master)](http://travis-ci.org/haskell/cabal) [![Windows build status](https://ci.appveyor.com/api/projects/status/yotutrf4i4wn5d9y/branch/master?svg=true)](https://ci.appveyor.com/project/23Skidoo/cabal) [![Documentation Status](http://readthedocs.org/projects/cabal/badge/?version=latest)](http://cabal.readthedocs.io/en/latest/?badge=latest)  This Cabal Git repository contains the following packages:   * [Cabal](Cabal/README.md): the Cabal library package ([license](Cabal/LICENSE))  * [cabal-install](cabal-install/README.md): the package containing the `cabal` tool ([license](cabal-install/LICENSE)) -See [HACKING.md](HACKING.md) for information about contributing and building-from git cloned sources.- The canonical upstream repository is located at https://github.com/haskell/cabal.++Installing Cabal+----------------++Assuming that you have a pre-existing, older version of `cabal-install`,+run:++~~~~+cabal install cabal-install+~~~~++To get the latest version of `cabal-install`. (You may want to `cabal+update` first.)++To install the latest version from the Git repository, clone the+Git repository and then run:++~~~~+(cd Cabal; cabal install)+(cd cabal-install; cabal install)+~~~~++Building Cabal for hacking+--------------------------++The current recommended way of developing Cabal is to use the+`new-build` feature which [shipped in cabal-install-1.24](http://blog.ezyang.com/2016/05/announcing-cabal-new-build-nix-style-local-builds/).  Assuming+that you have a sufficiently recent cabal-install (see above),+it is sufficient to run:++~~~~+cabal new-build cabal-install+~~~~++To build a local, development copy of cabal-install.  The binary+will be located at+`dist-newstyle/build/cabal-install-$VERSION/build/cabal/cabal`;+you can determine the `$VERSION` of cabal-install by looking at+[cabal-install/cabal-install.cabal](cabal-install/cabal-install.cabal).++Here are some other useful variations on the commands:++~~~~+cabal new-build Cabal # build library only+cabal new-build Cabal:package-tests # build Cabal's package test suite+cabal new-build cabal-install:integration-tests # etc...+~~~~++Running tests+-------------++**Using Travis and AppVeyor.**+The easiest way to run tests on Cabal is to make a branch on GitHub+and then open a pull request; our continuous integration service on+Travis and AppVeyor will build and test your code.  Title your PR+with WIP so we know that it does not need code review.  Alternately,+you can enable Travis on your fork in your own username and Travis+should build your local branches.++Some tips for using Travis effectively:++* Watch over your jobs on the [Travis website](http://travis-ci.org).+  If you know a build of yours is going to fail (because one job has+  already failed), be nice to others and cancel the rest of the jobs,+  so that other commits on the build queue can be processed.++* If you want realtime notification when builds of your PRs finish, we have a [Slack team](https://haskell-cabal.slack.com/). To get issued an invite, fill in your email at [this sign up page](https://haskell-cabal.herokuapp.com).++* If you enable Travis for the fork of Cabal in your local GitHub, you+  can have builds done automatically for your local branch seperate+  from Cabal. This is an alternative to opening a PR.++**Running tests locally.**+To run tests locally with `new-build`, you will need to know the+name of the test suite you want.  Cabal and cabal-install have+several.  In general, the test executable for+`{Cabal,cabal-install}:$TESTNAME` will be stored at+`dist-newstyle/build/{Cabal,cabal-install}-$VERSION/build/$TESTNAME/$TESTNAME`.++To run a single test, use `-p` which applies a regex filter to the test names.++* `Cabal:package-tests` are out-of-process integration tests on the top-level `Setup`+  command line interface.  If you are hacking on the Cabal library you+  want to run this test suite.  It must be run from the `Cabal` subdirectory+  (ugh!)  This test suite can be a bit touchy; see+  [Cabal/tests/README.md](Cabal/tests/README.md) for more information.+  Build products and test logs are generated and stored in+  `Cabal/tests/PackageTests` under folders named `dist-test` and+  `dist-test.$subname`.++  Handy command line spell to find test logs is:+  ```sh+  find . -name test.log|grep test-name+  ```++  `test.sh` in the same directory as `test.log` is intended to let you rerun+  the test without running the actual test driver.+++* `Cabal:unit-tests` are small, quick-running unit tests+  on small pieces of functionality in Cabal.  If you are working+  on some utility functions in the Cabal library you should run this+  test suite.++* `cabal-install:unit-tests` are small, quick-running unit tests on+  small pieces of functionality in cabal-install.  If you are working+  on some utility functions in cabal-install you should run this test+  suite.++* `cabal-install:solver-quickcheck` are QuickCheck tests on+  cabal-install's dependency solver.  If you are working+  on the solver you should run this test suite.++* `cabal-install:integration-tests` are out-of-process integration tests on the+  top-level `cabal` command line interface.  The coverage is not+  very good but it attempts to exercise most of cabal-install.++* `cabal-install:integration-tests2` are integration tests on some+  top-level API functions inside the `cabal-install` source code.+  You should also run this test suite.++Conventions+-----------++* Spaces, not tabs.++* Try to follow style conventions of a file you are modifying, and+  avoid gratuitous reformatting (it makes merges harder!)++* A lot of Cabal does not have top-level comments.  We are trying to+  fix this.  If you add new top-level definitions, please Haddock them;+  and if you spend some time understanding what a function does, help+  us out and add a comment.  We'll try to remind you during code review.++* If you do something tricky or non-obvious, add a comment.++* For local imports (Cabal module importing Cabal module), import lists+  are NOT required (although you may use them at your discretion.)  For+  third-party and standard library imports, please use explicit import+  lists.++* You can use basically any GHC extension supported by a GHC in our+  support window, except Template Haskell, which would cause+  bootstrapping problems in the GHC compilation process.++* Our GHC support window is five years for the Cabal library and three+  years for cabal-install: that is, the Cabal library must be+  buildable out-of-the-box with the dependencies that shipped with GHC+  for at least five years.  The Travis CI checks this, so most+  developers submit a PR to see if their code works on all these+  versions of GHC.  cabal-install must also be buildable on all+  supported GHCs, although it does not have to be buildable+  out-of-the-box. Instead, the `cabal-install/bootstrap.sh` script+  must be able to download and install all of the dependencies.  (This+  is also checked by CI!)++* `Cabal` has its own Prelude, in `Distribution.Compat.Prelude`,+  that provides a compatibility layer and exports some commonly+  used additional functions. Use it in all new modules.++* As far as possible, please do not use CPP. If you must use it,+  try to put it in a `Compat` module, and minimize the amount of code+  that is enclosed by CPP.  For example, prefer:+  ```+  f :: Int -> Int+  #ifdef mingw32_HOST_OS+  f = (+1)+  #else+  f = (+2)+  #endif+  ```++  over:+  ```+  #ifdef mingw32_HOST_OS+  f :: Int -> Int+  f = (+1)+  #else+  f :: Int -> Int+  f = (+2)+  #endif+  ```++We like [this style guide][guide].++[guide]: https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md++Communicating+-------------++There are a few main venues of communication:++* Most developers subscribe to receive messages from [all issues](https://github.com/haskell/cabal/issues); issues can be used to [open discussion](https://github.com/haskell/cabal/issues?q=is%3Aissue+is%3Aopen+custom+label%3A%22type%3A+discussion%22).  If you know someone who should hear about a message, CC them explicitly using the @username GitHub syntax.++* For more organizational concerns, the [mailing+  list](http://www.haskell.org/mailman/listinfo/cabal-devel) is used.++* Many developers idle on `#hackage` on `irc.freenode.net`.  `#ghc` is+  also a decently good bet.++Releases+--------++Notes for how to make a release are at the+wiki page ["Making a release"](https://github.com/haskell/cabal/wiki/Making-a-release).+Currently, @23Skidoo, @rthomas, @tibbe and @dcoutts have access to+`haskell.org/cabal`, and @davean is the point of contact for getting+permissions.++API Documentation+-----------------++Auto-generated API documentation for the `master` branch of Cabal is automatically uploaded here: http://haskell.github.io/cabal-website/doc/html/Cabal/.
cabal/appveyor.yml view
@@ -1,14 +1,16 @@ install:-  - choco install ghc -version 7.10.3 > NUL-  - SET PATH=%PATH%;C:\tools\ghc\ghc-7.10.3\bin-  - curl -o cabal.zip --silent https://www.haskell.org/cabal/release/cabal-install-1.24.0.0-rc1/cabal-install-1.24.0.0-rc1-x86_64-unknown-mingw32.zip+  # Using '-y' and 'refreshenv' as a workaround to:+  # https://github.com/haskell/cabal/issues/3687+  - choco install -y ghc --version 8.0.1 > NUL+  - refreshenv+  - curl -o cabal.zip --silent https://www.haskell.org/cabal/release/cabal-install-1.24.0.0/cabal-install-1.24.0.0-x86_64-unknown-mingw32.zip   - 7z x -bd cabal.zip   - cabal --version   - cabal update  build_script:   - cd Cabal-  - ghc --make -threaded -i -i. Setup.hs -Wall -Werror+  - ghc --make -threaded -i -i. Setup.hs -Wall -Werror -XRank2Types -XFlexibleContexts    # 'echo "" |' works around an AppVeyor issue:   # https://github.com/commercialhaskell/stack/issues/1097#issuecomment-145747849@@ -18,11 +20,21 @@   - Setup build   - Setup test --show-details=streaming --test-option=--hide-successes   - Setup install+  - cd ..\cabal-testsuite+  - echo "" | ..\cabal install --only-dependencies --enable-tests+  - ghc --make -threaded -i -i. Setup.hs -Wall -Werror+  - Setup configure --user --ghc-option=-Werror --enable-tests+  - Setup build+  - Setup test --show-details=streaming --test-option=--hide-successes   - cd ..\cabal-install   - ghc --make -threaded -i -i. Setup.hs -Wall -Werror   - echo "" | ..\cabal install happy   - echo "" | ..\cabal install --only-dependencies --enable-tests   - ..\cabal configure --user --ghc-option=-Werror --enable-tests   - ..\cabal build+  # update package index again, this time for the cabal under test+  - dist\build\cabal\cabal.exe update   - ..\cabal test unit-tests --show-details=streaming --test-option=--pattern=!FileMonitor --test-option=--hide-successes   - ..\cabal test integration-tests --show-details=streaming --test-option=--pattern=!exec --test-option=--hide-successes+  - ..\cabal test integration-tests2 --show-details=streaming --test-option=--hide-successes+  - ..\cabal test solver-quickcheck --show-details=streaming --test-option=--hide-successes --test-option=--quickcheck-tests=1000
cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs view
@@ -27,18 +27,18 @@   ) where  import qualified Distribution.Client.Types as BR-         ( BuildResult, BuildFailure(..), BuildSuccess(..)+         ( BuildOutcome, BuildFailure(..), BuildResult(..)          , DocsResult(..), TestsResult(..) ) import Distribution.Client.Utils          ( mergeBy, MergeResult(..) ) import qualified Paths_cabal_install (version)  import Distribution.Package-         ( PackageIdentifier(..), PackageName(..) )+         ( PackageIdentifier(..), mkPackageName ) import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )---import Distribution.Version---         ( Version )+         ( FlagName, mkFlagName, unFlagName, FlagAssignment )+import Distribution.Version+         ( mkVersion' ) import Distribution.System          ( OS, Arch ) import Distribution.Compiler@@ -120,7 +120,7 @@   deriving Eq  new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment-    -> [PackageIdentifier] -> BR.BuildResult -> BuildReport+    -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport new os' arch' comp pkgid flags deps result =   BuildReport {     package               = pkgid,@@ -145,21 +145,22 @@       Left  (BR.BuildFailed     _) -> BuildFailed       Left  (BR.TestsFailed     _) -> TestsFailed       Left  (BR.InstallFailed   _) -> InstallFailed-      Right (BR.BuildOk       _ _ _) -> InstallOk+      Right (BR.BuildResult _ _ _) -> InstallOk     convertDocsOutcome = case result of-      Left _                                -> NotTried-      Right (BR.BuildOk BR.DocsNotTried _ _)  -> NotTried-      Right (BR.BuildOk BR.DocsFailed _ _)    -> Failed-      Right (BR.BuildOk BR.DocsOk _ _)        -> Ok+      Left _                                      -> NotTried+      Right (BR.BuildResult BR.DocsNotTried _ _)  -> NotTried+      Right (BR.BuildResult BR.DocsFailed _ _)    -> Failed+      Right (BR.BuildResult BR.DocsOk _ _)        -> Ok     convertTestsOutcome = case result of-      Left  (BR.TestsFailed _)              -> Failed-      Left _                                -> NotTried-      Right (BR.BuildOk _ BR.TestsNotTried _) -> NotTried-      Right (BR.BuildOk _ BR.TestsOk _)       -> Ok+      Left  (BR.TestsFailed _)                    -> Failed+      Left _                                      -> NotTried+      Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried+      Right (BR.BuildResult _ BR.TestsOk _)       -> Ok  cabalInstallID :: PackageIdentifier cabalInstallID =-  PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version+  PackageIdentifier (mkPackageName "cabal-install")+                    (mkVersion' Paths_cabal_install.version)  -- ------------------------------------------------------------ -- * External format@@ -263,15 +264,15 @@ sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs  dispFlag :: (FlagName, Bool) -> Disp.Doc-dispFlag (FlagName name, True)  =                  Disp.text name-dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name+dispFlag (fname, True)  =                  Disp.text (unFlagName fname)+dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname)  parseFlag :: Parse.ReadP r (FlagName, Bool) parseFlag = do   name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')   case name of-    ('-':flag) -> return (FlagName flag, False)-    flag       -> return (FlagName flag, True)+    ('-':flag) -> return (mkFlagName flag, False)+    flag       -> return (mkFlagName flag, True)  instance Text.Text InstallOutcome where   disp PlanningFailed  = Disp.text "PlanningFailed"
cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs view
@@ -28,10 +28,12 @@  import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan-import qualified Distribution.Client.ComponentDeps as CD import Distribution.Client.InstallPlan          ( InstallPlan ) +import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.SourcePackage+ import Distribution.Package          ( PackageId, packageId ) import Distribution.PackageDescription@@ -121,38 +123,35 @@  fromInstallPlan :: Platform -> CompilerId                 -> InstallPlan+                -> BuildOutcomes                 -> [(BuildReport, Maybe Repo)]-fromInstallPlan platform comp plan =+fromInstallPlan platform comp plan buildOutcomes =      catMaybes-   . map (fromPlanPackage platform comp)+   . map (\pkg -> fromPlanPackage+                    platform comp pkg+                    (InstallPlan.lookupBuildOutcome pkg buildOutcomes))    . InstallPlan.toList    $ plan  fromPlanPackage :: Platform -> CompilerId                 -> InstallPlan.PlanPackage+                -> Maybe BuildOutcome                 -> Maybe (BuildReport, Maybe Repo)-fromPlanPackage (Platform arch os) comp planPackage = case planPackage of-  InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ deps))-                         _ result-    -> Just $ ( BuildReport.new os arch comp-                                (packageId srcPkg) flags-                                (map packageId (CD.nonSetupDeps deps))-                                (Right result)-              , extractRepo srcPkg)--  InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result-    -> Just $ ( BuildReport.new os arch comp-                                (packageId srcPkg) flags-                                (map confSrcId (CD.nonSetupDeps deps))-                                (Left result)-              , extractRepo srcPkg )--  _ -> Nothing-+fromPlanPackage (Platform arch os) comp+                (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))+                (Just buildResult) =+      Just ( BuildReport.new os arch comp+                             (packageId srcPkg) flags+                             (map packageId (CD.nonSetupDeps deps))+                             buildResult+           , extractRepo srcPkg)   where     extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ })                   = Just repo     extractRepo _ = Nothing++fromPlanPackage _ _ _ _ = Nothing+  fromPlanningFailure :: Platform -> CompilerId     -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
+ cabal/cabal-install/Distribution/Client/BuildTarget.hs view
@@ -0,0 +1,1670 @@+{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.BuildTargets+-- Copyright   :  (c) Duncan Coutts 2012, 2015+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified build targets+-- Unlike "Distribution.Simple.BuildTarget" these build+-- targets also handle package qualification (so, up to+-- four levels of qualification, as opposed to the former's+-- three.)+-----------------------------------------------------------------------------+module Distribution.Client.BuildTarget (++    -- * Build targets+    BuildTarget(..),+    -- Don't export me: it's partial (if you try to qualify too+    -- much you will error.)+    --showBuildTarget,+    QualLevel(..),+    buildTargetPackage,+    buildTargetComponentName,++    -- * Top level convenience+    readUserBuildTargets,+    resolveUserBuildTargets,++    -- * Parsing user build targets+    UserBuildTarget,+    parseUserBuildTargets,+    showUserBuildTarget,+    UserBuildTargetProblem(..),+    reportUserBuildTargetProblems,++    -- * Resolving build targets+    resolveBuildTargets,+    BuildTargetProblem(..),+    reportBuildTargetProblems,+  ) where++import Distribution.Package+         ( Package(..), PackageId, PackageName, packageName+         , unUnqualComponentName )+import Distribution.Client.Types+         ( PackageLocation(..) )++import Distribution.PackageDescription+         ( PackageDescription+         , Executable(..)+         , TestSuite(..), TestSuiteInterface(..), testModules+         , Benchmark(..), BenchmarkInterface(..), benchmarkModules+         , BuildInfo(..), explicitLibModules, exeModules )+import Distribution.ModuleName+         ( ModuleName, toFilePath )+import Distribution.Simple.LocalBuildInfo+         ( Component(..), ComponentName(..)+         , pkgComponents, componentName, componentBuildInfo )+import Distribution.Types.ForeignLib++import Distribution.Text+         ( display, simpleParse )+import Distribution.Simple.Utils+         ( die, lowercase )+import Distribution.Client.Utils+         ( makeRelativeToCwd )++import Data.Either+         ( partitionEithers )+import Data.Function+         ( on )+import Data.List+         ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy )+import Data.Maybe+         ( listToMaybe, maybeToList )+import Data.Ord+         ( comparing )+import GHC.Generics (Generic)+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Lazy   as Map.Lazy+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+#else+import qualified Data.Map as Map.Lazy+import qualified Data.Map as Map+import Data.Map (Map)+#endif+import qualified Data.Set as Set+import Control.Arrow ((&&&))+import Control.Monad+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..), (<$>))+#endif+import Control.Applicative (Alternative(..))+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( (+++), (<++) )+import Data.Char+         ( isSpace, isAlphaNum )+import System.FilePath as FilePath+         ( takeExtension, dropExtension, addTrailingPathSeparator+         , splitDirectories, joinPath, splitPath )+import System.Directory+         ( doesFileExist, doesDirectoryExist, canonicalizePath+         , getCurrentDirectory )+import System.FilePath+         ( (</>), (<.>), normalise )+import Text.EditDistance+         ( defaultEditCosts, restrictedDamerauLevenshteinDistance )++-- ------------------------------------------------------------+-- * User build targets+-- ------------------------------------------------------------++-- | Various ways that a user may specify a build target.+--+-- The main general form has lots of optional parts:+--+-- > [ package name | package dir | package .cabal file ]+-- > [ [lib:|exe:] component name ]+-- > [ module name | source file ]+--+-- There's also a special case of a package tarball. It doesn't take part in+-- the main general form since we always build a tarball package as a whole.+--+-- > [package tar.gz file]+--+data UserBuildTarget =++     -- | A simple target specified by a single part. This is any of the+     -- general forms that can be expressed using one part, which are:+     --+     -- > cabal build foo                      -- package name+     -- > cabal build ../bar ../bar/bar.cabal  -- package dir or package file+     -- > cabal build foo                      -- component name+     -- > cabal build Data.Foo                 -- module name+     -- > cabal build Data/Foo.hs bar/Main.hsc -- file name+     --+     -- It can also be a package tarball.+     --+     -- > cabal build bar.tar.gz+     --+     UserBuildTarget1 String++     -- | A qualified target with two parts. This is any of the general+     -- forms that can be expressed using two parts, which are:+     --+     -- > cabal build foo:foo              -- package : component+     -- > cabal build foo:Data.Foo         -- package : module+     -- > cabal build foo:Data/Foo.hs      -- package : filename+     --+     -- > cabal build ./foo:foo            -- package dir : component+     -- > cabal build ./foo:Data.Foo       -- package dir : module+     --+     -- > cabal build ./foo.cabal:foo      -- package file : component+     -- > cabal build ./foo.cabal:Data.Foo -- package file : module+     -- > cabal build ./foo.cabal:Main.hs  -- package file : filename+     --+     -- > cabal build lib:foo exe:foo      -- namespace : component+     -- > cabal build foo:Data.Foo         -- component : module+     -- > cabal build foo:Data/Foo.hs      -- component : filename+     --+   | UserBuildTarget2 String String++     -- A (very) qualified target with three parts. This is any of the general+     -- forms that can be expressed using three parts, which are:+     --+     -- > cabal build foo:lib:foo          -- package : namespace : component+     -- > cabal build foo:foo:Data.Foo     -- package : component : module+     -- > cabal build foo:foo:Data/Foo.hs  -- package : component : filename+     --+     -- > cabal build foo/:lib:foo         -- pkg dir : namespace : component+     -- > cabal build foo/:foo:Data.Foo    -- pkg dir : component : module+     -- > cabal build foo/:foo:Data/Foo.hs -- pkg dir : component : filename+     --+     -- > cabal build foo.cabal:lib:foo         -- pkg file : namespace : component+     -- > cabal build foo.cabal:foo:Data.Foo    -- pkg file : component : module+     -- > cabal build foo.cabal:foo:Data/Foo.hs -- pkg file : component : filename+     --+     -- > cabal build lib:foo:Data.Foo     -- namespace : component : module+     -- > cabal build lib:foo:Data/Foo.hs  -- namespace : component : filename+     --+   | UserBuildTarget3 String String String++     -- A (rediculously) qualified target with four parts. This is any of the+     -- general forms that can be expressed using all four parts, which are:+     --+     -- > cabal build foo:lib:foo:Data.Foo     -- package : namespace : component : module+     -- > cabal build foo:lib:foo:Data/Foo.hs  -- package : namespace : component : filename+     --+     -- > cabal build foo/:lib:foo:Data.Foo    -- pkg dir : namespace : component : module+     -- > cabal build foo/:lib:foo:Data/Foo.hs -- pkg dir : namespace : component : filename+     --+     -- > cabal build foo.cabal:lib:foo:Data.Foo    -- pkg file : namespace : component : module+     -- > cabal build foo.cabal:lib:foo:Data/Foo.hs -- pkg file : namespace : component : filename+     --+   | UserBuildTarget4 String String String String+  deriving (Show, Eq, Ord)+++-- ------------------------------------------------------------+-- * Resolved build targets+-- ------------------------------------------------------------++-- | A fully resolved build target.+--+data BuildTarget pkg =++     -- | A package as a whole+     --+     BuildTargetPackage pkg++     -- | A specific component+     --+   | BuildTargetComponent pkg ComponentName++     -- | A specific module within a specific component.+     --+   | BuildTargetModule pkg ComponentName ModuleName++     -- | A specific file within a specific component.+     --+   | BuildTargetFile pkg ComponentName FilePath+  deriving (Eq, Ord, Functor, Show, Generic)+++-- | Get the package that the 'BuildTarget' is referring to.+--+buildTargetPackage :: BuildTarget pkg -> pkg+buildTargetPackage (BuildTargetPackage   p)         = p+buildTargetPackage (BuildTargetComponent p _cn)     = p+buildTargetPackage (BuildTargetModule    p _cn _mn) = p+buildTargetPackage (BuildTargetFile      p _cn _fn) = p+++-- | Get the 'ComponentName' that the 'BuildTarget' is referring to, if any.+-- The 'BuildTargetPackage' target kind doesn't refer to any individual+-- component, while the component, module and file kinds do.+--+buildTargetComponentName :: BuildTarget pkg -> Maybe ComponentName+buildTargetComponentName (BuildTargetPackage   _p)        = Nothing+buildTargetComponentName (BuildTargetComponent _p cn)     = Just cn+buildTargetComponentName (BuildTargetModule    _p cn _mn) = Just cn+buildTargetComponentName (BuildTargetFile      _p cn _fn) = Just cn+++-- ------------------------------------------------------------+-- * Top level, do everything+-- ------------------------------------------------------------+++-- | Parse a bunch of command line args as user build targets, failing with an+-- error if any targets are unrecognised.+--+readUserBuildTargets :: [String] -> IO [UserBuildTarget]+readUserBuildTargets targetStrs = do+    let (uproblems, utargets) = parseUserBuildTargets targetStrs+    reportUserBuildTargetProblems uproblems+    return utargets+++-- | A 'UserBuildTarget's is just a semi-structured string. We sill have quite+-- a bit of work to do to figure out which targets they refer to (ie packages,+-- components, file locations etc).+--+-- The possible targets are based on the available packages (and their+-- locations). It fails with an error if any user string cannot be matched to+-- a valid target.+--+resolveUserBuildTargets :: [(PackageDescription, PackageLocation a)]+                        -> [UserBuildTarget] -> IO [BuildTarget PackageName]+resolveUserBuildTargets pkgs utargets = do+    utargets' <- mapM getUserTargetFileStatus utargets+    pkgs'     <- mapM (uncurry selectPackageInfo) pkgs+    pwd       <- getCurrentDirectory+    let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'+        (bproblems,  btargets)  = resolveBuildTargets+                                    primaryPkg otherPkgs utargets''+        utargets''+        -- default local dir target if there's no given target+          | not (null primaryPkg)+          , null utargets       = [UserBuildTargetFileStatus1 "./"+                                     (FileStatusExistsDir pwd)]+          | otherwise           = utargets'+        -- if there's nothing to build, build everything+        btargets' | null utargets+                  , null primaryPkg+                  = [ BuildTargetPackage pkg+                    | pkg <- otherPkgs ]+                  | otherwise+                  = btargets++    reportBuildTargetProblems bproblems+    return (map (fmap packageName) btargets')+  where+    selectPrimaryLocalPackage :: FilePath+                              -> [PackageInfo]+                              -> ([PackageInfo], [PackageInfo])+    selectPrimaryLocalPackage pwd pkgs' =+        let (primary, others) = partition isPrimary pkgs'+         in (primary, others)+      where+        isPrimary PackageInfo { pinfoDirectory = Just (dir,_) }+          | dir == pwd = True+        isPrimary _    = False+++-- ------------------------------------------------------------+-- * Checking if targets exist as files+-- ------------------------------------------------------------++data UserBuildTargetFileStatus =+     UserBuildTargetFileStatus1 String FileStatus+   | UserBuildTargetFileStatus2 String FileStatus String+   | UserBuildTargetFileStatus3 String FileStatus String String+   | UserBuildTargetFileStatus4 String FileStatus String String String+  deriving (Eq, Ord, Show)++data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath+                | FileStatusExistsDir  FilePath -- the canonicalised filepath+                | FileStatusNotExists  Bool -- does the parent dir exist even?+  deriving (Eq, Ord, Show)++getUserTargetFileStatus :: UserBuildTarget -> IO UserBuildTargetFileStatus+getUserTargetFileStatus t =+    case t of+      UserBuildTarget1 s1 ->+        (\f1 -> UserBuildTargetFileStatus1 s1 f1)          <$> fileStatus s1+      UserBuildTarget2 s1 s2 ->+        (\f1 -> UserBuildTargetFileStatus2 s1 f1 s2)       <$> fileStatus s1+      UserBuildTarget3 s1 s2 s3 ->+        (\f1 -> UserBuildTargetFileStatus3 s1 f1 s2 s3)    <$> fileStatus s1+      UserBuildTarget4 s1 s2 s3 s4 ->+        (\f1 -> UserBuildTargetFileStatus4 s1 f1 s2 s3 s4) <$> fileStatus s1+  where+    fileStatus f = do+      fexists <- doesFileExist f+      dexists <- doesDirectoryExist f+      case splitPath f of+        _ | fexists -> FileStatusExistsFile <$> canonicalizePath f+          | dexists -> FileStatusExistsDir  <$> canonicalizePath f+        (d:_)       -> FileStatusNotExists  <$> doesDirectoryExist d+        _           -> error "getUserTargetFileStatus: empty path"++forgetFileStatus :: UserBuildTargetFileStatus -> UserBuildTarget+forgetFileStatus t = case t of+    UserBuildTargetFileStatus1 s1 _          -> UserBuildTarget1 s1+    UserBuildTargetFileStatus2 s1 _ s2       -> UserBuildTarget2 s1 s2+    UserBuildTargetFileStatus3 s1 _ s2 s3    -> UserBuildTarget3 s1 s2 s3+    UserBuildTargetFileStatus4 s1 _ s2 s3 s4 -> UserBuildTarget4 s1 s2 s3 s4+++-- ------------------------------------------------------------+-- * Parsing user targets+-- ------------------------------------------------------------+++-- | Parse a bunch of 'UserBuildTarget's (purely without throwing exceptions).+--+parseUserBuildTargets :: [String] -> ([UserBuildTargetProblem]+                                     ,[UserBuildTarget])+parseUserBuildTargets = partitionEithers . map parseUserBuildTarget++parseUserBuildTarget :: String -> Either UserBuildTargetProblem+                                         UserBuildTarget+parseUserBuildTarget targetstr =+    case readPToMaybe parseTargetApprox targetstr of+      Nothing  -> Left  (UserBuildTargetUnrecognised targetstr)+      Just tgt -> Right tgt++  where+    parseTargetApprox :: Parse.ReadP r UserBuildTarget+    parseTargetApprox =+          (do a <- tokenQ+              return (UserBuildTarget1 a))+      +++ (do a <- tokenQ+              _ <- Parse.char ':'+              b <- tokenQ+              return (UserBuildTarget2 a b))+      +++ (do a <- tokenQ+              _ <- Parse.char ':'+              b <- tokenQ+              _ <- Parse.char ':'+              c <- tokenQ+              return (UserBuildTarget3 a b c))+      +++ (do a <- tokenQ+              _ <- Parse.char ':'+              b <- token+              _ <- Parse.char ':'+              c <- tokenQ+              _ <- Parse.char ':'+              d <- tokenQ+              return (UserBuildTarget4 a b c d))++    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')+    tokenQ = parseHaskellString <++ token+    parseHaskellString :: Parse.ReadP r String+    parseHaskellString = Parse.readS_to_P reads++    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                         , all isSpace s ]++-- | Syntax error when trying to parse a 'UserBuildTarget'.+data UserBuildTargetProblem+   = UserBuildTargetUnrecognised String+  deriving Show++-- | Throw an exception with a formatted message if there are any problems.+--+reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()+reportUserBuildTargetProblems problems = do+    case [ target | UserBuildTargetUnrecognised target <- problems ] of+      []     -> return ()+      target ->+        die $ unlines+                [ "Unrecognised build target syntax for '" ++ name ++ "'."+                | name <- target ]+           ++ "Syntax:\n"+           ++ " - build [package]\n"+           ++ " - build [package:]component\n"+           ++ " - build [package:][component:]module\n"+           ++ " - build [package:][component:]file\n"+           ++ " where\n"+           ++ "  package is a package name, package dir or .cabal file\n\n"+           ++ "Examples:\n"+           ++ " - build foo            -- package name\n"+           ++ " - build tests          -- component name\n"+           ++ "    (name of library, executable, test-suite or benchmark)\n"+           ++ " - build Data.Foo       -- module name\n"+           ++ " - build Data/Foo.hsc   -- file name\n\n"+           ++ "An ambigious target can be qualified by package, component\n"+           ++ "and/or component kind (lib|exe|test|bench)\n"+           ++ " - build foo:tests      -- component qualified by package\n"+           ++ " - build tests:Data.Foo -- module qualified by component\n"+           ++ " - build lib:foo        -- component qualified by kind"+++-- | Render a 'UserBuildTarget' back as the external syntax. This is mainly for+-- error messages.+--+showUserBuildTarget :: UserBuildTarget -> String+showUserBuildTarget = intercalate ":" . components+  where+    components (UserBuildTarget1 s1)          = [s1]+    components (UserBuildTarget2 s1 s2)       = [s1,s2]+    components (UserBuildTarget3 s1 s2 s3)    = [s1,s2,s3]+    components (UserBuildTarget4 s1 s2 s3 s4) = [s1,s2,s3,s4]++showBuildTarget :: QualLevel -> BuildTarget PackageInfo -> String+showBuildTarget ql = showUserBuildTarget . forgetFileStatus+                   . hd . renderBuildTarget ql+  where hd [] = error "showBuildTarget: head"+        hd (x:_) = x+++-- ------------------------------------------------------------+-- * Resolving user targets to build targets+-- ------------------------------------------------------------+++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to.+--+resolveBuildTargets :: [PackageInfo]     -- any primary pkg, e.g. cur dir+                    -> [PackageInfo]     -- all the other local packages+                    -> [UserBuildTargetFileStatus]+                    -> ([BuildTargetProblem], [BuildTarget PackageInfo])+resolveBuildTargets ppinfo opinfo =+    partitionEithers+  . map (resolveBuildTarget ppinfo opinfo)++resolveBuildTarget :: [PackageInfo] -> [PackageInfo]+                   -> UserBuildTargetFileStatus+                   -> Either BuildTargetProblem (BuildTarget PackageInfo)+resolveBuildTarget ppinfo opinfo userTarget =+    case findMatch (matcher userTarget) of+      Unambiguous          target  -> Right target+      None                 errs    -> Left (classifyMatchErrors errs)+      Ambiguous exactMatch targets ->+        case disambiguateBuildTargets+               matcher userTarget exactMatch+               targets of+          Right targets'   -> Left (BuildTargetAmbiguous  userTarget' targets')+          Left ((m, ms):_) -> Left (MatchingInternalError userTarget' m ms)+          Left []          -> internalError "resolveBuildTarget"+  where+    matcher = matchBuildTarget ppinfo opinfo++    userTarget' = forgetFileStatus userTarget++    classifyMatchErrors errs+      | not (null expected)+      = let (things, got:_) = unzip expected in+        BuildTargetExpected userTarget' things got++      | not (null nosuch)+      = BuildTargetNoSuch userTarget' nosuch++      | otherwise+      = internalError $ "classifyMatchErrors: " ++ show errs+      where+        expected = [ (thing, got)+                   | (_, MatchErrorExpected thing got)+                           <- map (innerErr Nothing) errs ]+        -- Trim the list of alternatives by dropping duplicates and+        -- retaining only at most three most similar (by edit distance) ones.+        nosuch   = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $+          [ ((inside, thing, got), Set.fromList alts)+          | (inside, MatchErrorNoSuch thing got alts)+            <- map (innerErr Nothing) errs+          ]++        genResults (inside, thing, got) alts acc = (+            inside+          , thing+          , got+          , take maxResults+            $ map fst+            $ takeWhile distanceLow+            $ sortBy (comparing snd)+            $ map addLevDist+            $ Set.toList alts+          ) : acc+          where+            addLevDist = id &&& restrictedDamerauLevenshteinDistance+                                defaultEditCosts got++            distanceLow (_, dist) = dist < length got `div` 2++            maxResults = 3++        innerErr _ (MatchErrorIn kind thing m)+                     = innerErr (Just (kind,thing)) m+        innerErr c m = (c,m)++-- | The various ways that trying to resolve a 'UserBuildTarget' to a+-- 'BuildTarget' can fail.+--+data BuildTargetProblem+   = BuildTargetExpected   UserBuildTarget [String]  String+     -- ^  [expected thing] (actually got)+   | BuildTargetNoSuch     UserBuildTarget+                           [(Maybe (String, String), String, String, [String])]+     -- ^ [([in thing], no such thing,  actually got, alternatives)]+   | BuildTargetAmbiguous  UserBuildTarget+                           [(UserBuildTarget, BuildTarget PackageInfo)]++   | MatchingInternalError UserBuildTarget (BuildTarget PackageInfo)+                           [(UserBuildTarget, [BuildTarget PackageInfo])]+++disambiguateBuildTargets+  :: (UserBuildTargetFileStatus -> Match (BuildTarget PackageInfo))+  -> UserBuildTargetFileStatus -> Bool+  -> [BuildTarget PackageInfo]+  -> Either [(BuildTarget PackageInfo,+              [(UserBuildTarget, [BuildTarget PackageInfo])])]+            [(UserBuildTarget, BuildTarget PackageInfo)]+disambiguateBuildTargets matcher matchInput exactMatch matchResults =+    case partitionEithers results of+      (errs@(_:_), _) -> Left errs+      ([], ok)        -> Right ok+  where+    -- So, here's the strategy. We take the original match results, and make a+    -- table of all their renderings at all qualification levels.+    -- Note there can be multiple renderings at each qualification level.+    matchResultsRenderings :: [(BuildTarget PackageInfo,+                                [UserBuildTargetFileStatus])]+    matchResultsRenderings =+      [ (matchResult, matchRenderings)+      | matchResult <- matchResults+      , let matchRenderings =+              [ rendering+              | ql <- [QL1 .. QL4]+              , rendering <- renderBuildTarget ql matchResult ]+      ]++    -- Of course the point is that we're looking for renderings that are+    -- unambiguous matches. So we build another memo table of all the matches+    -- for all of those renderings. So by looking up in this table we can see+    -- if we've got an unambiguous match.++    memoisedMatches :: Map UserBuildTargetFileStatus+                           (Match (BuildTarget PackageInfo))+    memoisedMatches =+        -- avoid recomputing the main one if it was an exact match+        (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults)+                       else id)+      $ Map.Lazy.fromList+          [ (rendering, matcher rendering)+          | rendering <- concatMap snd matchResultsRenderings ]++    -- Finally, for each of the match results, we go through all their+    -- possible renderings (in order of qualification level, though remember+    -- there can be multiple renderings per level), and find the first one+    -- that has an unambiguous match.+    results :: [Either (BuildTarget PackageInfo,+                        [(UserBuildTarget, [BuildTarget PackageInfo])])+                       (UserBuildTarget, BuildTarget PackageInfo)]+    results =+      [ case findUnambiguous originalMatch matchRenderings of+          Just unambiguousRendering ->+            Right ( forgetFileStatus unambiguousRendering+                  , originalMatch)++          -- This case is an internal error, but we bubble it up and report it+          Nothing ->+            Left  ( originalMatch+                  , [ (forgetFileStatus rendering, matches)+                    | rendering <- matchRenderings+                    , let (ExactMatch _ matches) =+                            memoisedMatches Map.! rendering+                    ] )++      | (originalMatch, matchRenderings) <- matchResultsRenderings ]++    findUnambiguous :: BuildTarget PackageInfo -> [UserBuildTargetFileStatus]+                    -> Maybe UserBuildTargetFileStatus+    findUnambiguous _ []     = Nothing+    findUnambiguous t (r:rs) =+      case memoisedMatches Map.! r of+        ExactMatch _ [t'] | fmap packageName t == fmap packageName t'+                         -> Just r+        ExactMatch _  _  -> findUnambiguous t rs+        InexactMatch _ _ -> internalError "InexactMatch"+        NoMatch      _ _ -> internalError "NoMatch"++internalError :: String -> a+internalError msg =+  error $ "BuildTargets: internal error: " ++ msg+++data QualLevel = QL1 | QL2 | QL3 | QL4+  deriving (Enum, Show)++renderBuildTarget :: QualLevel -> BuildTarget PackageInfo+                  -> [UserBuildTargetFileStatus]+renderBuildTarget ql t =+    case t of+      BuildTargetPackage p ->+        case ql of+          QL1 -> [t1 (dispP p)]+          QL2 -> [t1' pf fs | (pf, fs) <- dispPF p]+          QL3 -> []+          QL4 -> []++      BuildTargetComponent p c ->+        case ql of+          QL1 -> [t1                     (dispC p c)]+          QL2 -> [t2 (dispP p)           (dispC p c),+                  t2           (dispK c) (dispC p c)]+          QL3 -> [t3 (dispP p) (dispK c) (dispC p c)]+          QL4 -> []++      BuildTargetModule p c m ->+        case ql of+          QL1 -> [t1                                 (dispM m)]+          QL2 -> [t2 (dispP p)                       (dispM m),+                  t2                     (dispC p c) (dispM m)]+          QL3 -> [t3 (dispP p)           (dispC p c) (dispM m),+                  t3           (dispK c) (dispC p c) (dispM m)]+          QL4 -> [t4 (dispP p) (dispK c) (dispC p c) (dispM m)]++      BuildTargetFile p c f ->+        case ql of+          QL1 -> [t1                                 f]+          QL2 -> [t2 (dispP p)                       f,+                  t2                     (dispC p c) f]+          QL3 -> [t3 (dispP p)           (dispC p c) f,+                  t3           (dispK c) (dispC p c) f]+          QL4 -> [t4 (dispP p) (dispK c) (dispC p c) f]+  where+    t1  s1 = UserBuildTargetFileStatus1 s1 none+    t1' s1 = UserBuildTargetFileStatus1 s1+    t2  s1 = UserBuildTargetFileStatus2 s1 none+    t3  s1 = UserBuildTargetFileStatus3 s1 none+    t4  s1 = UserBuildTargetFileStatus4 s1 none+    none   = FileStatusNotExists False++    dispP = display . packageName+    dispC = componentStringName+    dispK = showComponentKindShort . componentKind+    dispM = display++    dispPF p = [ (addTrailingPathSeparator drel, FileStatusExistsDir dabs)+               | PackageInfo { pinfoDirectory   = Just (dabs,drel) } <- [p] ]+            ++ [ (frel, FileStatusExistsFile fabs)+               | PackageInfo { pinfoPackageFile = Just (fabs,frel) } <- [p] ]+++-- | Throw an exception with a formatted message if there are any problems.+--+reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()+reportBuildTargetProblems problems = do++    case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of+      [] -> return ()+      ((target, originalMatch, renderingsAndMatches):_) ->+        die $ "Internal error in build target matching. It should always be "+           ++ "possible to find a syntax that's sufficiently qualified to "+           ++ "give an unambigious match. However when matching '"+           ++ showUserBuildTarget target ++ "'  we found "+           ++ showBuildTarget QL1 originalMatch+           ++ " (" ++ showBuildTargetKind originalMatch ++ ") which does not "+           ++ "have an unambigious syntax. The possible syntax and the "+           ++ "targets they match are as follows:\n"+           ++ unlines+                [ "'" ++ showUserBuildTarget rendering ++ "' which matches "+                  ++ intercalate ", "+                       [ showBuildTarget QL1 match +++                         " (" ++ showBuildTargetKind match ++ ")"+                       | match <- matches ]+                | (rendering, matches) <- renderingsAndMatches ]++    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Unrecognised build target '" ++ showUserBuildTarget target+            ++ "'.\n"+            ++ "Expected a " ++ intercalate " or " expected+            ++ ", rather than '" ++ got ++ "'."+          | (target, expected, got) <- targets ]++    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [ "Unknown build target '" ++ showUserBuildTarget target +++            "'.\n" ++ unlines+            [    (case inside of+                    Just (kind, thing)+                            -> "The " ++ kind ++ " " ++ thing ++ " has no "+                    Nothing -> "There is no ")+              ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"+                                    | (thing, got, _alts) <- nosuch' ] ++ "."+              ++ if null alternatives then "" else+                 "\nPerhaps you meant " ++ intercalate ";\nor "+                 [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?"+                 | (thing, alts) <- alternatives ]+            | (inside, nosuch') <- groupByContainer nosuch+            , let alternatives =+                    [ (thing, alts)+                    | (thing,_got,alts@(_:_)) <- nosuch' ]+            ]+          | (target, nosuch) <- targets+          , let groupByContainer =+                    map (\g@((inside,_,_,_):_) ->+                            (inside, [   (thing,got,alts)+                                     | (_,thing,got,alts) <- g ]))+                  . groupBy ((==)    `on` (\(x,_,_,_) -> x))+                  . sortBy  (compare `on` (\(x,_,_,_) -> x))+          ]+        where+          mungeThing "file" = "file target"+          mungeThing thing  = thing++    case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Ambiguous build target '" ++ showUserBuildTarget target+            ++ "'. It could be:\n "+            ++ unlines [ "   "++ showUserBuildTarget ut +++                         " (" ++ showBuildTargetKind bt ++ ")"+                       | (ut, bt) <- amb ]+          | (target, amb) <- targets ]++  where+    showBuildTargetKind (BuildTargetPackage   _    ) = "package"+    showBuildTargetKind (BuildTargetComponent _ _  ) = "component"+    showBuildTargetKind (BuildTargetModule    _ _ _) = "module"+    showBuildTargetKind (BuildTargetFile      _ _ _) = "file"+++----------------------------------+-- Top level BuildTarget matcher+--++matchBuildTarget :: [PackageInfo] -> [PackageInfo]+                 -> UserBuildTargetFileStatus+                 -> Match (BuildTarget PackageInfo)+matchBuildTarget ppinfo opinfo = \utarget ->+    nubMatchesBy ((==) `on` (fmap packageName)) $+    case utarget of+      UserBuildTargetFileStatus1 str1 fstatus1 ->+        matchBuildTarget1 ppinfo opinfo str1 fstatus1++      UserBuildTargetFileStatus2 str1 fstatus1 str2 ->+        matchBuildTarget2 pinfo str1 fstatus1 str2++      UserBuildTargetFileStatus3 str1 fstatus1 str2 str3 ->+        matchBuildTarget3 pinfo str1 fstatus1 str2 str3++      UserBuildTargetFileStatus4 str1 fstatus1 str2 str3 str4 ->+        matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4+  where+    pinfo  = ppinfo ++ opinfo+    --TODO: sort this out+++matchBuildTarget1 :: [PackageInfo] -> [PackageInfo]+                  -> String -> FileStatus -> Match (BuildTarget PackageInfo)+matchBuildTarget1 ppinfo opinfo = \str1 fstatus1 ->+         match1Cmp pcinfo str1+    <//> match1Pkg pinfo  str1 fstatus1+    <//> match1Cmp ocinfo str1+    <//> match1Mod cinfo  str1+    <//> match1Fil pinfo  str1 fstatus1+  where+    pinfo  = ppinfo ++ opinfo+    cinfo  = concatMap pinfoComponents pinfo+    pcinfo = concatMap pinfoComponents ppinfo+    ocinfo = concatMap pinfoComponents opinfo+++matchBuildTarget2 :: [PackageInfo] -> String -> FileStatus -> String+                  -> Match (BuildTarget PackageInfo)+matchBuildTarget2 pinfo str1 fstatus1 str2 =+        match2PkgCmp pinfo str1 fstatus1 str2+   <|>  match2KndCmp cinfo str1          str2+   <//> match2PkgMod pinfo str1 fstatus1 str2+   <//> match2CmpMod cinfo str1          str2+   <//> match2PkgFil pinfo str1 fstatus1 str2+   <//> match2CmpFil cinfo str1          str2+  where+    cinfo = concatMap pinfoComponents pinfo+    --TODO: perhaps we actually do want to prioritise local/primary components+++matchBuildTarget3 :: [PackageInfo] -> String -> FileStatus -> String -> String+                  -> Match (BuildTarget PackageInfo)+matchBuildTarget3 pinfo str1 fstatus1 str2 str3 =+        match3PkgKndCmp pinfo str1 fstatus1 str2 str3+   <//> match3PkgCmpMod pinfo str1 fstatus1 str2 str3+   <//> match3PkgCmpFil pinfo str1 fstatus1 str2 str3+   <//> match3KndCmpMod cinfo str1          str2 str3+   <//> match3KndCmpFil cinfo str1          str2 str3+  where+    cinfo = concatMap pinfoComponents pinfo+++matchBuildTarget4 :: [PackageInfo]+                  -> String -> FileStatus -> String -> String -> String+                  -> Match (BuildTarget PackageInfo)+matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 =+        match4PkgKndCmpMod pinfo str1 fstatus1 str2 str3 str4+   <//> match4PkgKndCmpFil pinfo str1 fstatus1 str2 str3 str4+++------------------------------------+-- Individual BuildTarget matchers+--++match1Pkg :: [PackageInfo] -> String -> FileStatus+          -> Match (BuildTarget PackageInfo)+match1Pkg pinfo = \str1 fstatus1 -> do+    guardPackage            str1 fstatus1+    p <- matchPackage pinfo str1 fstatus1+    return (BuildTargetPackage p)++match1Cmp :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo)+match1Cmp cs = \str1 -> do+    guardComponentName str1+    c <- matchComponentName cs str1+    return (BuildTargetComponent (cinfoPackage c) (cinfoName c))++match1Mod :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo)+match1Mod cs = \str1 -> do+    guardModuleName str1+    let ms = [ (m,c) | c <- cs, m <- cinfoModules c ]+    (m,c) <- matchModuleNameAnd ms str1+    return (BuildTargetModule (cinfoPackage c) (cinfoName c) m)++match1Fil :: [PackageInfo] -> String -> FileStatus+          -> Match (BuildTarget PackageInfo)+match1Fil ps str1 fstatus1 =+    expecting "file" str1 $ do+    (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile+      return (BuildTargetFile p (cinfoName c) filepath)++---++match2PkgCmp :: [PackageInfo]+             -> String -> FileStatus -> String+             -> Match (BuildTarget PackageInfo)+match2PkgCmp ps = \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    guardComponentName   str2+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentName (pinfoComponents p) str2+      return (BuildTargetComponent p (cinfoName c))+    --TODO: the error here ought to say there's no component by that name in+    -- this package, and name the package++match2KndCmp :: [ComponentInfo] -> String -> String+             -> Match (BuildTarget PackageInfo)+match2KndCmp cs = \str1 str2 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    return (BuildTargetComponent (cinfoPackage c) (cinfoName c))++match2PkgMod :: [PackageInfo] -> String -> FileStatus -> String+             -> Match (BuildTarget PackageInfo)+match2PkgMod ps = \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    guardModuleName      str2+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ]+      (m,c) <- matchModuleNameAnd ms str2+      return (BuildTargetModule p (cinfoName c) m)++match2CmpMod :: [ComponentInfo] -> String -> String+             -> Match (BuildTarget PackageInfo)+match2CmpMod cs = \str1 str2 -> do+    guardComponentName str1+    guardModuleName    str2+    c <- matchComponentName cs str1+    orNoThingIn "component" (cinfoStrName c) $ do+      let ms = cinfoModules c+      m <- matchModuleName ms str2+      return (BuildTargetModule (cinfoPackage c) (cinfoName c) m)++match2PkgFil :: [PackageInfo] -> String -> FileStatus -> String+             -> Match (BuildTarget PackageInfo)+match2PkgFil ps str1 fstatus1 str2 = do+    guardPackage         str1 fstatus1+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      (filepath, c) <- matchComponentFile (pinfoComponents p) str2+      return (BuildTargetFile p (cinfoName c) filepath)++match2CmpFil :: [ComponentInfo] -> String -> String+             -> Match (BuildTarget PackageInfo)+match2CmpFil cs str1 str2 = do+    guardComponentName str1+    c <- matchComponentName cs str1+    orNoThingIn "component" (cinfoStrName c) $ do+      (filepath, _) <- matchComponentFile [c] str2+      return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath)++---++match3PkgKndCmp :: [PackageInfo]+                -> String -> FileStatus -> String -> String+                -> Match (BuildTarget PackageInfo)+match3PkgKndCmp ps = \str1 fstatus1 str2 str3 -> do+    guardPackage         str1 fstatus1+    ckind <- matchComponentKind str2+    guardComponentName   str3+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentKindAndName (pinfoComponents p) ckind str3+      return (BuildTargetComponent p (cinfoName c))++match3PkgCmpMod :: [PackageInfo]+                -> String -> FileStatus -> String -> String+                -> Match (BuildTarget PackageInfo)+match3PkgCmpMod ps = \str1 fstatus1 str2 str3 -> do+    guardPackage str1 fstatus1+    guardComponentName str2+    guardModuleName    str3+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentName (pinfoComponents p) str2+      orNoThingIn "component" (cinfoStrName c) $ do+        let ms = cinfoModules c+        m <- matchModuleName ms str3+        return (BuildTargetModule p (cinfoName c) m)++match3KndCmpMod :: [ComponentInfo]+                -> String -> String -> String+                -> Match (BuildTarget PackageInfo)+match3KndCmpMod cs = \str1 str2 str3 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    guardModuleName    str3+    c <- matchComponentKindAndName cs ckind str2+    orNoThingIn "component" (cinfoStrName c) $ do+      let ms = cinfoModules c+      m <- matchModuleName ms str3+      return (BuildTargetModule (cinfoPackage c) (cinfoName c) m)++match3PkgCmpFil :: [PackageInfo]+                -> String -> FileStatus -> String -> String+                -> Match (BuildTarget PackageInfo)+match3PkgCmpFil ps = \str1 fstatus1 str2 str3 -> do+    guardPackage         str1 fstatus1+    guardComponentName   str2+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentName (pinfoComponents p) str2+      orNoThingIn "component" (cinfoStrName c) $ do+        (filepath, _) <- matchComponentFile [c] str3+        return (BuildTargetFile p (cinfoName c) filepath)++match3KndCmpFil :: [ComponentInfo] -> String -> String -> String+                -> Match (BuildTarget PackageInfo)+match3KndCmpFil cs = \str1 str2 str3 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    orNoThingIn "component" (cinfoStrName c) $ do+      (filepath, _) <- matchComponentFile [c] str3+      return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath)++--++match4PkgKndCmpMod :: [PackageInfo]+                   -> String-> FileStatus -> String -> String -> String+                   -> Match (BuildTarget PackageInfo)+match4PkgKndCmpMod ps = \str1 fstatus1 str2 str3 str4 -> do+    guardPackage         str1 fstatus1+    ckind <- matchComponentKind str2+    guardComponentName   str3+    guardModuleName      str4+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentKindAndName (pinfoComponents p) ckind str3+      orNoThingIn "component" (cinfoStrName c) $ do+        let ms = cinfoModules c+        m <- matchModuleName ms str4+        return (BuildTargetModule p (cinfoName c) m)++match4PkgKndCmpFil :: [PackageInfo]+                   -> String -> FileStatus -> String -> String -> String+                   -> Match (BuildTarget PackageInfo)+match4PkgKndCmpFil ps = \str1 fstatus1 str2 str3 str4 -> do+    guardPackage       str1 fstatus1+    ckind <- matchComponentKind str2+    guardComponentName str3+    p     <- matchPackage ps    str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentKindAndName (pinfoComponents p) ckind str3+      orNoThingIn "component" (cinfoStrName c) $ do+        (filepath,_) <- matchComponentFile [c] str4+        return (BuildTargetFile p (cinfoName c) filepath)+++-------------------------------+-- Package and component info+--++data PackageInfo = PackageInfo {+       pinfoId          :: PackageId,+       pinfoLocation    :: PackageLocation (),+       pinfoDirectory   :: Maybe (FilePath, FilePath),+       pinfoPackageFile :: Maybe (FilePath, FilePath),+       pinfoComponents  :: [ComponentInfo]+     }++data ComponentInfo = ComponentInfo {+       cinfoName    :: ComponentName,+       cinfoStrName :: ComponentStringName,+       cinfoPackage :: PackageInfo,+       cinfoSrcDirs :: [FilePath],+       cinfoModules :: [ModuleName],+       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)+       cinfoCFiles  :: [FilePath],+       cinfoJsFiles :: [FilePath]+     }++type ComponentStringName = String++instance Package PackageInfo where+  packageId = pinfoId++--TODO: [required eventually] need the original GenericPackageDescription or+-- the flattening thereof because we need to be able to target modules etc+-- that are not enabled in the current configuration.+selectPackageInfo :: PackageDescription -> PackageLocation a -> IO PackageInfo+selectPackageInfo pkg loc = do+    (pkgdir, pkgfile) <-+      case loc of+        --TODO: local tarballs, remote tarballs etc+        LocalUnpackedPackage dir -> do+          dirabs <- canonicalizePath dir+          dirrel <- makeRelativeToCwd dirabs+          --TODO: ought to get this earlier in project reading+          let fileabs = dirabs </> display (packageName pkg) <.> "cabal"+              filerel = dirrel </> display (packageName pkg) <.> "cabal"+          exists <- doesFileExist fileabs+          return ( Just (dirabs, dirrel)+                 , if exists then Just (fileabs, filerel) else Nothing+                 )+        _ -> return (Nothing, Nothing)+    let pinfo =+          PackageInfo {+            pinfoId          = packageId pkg,+            pinfoLocation    = fmap (const ()) loc,+            pinfoDirectory   = pkgdir,+            pinfoPackageFile = pkgfile,+            pinfoComponents  = selectComponentInfo pinfo pkg+          }+    return pinfo+++selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo]+selectComponentInfo pinfo pkg =+    [ ComponentInfo {+        cinfoName    = componentName c,+        cinfoStrName = componentStringName pkg (componentName c),+        cinfoPackage = pinfo,+        cinfoSrcDirs = hsSourceDirs bi,+--                       [ pkgroot </> srcdir+--                       | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo)+--                       , srcdir <- hsSourceDirs bi ],+        cinfoModules = componentModules c,+        cinfoHsFiles = componentHsFiles c,+        cinfoCFiles  = cSources bi,+        cinfoJsFiles = jsSources bi+      }+    | c <- pkgComponents pkg+    , let bi = componentBuildInfo c ]+++componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName+componentStringName pkg CLibName          = display (packageName pkg)+componentStringName _ (CSubLibName name) = unUnqualComponentName name+componentStringName _ (CFLibName name)  = unUnqualComponentName name+componentStringName _ (CExeName   name) = unUnqualComponentName name+componentStringName _ (CTestName  name) = unUnqualComponentName name+componentStringName _ (CBenchName name) = unUnqualComponentName name++componentModules :: Component -> [ModuleName]+-- I think it's unlikely users will ask to build a requirement+-- which is not mentioned locally.+componentModules (CLib   lib)   = explicitLibModules lib+componentModules (CFLib  flib)  = foreignLibModules flib+componentModules (CExe   exe)   = exeModules exe+componentModules (CTest  test)  = testModules test+componentModules (CBench bench) = benchmarkModules bench++componentHsFiles :: Component -> [FilePath]+componentHsFiles (CExe exe) = [modulePath exe]+componentHsFiles (CTest  TestSuite {+                           testInterface = TestSuiteExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles (CBench Benchmark {+                           benchmarkInterface = BenchmarkExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles _          = []+++------------------------------+-- Matching component kinds+--++data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind+  deriving (Eq, Ord, Show)++componentKind :: ComponentName -> ComponentKind+componentKind  CLibName      = LibKind+componentKind (CSubLibName _) = LibKind+componentKind (CFLibName _)  = FLibKind+componentKind (CExeName   _) = ExeKind+componentKind (CTestName  _) = TestKind+componentKind (CBenchName _) = BenchKind++cinfoKind :: ComponentInfo -> ComponentKind+cinfoKind = componentKind . cinfoName++matchComponentKind :: String -> Match ComponentKind+matchComponentKind s+  | s `elem` ["lib", "library"]            = increaseConfidence >> return LibKind+  | s `elem` ["exe", "executable"]         = increaseConfidence >> return ExeKind+  | s `elem` ["tst", "test", "test-suite"] = increaseConfidence+                                             >> return TestKind+  | s `elem` ["bench", "benchmark"]        = increaseConfidence+                                             >> return BenchKind+  | otherwise                              = matchErrorExpected+                                             "component kind" s++showComponentKind :: ComponentKind -> String+showComponentKind LibKind   = "library"+showComponentKind FLibKind  = "foreign library"+showComponentKind ExeKind   = "executable"+showComponentKind TestKind  = "test-suite"+showComponentKind BenchKind = "benchmark"++showComponentKindShort :: ComponentKind -> String+showComponentKindShort LibKind   = "lib"+showComponentKindShort FLibKind  = "flib"+showComponentKindShort ExeKind   = "exe"+showComponentKindShort TestKind  = "test"+showComponentKindShort BenchKind = "bench"++------------------------------+-- Matching package targets+--++guardPackage :: String -> FileStatus -> Match ()+guardPackage str fstatus =+      guardPackageName str+  <|> guardPackageDir  str fstatus+  <|> guardPackageFile str fstatus+++guardPackageName :: String -> Match ()+guardPackageName s+  | validPackageName s = increaseConfidence+  | otherwise           = matchErrorExpected "package name" s+  where++validPackageName :: String -> Bool+validPackageName s =+       all validPackageNameChar s+    && not (null s)+  where+    validPackageNameChar c = isAlphaNum c || c == '-'+++guardPackageDir :: String -> FileStatus -> Match ()+guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence+guardPackageDir str _ = matchErrorExpected "package directory" str+++guardPackageFile :: String -> FileStatus -> Match ()+guardPackageFile _ (FileStatusExistsFile file)+                       | takeExtension file == ".cabal"+                       = increaseConfidence+guardPackageFile str _ = matchErrorExpected "package .cabal file" str+++matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo+matchPackage pinfo = \str fstatus ->+    orNoThingIn "project" "" $+          matchPackageName pinfo str+    <//> (matchPackageDir  pinfo str fstatus+     <|>  matchPackageFile pinfo str fstatus)+++matchPackageName :: [PackageInfo] -> String -> Match PackageInfo+matchPackageName ps = \str -> do+    guard (validPackageName str)+    orNoSuchThing "package" str+                  (map (display . packageName) ps) $+      increaseConfidenceFor $+        matchInexactly caseFold (display . packageName) ps str+++matchPackageDir :: [PackageInfo]+                -> String -> FileStatus -> Match PackageInfo+matchPackageDir ps = \str fstatus ->+    case fstatus of+      FileStatusExistsDir canondir ->+        orNoSuchThing "package directory" str (map (snd . fst) dirs) $+          increaseConfidenceFor $+            fmap snd $ matchExactly (fst . fst) dirs canondir+      _ -> mzero+  where+    dirs = [ ((dabs,drel),p)+           | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ]+++matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo+matchPackageFile ps = \str fstatus -> do+    case fstatus of+      FileStatusExistsFile canonfile ->+        orNoSuchThing "package .cabal file" str (map (snd . fst) files) $+          increaseConfidenceFor $+            fmap snd $ matchExactly (fst . fst) files canonfile+      _ -> mzero+  where+    files = [ ((fabs,frel),p)+            | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ]++--TODO: test outcome when dir exists but doesn't match any known one++--TODO: perhaps need another distinction, vs no such thing, point is the+--      thing is not known, within the project, but could be outside project+++------------------------------+-- Matching component targets+--+++guardComponentName :: String -> Match ()+guardComponentName s+  | all validComponentChar s+    && not (null s)  = increaseConfidence+  | otherwise        = matchErrorExpected "component name" s+  where+    validComponentChar c = isAlphaNum c || c == '.'+                        || c == '_' || c == '-' || c == '\''+++matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo+matchComponentName cs str =+    orNoSuchThing "component" str (map cinfoStrName cs)+  $ increaseConfidenceFor+  $ matchInexactly caseFold cinfoStrName cs str+++matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String+                          -> Match ComponentInfo+matchComponentKindAndName cs ckind str =+    orNoSuchThing (showComponentKind ckind ++ " component") str+                  (map render cs)+  $ increaseConfidenceFor+  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))+                   (\c -> (cinfoKind c, cinfoStrName c))+                   cs+                   (ckind, str)+  where+    render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c+++------------------------------+-- Matching module targets+--++guardModuleName :: String -> Match ()+guardModuleName s =+  case simpleParse s :: Maybe ModuleName of+    Just _                   -> increaseConfidence+    _ | all validModuleChar s+        && not (null s)      -> return ()+      | otherwise            -> matchErrorExpected "module name" s+    where+      validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''+++matchModuleName :: [ModuleName] -> String -> Match ModuleName+matchModuleName ms str =+    orNoSuchThing "module" str (map display ms)+  $ increaseConfidenceFor+  $ matchInexactly caseFold display ms str+++matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)+matchModuleNameAnd ms str =+    orNoSuchThing "module" str (map (display . fst) ms)+  $ increaseConfidenceFor+  $ matchInexactly caseFold (display . fst) ms str+++------------------------------+-- Matching file targets+--++matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus+                            -> Match (FilePath, PackageInfo)+matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =+    increaseConfidenceFor $+      matchDirectoryPrefix pkgdirs filepath+  where+    pkgdirs = [ (dir, p)+              | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ]+matchPackageDirectoryPrefix _ _ = mzero+++matchComponentFile :: [ComponentInfo] -> String+                   -> Match (FilePath, ComponentInfo)+matchComponentFile cs str =+    orNoSuchThing "file" str [] $+        matchComponentModuleFile cs str+    <|> matchComponentOtherFile  cs str+++matchComponentOtherFile :: [ComponentInfo] -> String+                        -> Match (FilePath, ComponentInfo)+matchComponentOtherFile cs =+    matchFile+      [ (file, c)+      | c    <- cs+      , file <- cinfoHsFiles c+             ++ cinfoCFiles  c+             ++ cinfoJsFiles c+      ]+++matchComponentModuleFile :: [ComponentInfo] -> String+                         -> Match (FilePath, ComponentInfo)+matchComponentModuleFile cs str = do+    matchFile+      [ (normalise (d </> toFilePath m), c)+      | c <- cs+      , d <- cinfoSrcDirs c+      , m <- cinfoModules c+      ]+      (dropExtension (normalise str))++-- utils++matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)+matchFile fs =+      increaseConfidenceFor+    . matchInexactly caseFold fst fs++matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)+matchDirectoryPrefix dirs filepath =+    tryEach $+      [ (file, x)+      | (dir,x) <- dirs+      , file <- maybeToList (stripDirectory dir) ]+  where+    stripDirectory :: FilePath -> Maybe FilePath+    stripDirectory dir =+      joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit++    filepathsplit = splitDirectories filepath+++------------------------------+-- Matching monad+--++-- | A matcher embodies a way to match some input as being some recognised+-- value. In particular it deals with multiple and ambiguous matches.+--+-- There are various matcher primitives ('matchExactly', 'matchInexactly'),+-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we+-- can run a matcher against an input using 'findMatch'.+--+data Match a = NoMatch      Confidence [MatchError]+             | ExactMatch   Confidence [a]+             | InexactMatch Confidence [a]+  deriving Show++type Confidence = Int++data MatchError = MatchErrorExpected String String            -- thing got+                | MatchErrorNoSuch   String String [String]   -- thing got alts+                | MatchErrorIn       String String MatchError -- kind  thing+  deriving (Show, Eq)+++instance Functor Match where+    fmap _ (NoMatch      d ms) = NoMatch      d ms+    fmap f (ExactMatch   d xs) = ExactMatch   d (fmap f xs)+    fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)++instance Applicative Match where+    pure a = ExactMatch 0 [a]+    (<*>)  = ap++instance Alternative Match where+    empty = NoMatch 0 []+    (<|>) = matchPlus++instance Monad Match where+    return                  = pure+    NoMatch      d ms >>= _ = NoMatch d ms+    ExactMatch   d xs >>= f = addDepth d+                            $ msum (map f xs)+    InexactMatch d xs >>= f = addDepth d . forceInexact+                            $ msum (map f xs)++instance MonadPlus Match where+    mzero = empty+    mplus = matchPlus++(<//>) :: Match a -> Match a -> Match a+(<//>) = matchPlusShadowing++infixl 3 <//>++addDepth :: Confidence -> Match a -> Match a+addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs+addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs+addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs++forceInexact :: Match a -> Match a+forceInexact (ExactMatch d ys) = InexactMatch d ys+forceInexact m                 = m++-- | Combine two matchers. Exact matches are used over inexact matches+-- but if we have multiple exact, or inexact then the we collect all the+-- ambiguous matches.+--+matchPlus :: Match a -> Match a -> Match a+matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =+  ExactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a+matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a+matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =+  InexactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a+matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b+matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')+                                             | d1 >  d2  = a+                                             | d1 <  d2  = b+                                             | otherwise = NoMatch d1 (ms ++ ms')++-- | Combine two matchers. This is similar to 'matchPlus' with the+-- difference that an exact match from the left matcher shadows any exact+-- match on the right. Inexact matches are still collected however.+--+matchPlusShadowing :: Match a -> Match a -> Match a+matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a+matchPlusShadowing a                   b               = matchPlus a b+++------------------------------+-- Various match primitives+--++matchErrorExpected :: String -> String -> Match a+matchErrorExpected thing got      = NoMatch 0 [MatchErrorExpected thing got]++matchErrorNoSuch :: String -> String -> [String] -> Match a+matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts]++expecting :: String -> String -> Match a -> Match a+expecting thing got (NoMatch 0 _) = matchErrorExpected thing got+expecting _     _   m             = m++orNoSuchThing :: String -> String -> [String] -> Match a -> Match a+orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts+orNoSuchThing _     _   _    m             = m++orNoThingIn :: String -> String -> Match a -> Match a+orNoThingIn kind name (NoMatch n ms) =+    NoMatch n [ MatchErrorIn kind name m | m <- ms ]+orNoThingIn _ _ m = m++increaseConfidence :: Match ()+increaseConfidence = ExactMatch 1 [()]++increaseConfidenceFor :: Match a -> Match a+increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r++nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a+nubMatchesBy _  (NoMatch      d msgs) = NoMatch      d msgs+nubMatchesBy eq (ExactMatch   d xs)   = ExactMatch   d (nubBy eq xs)+nubMatchesBy eq (InexactMatch d xs)   = InexactMatch d (nubBy eq xs)++-- | Lift a list of matches to an exact match.+--+exactMatches, inexactMatches :: [a] -> Match a++exactMatches [] = mzero+exactMatches xs = ExactMatch 0 xs++inexactMatches [] = mzero+inexactMatches xs = InexactMatch 0 xs++tryEach :: [a] -> Match a+tryEach = exactMatches+++------------------------------+-- Top level match runner+--++-- | Given a matcher and a key to look up, use the matcher to find all the+-- possible matches. There may be 'None', a single 'Unambiguous' match or+-- you may have an 'Ambiguous' match with several possibilities.+--+findMatch :: Match a -> MaybeAmbiguous a+findMatch match = case match of+  NoMatch    _ msgs  -> None msgs+  ExactMatch   _ [x] -> Unambiguous x+  InexactMatch _ [x] -> Unambiguous x+  ExactMatch   _  [] -> error "findMatch: impossible: ExactMatch []"+  InexactMatch _  [] -> error "findMatch: impossible: InexactMatch []"+  ExactMatch   _  xs -> Ambiguous True  xs+  InexactMatch _  xs -> Ambiguous False xs++data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a]+  deriving Show+++------------------------------+-- Basic matchers+--++-- | A primitive matcher that looks up a value in a finite 'Map'. The+-- value must match exactly.+--+matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a)+matchExactly key xs =+    \k -> case Map.lookup k m of+            Nothing -> mzero+            Just ys -> exactMatches ys+  where+    m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]++-- | A primitive matcher that looks up a value in a finite 'Map'. It checks+-- for an exact or inexact match. We get an inexact match if the match+-- is not exact, but the canonical forms match. It takes a canonicalisation+-- function for this purpose.+--+-- So for example if we used string case fold as the canonicalisation+-- function, then we would get case insensitive matching (but it will still+-- report an exact match when the case matches too).+--+matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k)+               -> [a] -> (k -> Match a)+matchInexactly cannonicalise key xs =+    \k -> case Map.lookup k m of+            Just ys -> exactMatches ys+            Nothing -> case Map.lookup (cannonicalise k) m' of+                         Just ys -> inexactMatches ys+                         Nothing -> mzero+  where+    m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]++    -- the map of canonicalised keys to groups of inexact matches+    m' = Map.mapKeysWith (++) cannonicalise m+++------------------------------+-- Utils+--++caseFold :: String -> String+caseFold = lowercase+++------------------------------+-- Example inputs+--++{-+ex1pinfo :: [PackageInfo]+ex1pinfo =+  [ PackageInfo {+      pinfoName        = PackageName "foo",+      pinfoDirectory   = Just "/the/foo",+      pinfoPackageFile = Just "/the/foo/foo.cabal",+      pinfoComponents  = []+    }+  , PackageInfo {+      pinfoName        = PackageName "bar",+      pinfoDirectory   = Just "/the/bar",+      pinfoPackageFile = Just "/the/bar/bar.cabal",+      pinfoComponents  = []+    }+  ]+-}+{-+stargets =+  [ BuildTargetComponent (CExeName "foo")+  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")+  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")+  ]+    where+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse++ex_pkgid :: PackageIdentifier+Just ex_pkgid = simpleParse "thelib"+-}++{-+ex_cs :: [ComponentInfo]+ex_cs =+  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])+  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])+  ]+    where+    mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms)+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse+    pkgid :: PackageIdentifier+    Just pkgid = simpleParse "thelib"+-}
cabal/cabal-install/Distribution/Client/Check.hs view
@@ -58,7 +58,7 @@         printCheckMessages buildImpossible      unless (null buildWarning) $ do-        putStrLn "The following warnings are likely affect your build negatively:"+        putStrLn "The following warnings are likely to affect your build negatively:"         printCheckMessages buildWarning      unless (null distSuspicious) $ do
+ cabal/cabal-install/Distribution/Client/CmdBuild.hs view
@@ -0,0 +1,90 @@+-- | cabal-install CLI command: build+--+module Distribution.Client.CmdBuild (+    buildCommand,+    buildAction,+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig+         ( BuildTimeSettings(..) )+import Distribution.Client.ProjectPlanning+         ( PackageTarget(..) )+import Distribution.Client.BuildTarget+         ( readUserBuildTargets )++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Verbosity+         ( normal )++import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Utils+         ( wrapText )+import qualified Distribution.Client.Setup as Client++buildCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+buildCommand = Client.installCommand {+  commandName         = "new-build",+  commandSynopsis     = "Builds a Nix-local build project",+  commandUsage        = usageAlternatives "new-build" [ "[FLAGS]"+                                                      , "[FLAGS] TARGETS" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Builds a Nix-local build project, automatically building and installing"+     ++ "necessary dependencies.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-build           "+     ++ "    Build the package in the current directory or all packages in the project\n"+     ++ "  " ++ pname ++ " new-build pkgname   "+     ++ "    Build the package named pkgname in the project\n"+     ++ "  " ++ pname ++ " new-build cname     "+     ++ "    Build the component named cname in the project\n"+     ++ "  " ++ pname ++ " new-build pkgname:cname"+     ++    " Build the component named cname in the package pkgname\n"+   }+++-- | The @build@ command does a lot. It brings the install plan up to date,+-- selects that part of the plan needed by the given or implicit targets and+-- then executes the plan.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+            -> [String] -> GlobalFlags -> IO ()+buildAction (configFlags, configExFlags, installFlags, haddockFlags)+            targetStrings globalFlags = do++    userTargets <- readUserBuildTargets targetStrings++    buildCtx <-+      runProjectPreBuildPhase+        verbosity+        ( globalFlags, configFlags, configExFlags+        , installFlags, haddockFlags )+        PreBuildHooks {+          hookPrePlanning      = \_ _ _ -> return (),++          hookSelectPlanSubset = \buildSettings' elaboratedPlan -> do+            -- Interpret the targets on the command line as build targets+            -- (as opposed to say repl or haddock targets).+            selectTargets+              verbosity+              BuildDefaultComponents+              BuildSpecificComponent+              userTargets+              (buildSettingOnlyDeps buildSettings')+              elaboratedPlan+        }++    printPlan verbosity buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity buildCtx+    runProjectPostBuildPhase verbosity buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
+ cabal/cabal-install/Distribution/Client/CmdConfigure.hs view
@@ -0,0 +1,97 @@+-- | cabal-install CLI command: configure+--+module Distribution.Client.CmdConfigure (+    configureCommand,+    configureAction,+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig+import Distribution.Client.ProjectPlanning+         ( PackageTarget(..) )++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Verbosity+         ( normal )++import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Utils+         ( wrapText )+import qualified Distribution.Client.Setup as Client++configureCommand :: CommandUI (ConfigFlags, ConfigExFlags+                              ,InstallFlags, HaddockFlags)+configureCommand = Client.installCommand {+  commandName         = "new-configure",+  commandSynopsis     = "Write out a cabal.project.local file.",+  commandUsage        = usageAlternatives "new-configure" [ "[FLAGS]" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Configures a Nix-local build project, downloading source from"+     ++ " the network and writing out a cabal.project.local file which"+     ++ " saves any FLAGS, to be reapplied on subsequent invocations to "+     ++ "new-build.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-configure           "+     ++ "    Configure project of the current directory\n"+   }++-- | To a first approximation, the @configure@ just runs the first phase of+-- the @build@ command where we bring the install plan up to date (thus+-- checking that it's possible).+--+-- The only difference is that @configure@ also allows the user to specify+-- some extra config flags which we save in the file @cabal.project.local@.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+                -> [String] -> GlobalFlags -> IO ()+configureAction (configFlags, configExFlags, installFlags, haddockFlags)+                _extraArgs globalFlags = do+    --TODO: deal with _extraArgs, since flags with wrong syntax end up there++    buildCtx <-+      runProjectPreBuildPhase+        verbosity+        ( globalFlags, configFlags, configExFlags+        , installFlags, haddockFlags )+        PreBuildHooks {+          hookPrePlanning = \rootDir _ cliConfig ->+            -- Write out the @cabal.project.local@ so it gets picked up by the+            -- planning phase.+            writeProjectLocalExtraConfig rootDir cliConfig,++          hookSelectPlanSubset = \buildSettings' elaboratedPlan -> do+            -- Select the same subset of targets as 'CmdBuild' would+            -- pick (ignoring, for example, executables in libraries+            -- we depend on).+            selectTargets+              verbosity+              BuildDefaultComponents+              BuildSpecificComponent+              []+              (buildSettingOnlyDeps buildSettings')+              elaboratedPlan++        }++    let buildCtx' = buildCtx {+                      buildSettings = (buildSettings buildCtx) {+                        buildSettingDryRun = True+                      }+                    }++    -- TODO: Hmm, but we don't have any targets. Currently this prints+    -- what we would build if we were to build everything. Could pick+    -- implicit target like "."+    --+    -- TODO: should we say what's in the project (+deps) as a whole?+    printPlan verbosity buildCtx'+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
+ cabal/cabal-install/Distribution/Client/CmdFreeze.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-}++-- | cabal-install CLI command: freeze+--+module Distribution.Client.CmdFreeze (+    freezeCommand,+    freezeAction,+  ) where++import Distribution.Client.ProjectPlanning+import Distribution.Client.ProjectConfig+         ( ProjectConfig(..), ProjectConfigShared(..)+         , commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig+         , findProjectRoot )+import Distribution.Client.Targets+         ( UserConstraint(..) )+import Distribution.Solver.Types.ConstraintSource+         ( ConstraintSource(..) )+import Distribution.Client.DistDirLayout+         ( defaultDistDirLayout, defaultCabalDirLayout )+import Distribution.Client.Config+         ( defaultCabalDir )+import qualified Distribution.Client.InstallPlan as InstallPlan+++import Distribution.Package+         ( PackageName, packageName, packageVersion )+import Distribution.Version+         ( VersionRange, thisVersion+         , unionVersionRanges, simplifyVersionRange )+import Distribution.PackageDescription+         ( FlagAssignment )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( die, notice )+import Distribution.Verbosity+         ( normal )++import Data.Monoid as Monoid+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Monad (unless)+import System.FilePath++import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Utils+         ( wrapText )+import qualified Distribution.Client.Setup as Client+++freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+freezeCommand = Client.installCommand {+  commandName         = "new-freeze",+  commandSynopsis     = "Freezes a Nix-local build project",+  commandUsage        = usageAlternatives "new-freeze" [ "[FLAGS]" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Performs dependency solving on a Nix-local build project, and"+     ++ " then writes out the precise dependency configuration to cabal.project.freeze"+     ++ " so that the plan is always used in subsequent builds.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-freeze          "+     ++ "    Freeze the configuration of the current project\n"+   }++-- | To a first approximation, the @freeze@ command runs the first phase of+-- the @build@ command where we bring the install plan up to date, and then+-- based on the install plan we write out a @cabal.project.freeze@ config file.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+             -> [String] -> GlobalFlags -> IO ()+freezeAction (configFlags, configExFlags, installFlags, haddockFlags)+             extraArgs globalFlags = do++    unless (null extraArgs) $+      die $ "'freeze' doesn't take any extra arguments: "+         ++ unwords extraArgs++    cabalDir <- defaultCabalDir+    let cabalDirLayout = defaultCabalDirLayout cabalDir++    projectRootDir <- findProjectRoot+    let distDirLayout = defaultDistDirLayout projectRootDir++    let cliConfig = commandLineFlagsToProjectConfig+                      globalFlags configFlags configExFlags+                      installFlags haddockFlags+++    (_, elaboratedPlan, _, _) <-+      rebuildInstallPlan verbosity+                         projectRootDir distDirLayout cabalDirLayout+                         cliConfig++    let freezeConfig = projectFreezeConfig elaboratedPlan+    writeProjectLocalFreezeConfig projectRootDir freezeConfig+    notice verbosity $+      "Wrote freeze file: " ++ projectRootDir </> "cabal.project.freeze"++  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)++++-- | Given the install plan, produce a config value with constraints that+-- freezes the versions of packages used in the plan.+--+projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig+projectFreezeConfig elaboratedPlan =+    Monoid.mempty {+      projectConfigShared = Monoid.mempty {+        projectConfigConstraints =+          concat (Map.elems (projectFreezeConstraints elaboratedPlan))+      }+    }++-- | Given the install plan, produce solver constraints that will ensure the+-- solver picks the same solution again in future in different environments.+--+projectFreezeConstraints :: ElaboratedInstallPlan+                         -> Map PackageName [(UserConstraint, ConstraintSource)]+projectFreezeConstraints plan =+    --+    -- TODO: [required eventually] this is currently an underapproximation+    -- since the constraints language is not expressive enough to specify the+    -- precise solution. See https://github.com/haskell/cabal/issues/3502.+    --+    -- For the moment we deal with multiple versions in the solution by using+    -- constraints that allow either version. Also, we do not include any+    -- /version/ constraints for packages that are local to the project (e.g.+    -- if the solution has two instances of Cabal, one from the local project+    -- and one pulled in as a setup deps then we exclude all constraints on+    -- Cabal, not just the constraint for the local instance since any+    -- constraint would apply to both instances). We do however keep flag+    -- constraints of local packages.+    --+    deleteLocalPackagesVersionConstraints+      (Map.unionWith (++) versionConstraints flagConstraints)+  where+    versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]+    versionConstraints =+      Map.mapWithKey+        (\p v -> [(UserConstraintVersion p v, ConstraintSourceFreeze)])+        versionRanges++    versionRanges :: Map PackageName VersionRange+    versionRanges =+      Map.map simplifyVersionRange $+      Map.fromListWith unionVersionRanges $+          [ (packageName pkg, thisVersion (packageVersion pkg))+          | InstallPlan.PreExisting pkg <- InstallPlan.toList plan+          ]+       ++ [ (packageName pkg, thisVersion (packageVersion pkg))+          | InstallPlan.Configured pkg <- InstallPlan.toList plan+          ]++    flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]+    flagConstraints =+      Map.mapWithKey+        (\p f -> [(UserConstraintFlags p f, ConstraintSourceFreeze)])+        flagAssignments++    flagAssignments :: Map PackageName FlagAssignment+    flagAssignments =+      Map.fromList+        [ (pkgname, flags)+        | InstallPlan.Configured elab <- InstallPlan.toList plan+        , let flags   = elabFlagAssignment elab+              pkgname = packageName elab+        , not (null flags) ]++    -- As described above, remove the version constraints on local packages,+    -- but leave any flag constraints.+    deleteLocalPackagesVersionConstraints+      :: Map PackageName [(UserConstraint, ConstraintSource)]+      -> Map PackageName [(UserConstraint, ConstraintSource)]+    deleteLocalPackagesVersionConstraints =+#if MIN_VERSION_containers(0,5,0)+      Map.mergeWithKey+        (\_pkgname () constraints ->+            case filter (not . isVersionConstraint . fst) constraints of+              []           -> Nothing+              constraints' -> Just constraints')+        (const Map.empty) id+        localPackages+#else+      Map.mapMaybeWithKey+        (\pkgname constraints ->+            if pkgname `Map.member` localPackages+              then case filter (not . isVersionConstraint . fst) constraints of+                     []           -> Nothing+                     constraints' -> Just constraints'+              else Just constraints)+#endif++    isVersionConstraint UserConstraintVersion{} = True+    isVersionConstraint _                       = False++    localPackages :: Map PackageName ()+    localPackages =+      Map.fromList+        [ (packageName elab, ())+        | InstallPlan.Configured elab <- InstallPlan.toList plan+        , elabLocalToProject elab+        ]+
+ cabal/cabal-install/Distribution/Client/CmdHaddock.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | cabal-install CLI command: haddock+--+module Distribution.Client.CmdHaddock (+    haddockCommand,+    haddockAction,+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig+import Distribution.Client.ProjectPlanning+         ( PackageTarget(..) )+import Distribution.Client.BuildTarget+         ( readUserBuildTargets )++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import qualified Distribution.Client.Setup as Client+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( wrapText )+import Distribution.Verbosity+         ( normal )++import Control.Monad (unless, void)++haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+haddockCommand = Client.installCommand {+  commandName         = "new-haddock",+  commandSynopsis     = "Build Haddock documentation for the current project",+  commandUsage        = usageAlternatives "new-haddock" [ "[FLAGS] TARGET" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Build Haddock documentation for a Nix-local build project.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-haddock cname"+     ++ "    Build documentation for the component named cname\n"+     ++ "  " ++ pname ++ " new-haddock pkgname:cname"+     ++ "    Build documentation for the component named cname in pkgname\n"+   }++-- | The @haddock@ command is TODO.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+                 -> [String] -> GlobalFlags -> IO ()+haddockAction (configFlags, configExFlags, installFlags, haddockFlags)+                targetStrings globalFlags = do++    userTargets <- readUserBuildTargets targetStrings++    buildCtx <-+      runProjectPreBuildPhase+        verbosity+        ( globalFlags, configFlags, configExFlags+        , installFlags, haddockFlags )+        PreBuildHooks {+          hookPrePlanning = \_ _ _ -> return (),+          hookSelectPlanSubset = \_ ->+              -- When we interpret the targets on the command line, interpret them as+              -- haddock targets+              selectTargets+                verbosity+                HaddockDefaultComponents+                (const HaddockDefaultComponents)+                userTargets+                False -- onlyDependencies, always False for haddock+        }++    --TODO: Hmm, but we don't have any targets. Currently this prints what we+    -- would build if we were to build everything. Could pick implicit target like "."+    --TODO: should we say what's in the project (+deps) as a whole?+    printPlan+      verbosity+      buildCtx {+        buildSettings = (buildSettings buildCtx) {+          buildSettingDryRun = True+        }+      }++    unless (buildSettingDryRun (buildSettings buildCtx)) $ void $+      runProjectBuildPhase+        verbosity+        buildCtx+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+
+ cabal/cabal-install/Distribution/Client/CmdRepl.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | cabal-install CLI command: repl+--+module Distribution.Client.CmdRepl (+    replCommand,+    replAction,+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig+         ( BuildTimeSettings(..) )+import Distribution.Client.ProjectPlanning+         ( PackageTarget(..) )+import Distribution.Client.BuildTarget+         ( readUserBuildTargets )++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Verbosity+         ( normal )++import Control.Monad (when)++import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Utils+         ( wrapText, die )+import qualified Distribution.Client.Setup as Client++replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+replCommand = Client.installCommand {+  commandName         = "new-repl",+  commandSynopsis     = "Open a REPL for the current project",+  commandUsage        = usageAlternatives "new-repl" [ "[FLAGS] TARGET" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Opens a REPL for a Nix-local build project.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-repl cname"+     ++ "    Open a REPL for the component named cname\n"+     ++ "  " ++ pname ++ " new-repl pkgname:cname"+     ++ "    Open a REPL for the component named cname in pkgname\n"+   }++-- | The @repl@ command is very much like @build@. It brings the install plan+-- up to date, selects that part of the plan needed by the given or implicit+-- repl target and then executes the plan.+--+-- Compared to @build@ the difference is that only one target is allowed+-- (given or implicit) and the target type is repl rather than build. The+-- general plan execution infrastructure handles both build and repl targets.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+              -> [String] -> GlobalFlags -> IO ()+replAction (configFlags, configExFlags, installFlags, haddockFlags)+           targetStrings globalFlags = do++    userTargets <- readUserBuildTargets targetStrings++    buildCtx <-+      runProjectPreBuildPhase+        verbosity+        ( globalFlags, configFlags, configExFlags+        , installFlags, haddockFlags )+        PreBuildHooks {+          hookPrePlanning      = \_ _ _ -> return (),++          hookSelectPlanSubset = \buildSettings elaboratedPlan -> do+            when (buildSettingOnlyDeps buildSettings) $+              die $ "The repl command does not support '--only-dependencies'. "+                 ++ "You may wish to use 'build --only-dependencies' and then "+                 ++ "use 'repl'."+            -- Interpret the targets on the command line as repl targets+            -- (as opposed to say build or haddock targets).+            selectTargets+              verbosity+              ReplDefaultComponent+              ReplSpecificComponent+              userTargets+              False -- onlyDependencies, always False for repl+              elaboratedPlan+            --TODO: [required eventually] reject multiple targets, or at least+            -- targets spanning multiple components. ie it's ok to have two+            -- module/file targets in the same component, but not two that live+            -- in different components.+        }++    printPlan verbosity buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity buildCtx+    runProjectPostBuildPhase verbosity buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+
+ cabal/cabal-install/Distribution/Client/Compat/Prelude.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}++-- to suppress WARNING in "Distribution.Compat.Prelude.Internal"+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- | This module does two things:+--+-- * Acts as a compatiblity layer, like @base-compat@.+--+-- * Provides commonly used imports.+--+-- This module is a superset of "Distribution.Compat.Prelude" (which+-- this module re-exports)+--+module Distribution.Client.Compat.Prelude+  ( module Distribution.Compat.Prelude.Internal+  , Prelude.IO+  , readMaybe+  ) where++import Prelude (IO)+import Distribution.Compat.Prelude.Internal hiding (IO)++#if MIN_VERSION_base(4,6,0)+import Text.Read+         ( readMaybe )+#endif++#if !MIN_VERSION_base(4,6,0)+-- | An implementation of readMaybe, for compatability with older base versions.+readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+                [(x,"")] -> Just x+                _        -> Nothing+#endif
cabal/cabal-install/Distribution/Client/Compat/Process.hs view
@@ -24,7 +24,7 @@  import           Control.Exception (catch, throw) import           System.Exit       (ExitCode (ExitFailure))-import           System.IO.Error   (isDoesNotExistError)+import           System.IO.Error   (isDoesNotExistError, isPermissionError) import qualified System.Process    as P  -- | @readProcessWithExitCode@ creates an external process, reads its@@ -38,11 +38,12 @@ --   The version from @System.Process@ behaves inconsistently across --   platforms when an executable with the given name is not found: in --   some cases it returns an @ExitFailure@, in others it throws an---   exception.  This variant catches \"does not exist\" exceptions and---   turns them into @ExitFailure@s.+--   exception.  This variant catches \"does not exist\" and+--   \"permission denied\" exceptions and turns them into+--   @ExitFailure@s. readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) readProcessWithExitCode cmd args input =   P.readProcessWithExitCode cmd args input-    `catch` \e -> if isDoesNotExistError e+    `catch` \e -> if isDoesNotExistError e || isPermissionError e                     then return (ExitFailure 127, "", "")                     else throw e
− cabal/cabal-install/Distribution/Client/Compat/Time.hs 
@@ -1,167 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving #-}-module Distribution.Client.Compat.Time-       ( ModTime(..) -- Needed for testing-       , getModTime, getFileAge, getCurTime-       , posixSecondsToModTime )-       where--import Control.Arrow    ( first )-import Data.Int         ( Int64 )-import Data.Word        ( Word64 )-import System.Directory ( getModificationTime )--import Distribution.Compat.Binary ( Binary )--import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )-#if MIN_VERSION_directory(1,2,0)-import Data.Time.Clock.POSIX ( posixDayLength )-import Data.Time             ( diffUTCTime, getCurrentTime )-#else-import System.Time ( getClockTime, diffClockTimes-                   , normalizeTimeDiff, tdDay, tdHour )-#endif--#if defined mingw32_HOST_OS--import Data.Bits          ((.|.), unsafeShiftL)-#if MIN_VERSION_base(4,7,0)-import Data.Bits          (finiteBitSize)-#else-import Data.Bits          (bitSize)-#endif--import Data.Int           ( Int32 )-import Foreign            ( allocaBytes, peekByteOff )-import System.IO.Error    ( mkIOError, doesNotExistErrorType )-import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )--#else--import System.Posix.Files ( FileStatus, getFileStatus )--#if MIN_VERSION_unix(2,6,0)-import System.Posix.Files ( modificationTimeHiRes )-#else-import System.Posix.Files ( modificationTime )-#endif--#endif---- | An opaque type representing a file's modification time, represented--- internally as a 64-bit unsigned integer in the Windows UTC format.-newtype ModTime = ModTime Word64-                deriving (Binary, Bounded, Eq, Ord)--instance Show ModTime where-  show (ModTime x) = show x--instance Read ModTime where-  readsPrec p str = map (first ModTime) (readsPrec p str)---- | Return modification time of the given file. Works around the low clock--- resolution problem that 'getModificationTime' has on GHC < 7.8.------ This is a modified version of the code originally written for Shake by Neil--- Mitchell. See module Development.Shake.FileInfo.-getModTime :: FilePath -> IO ModTime--#if defined mingw32_HOST_OS---- Directly against the Win32 API.-getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do-  res <- getFileAttributesEx path info-  if not res-    then do-      let err = mkIOError doesNotExistErrorType-                "Distribution.Client.Compat.Time.getModTime"-                Nothing (Just path)-      ioError err-    else do-      dwLow  <- peekByteOff info-                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime-      dwHigh <- peekByteOff info-                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime-#if MIN_VERSION_base(4,7,0)-      let qwTime =-            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)-            .|. (fromIntegral (dwLow :: DWORD))-#else-      let qwTime =-            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)-            .|. (fromIntegral (dwLow :: DWORD))-#endif-      return $! ModTime (qwTime :: Word64)--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV "windows.h GetFileAttributesExW"-  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL--getFileAttributesEx :: String -> LPVOID -> IO BOOL-getFileAttributesEx path lpFileInformation =-  withTString path $ \c_path ->-      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation--getFileExInfoStandard :: Int32-getFileExInfoStandard = 0--size_WIN32_FILE_ATTRIBUTE_DATA :: Int-size_WIN32_FILE_ATTRIBUTE_DATA = 36--index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20--index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24--#else---- Directly against the unix library.-getModTime path = do-    st <- getFileStatus path-    return $! (extractFileTime st)--extractFileTime :: FileStatus -> ModTime-#if MIN_VERSION_unix(2,6,0)-extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)-#else-extractFileTime x = posixSecondsToModTime $ fromIntegral $ fromEnum $-                    modificationTime x-#endif--#endif--windowsTick, secToUnixEpoch :: Word64-windowsTick    = 10000000-secToUnixEpoch = 11644473600---- | Convert POSIX seconds to ModTime.-posixSecondsToModTime :: Int64 -> ModTime-posixSecondsToModTime s =-  ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick---- | Convert 'POSIXTime' to 'ModTime'.-posixTimeToModTime :: POSIXTime -> ModTime-posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision-                       + (secToUnixEpoch * windowsTick)---- | Return age of given file in days.-getFileAge :: FilePath -> IO Double-getFileAge file = do-  t0 <- getModificationTime file-#if MIN_VERSION_directory(1,2,0)-  t1 <- getCurrentTime-  return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength-#else-  t1 <- getClockTime-  let dt = normalizeTimeDiff (t1 `diffClockTimes` t0)-  return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0-#endif---- | Return the current time as 'ModTime'.-getCurTime :: IO ModTime-getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
− cabal/cabal-install/Distribution/Client/ComponentDeps.hs 
@@ -1,162 +0,0 @@--- | Fine-grained package dependencies------ Like many others, this module is meant to be "double-imported":------ > import Distribution.Client.ComponentDeps (--- >     Component--- >   , ComponentDep--- >   , ComponentDeps--- >   )--- > import qualified Distribution.Client.ComponentDeps as CD-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.ComponentDeps (-    -- * Fine-grained package dependencies-    Component(..)-  , ComponentDep-  , ComponentDeps -- opaque-    -- ** Constructing ComponentDeps-  , empty-  , fromList-  , singleton-  , insert-  , filterDeps-  , fromLibraryDeps-  , fromSetupDeps-  , fromInstalled-    -- ** Deconstructing ComponentDeps-  , toList-  , flatDeps-  , nonSetupDeps-  , libraryDeps-  , setupDeps-  , select-  ) where--import Data.Map (Map)-import qualified Data.Map as Map-import Distribution.Compat.Binary (Binary)-import Distribution.Compat.Semigroup (Semigroup((<>)))-import GHC.Generics-import Data.Foldable (fold)--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable(foldMap))-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-#endif--{--------------------------------------------------------------------------------  Types--------------------------------------------------------------------------------}---- | Component of a package.-data Component =-    ComponentLib   String-  | ComponentExe   String-  | ComponentTest  String-  | ComponentBench String-  | ComponentSetup-  deriving (Show, Eq, Ord, Generic)--instance Binary Component---- | Dependency for a single component.-type ComponentDep a = (Component, a)---- | Fine-grained dependencies for a package.------ Typically used as @ComponentDeps [Dependency]@, to represent the list of--- dependencies for each named component within a package.----newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }-  deriving (Show, Functor, Eq, Ord, Generic)--instance Semigroup a => Monoid (ComponentDeps a) where-  mempty = ComponentDeps Map.empty-  mappend = (<>)--instance Semigroup a => Semigroup (ComponentDeps a) where-  ComponentDeps d <> ComponentDeps d' =-      ComponentDeps (Map.unionWith (<>) d d')--instance Foldable ComponentDeps where-  foldMap f = foldMap f . unComponentDeps--instance Traversable ComponentDeps where-  traverse f = fmap ComponentDeps . traverse f . unComponentDeps--instance Binary a => Binary (ComponentDeps a)--{--------------------------------------------------------------------------------  Construction--------------------------------------------------------------------------------}--empty :: ComponentDeps a-empty = ComponentDeps $ Map.empty--fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a-fromList = ComponentDeps . Map.fromListWith mappend--singleton :: Component -> a -> ComponentDeps a-singleton comp = ComponentDeps . Map.singleton comp--insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a-insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps-  where-    aux Nothing   = Just a-    aux (Just a') = Just $ a `mappend` a'---- | Keep only selected components (and their associated deps info).-filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a-filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps---- | ComponentDeps containing library dependencies only-fromLibraryDeps :: String -> a -> ComponentDeps a-fromLibraryDeps n = singleton (ComponentLib n)---- | ComponentDeps containing setup dependencies only.-fromSetupDeps :: a -> ComponentDeps a-fromSetupDeps = singleton ComponentSetup---- | ComponentDeps for installed packages.------ We assume that installed packages only record their library dependencies.-fromInstalled :: String -> a -> ComponentDeps a-fromInstalled = fromLibraryDeps--{--------------------------------------------------------------------------------  Deconstruction--------------------------------------------------------------------------------}--toList :: ComponentDeps a -> [ComponentDep a]-toList = Map.toList . unComponentDeps---- | All dependencies of a package.------ This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more--- obvious than a use of 'fold', and moreover this avoids introducing lots of--- @#ifdef@s for 7.10 just for the use of 'fold'.-flatDeps :: Monoid a => ComponentDeps a -> a-flatDeps = fold---- | All dependencies except the setup dependencies.------ Prior to the introduction of setup dependencies in version 1.24 this--- would have been _all_ dependencies.-nonSetupDeps :: Monoid a => ComponentDeps a -> a-nonSetupDeps = select (/= ComponentSetup)---- | Library dependencies proper only.-libraryDeps :: Monoid a => ComponentDeps a -> a-libraryDeps = select (\c -> case c of ComponentLib _ -> True-                                      _ -> False)---- | Setup dependencies.-setupDeps :: Monoid a => ComponentDeps a -> a-setupDeps = select (== ComponentSetup)---- | Select dependencies satisfying a given predicate.-select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a-select p = foldMap snd . filter (p . fst) . toList
cabal/cabal-install/Distribution/Client/Config.hs view
@@ -49,8 +49,6 @@          ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) )-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..) ) import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand, defaultGlobalFlags          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags@@ -59,16 +57,16 @@          , ReportFlags(..), reportCommand          , showRepo, parseRepo, readRepo ) import Distribution.Utils.NubList-         ( NubList, fromNubList, toNubList)+         ( NubList, fromNubList, toNubList, overNubList )  import Distribution.Simple.Compiler          ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags-         , AllowNewer(..)+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , HaddockFlags(..), haddockOptions, defaultHaddockFlags          , installDirsOptions, optionDistPref-         , programConfigurationPaths', programConfigurationOptions+         , programDbPaths', programDbOptions          , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs          ( InstallDirs(..), defaultInstallDirs@@ -87,12 +85,12 @@ import qualified Distribution.ParseUtils as ParseUtils          ( Field(..) ) import qualified Distribution.Text as Text-         ( Text(..) )+         ( Text(..), display ) import Distribution.Simple.Command          ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)          , viewAsFieldDescr ) import Distribution.Simple.Program-         ( defaultProgramConfiguration )+         ( defaultProgramDb ) import Distribution.Simple.Utils          ( die, notice, warn, lowercase, cabalVersion ) import Distribution.Compiler@@ -100,12 +98,14 @@ import Distribution.Verbosity          ( Verbosity, normal ) +import Distribution.Solver.Types.ConstraintSource+ import Data.List          ( partition, find, foldl' ) import Data.Maybe          ( fromMaybe ) import Control.Monad-         ( when, unless, foldM, liftM, liftM2 )+         ( when, unless, foldM, liftM ) import qualified Distribution.Compat.ReadP as Parse          ( (<++), option ) import Distribution.Compat.Semigroup@@ -240,6 +240,7 @@         installDryRun                = combine installDryRun,         installMaxBackjumps          = combine installMaxBackjumps,         installReorderGoals          = combine installReorderGoals,+        installCountConflicts        = combine installCountConflicts,         installIndependentGoals      = combine installIndependentGoals,         installShadowPkgs            = combine installShadowPkgs,         installStrongFlags           = combine installStrongFlags,@@ -249,6 +250,7 @@         installUpgradeDeps           = combine installUpgradeDeps,         installOnly                  = combine installOnly,         installOnlyDeps              = combine installOnlyDeps,+        installIndexState            = combine installIndexState,         installRootCmd               = combine installRootCmd,         installSummaryFile           = lastNonEmptyNL installSummaryFile,         installLogFile               = combine installLogFile,@@ -257,6 +259,7 @@         installSymlinkBinDir         = combine installSymlinkBinDir,         installOneShot               = combine installOneShot,         installNumJobs               = combine installNumJobs,+        installKeepGoing             = combine installKeepGoing,         installRunTests              = combine installRunTests,         installOfflineMode           = combine installOfflineMode         }@@ -265,12 +268,14 @@           lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags        combinedSavedConfigureFlags = ConfigFlags {+        configArgs                = lastNonEmpty configArgs,         configPrograms_           = configPrograms_ . savedConfigureFlags $ b,         -- TODO: NubListify         configProgramPaths        = lastNonEmpty configProgramPaths,         -- TODO: NubListify         configProgramArgs         = lastNonEmpty configProgramArgs,         configProgramPathExtra    = lastNonEmptyNL configProgramPathExtra,+        configInstantiateWith     = lastNonEmpty configInstantiateWith,         configHcFlavor            = combine configHcFlavor,         configHcPath              = combine configHcPath,         configHcPkg               = combine configHcPkg,@@ -300,7 +305,9 @@         -- TODO: NubListify         configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,         configIPID                = combine configIPID,+        configCID                 = combine configCID,         configDistPref            = combine configDistPref,+        configCabalFilePath       = combine configCabalFilePath,         configVerbosity           = combine configVerbosity,         configUserInstall         = combine configUserInstall,         -- TODO: NubListify@@ -322,6 +329,8 @@         configExactConfiguration  = combine configExactConfiguration,         configFlagError           = combine configFlagError,         configRelocatable         = combine configRelocatable,+        configAllowOlder          = combineMonoid savedConfigureFlags+                                    configAllowOlder,         configAllowNewer          = combineMonoid savedConfigureFlags                                     configAllowNewer         }@@ -351,7 +360,7 @@                                        `mappend` savedGlobalInstallDirs b        combinedSavedUploadFlags = UploadFlags {-        uploadCheck       = combine uploadCheck,+        uploadCandidate   = combine uploadCandidate,         uploadDoc         = combine uploadDoc,         uploadUsername    = combine uploadUsername,         uploadPassword    = combine uploadPassword,@@ -381,6 +390,7 @@         haddockExecutables   = combine haddockExecutables,         haddockTestSuites    = combine haddockTestSuites,         haddockBenchmarks    = combine haddockBenchmarks,+        haddockForeignLibs   = combine haddockForeignLibs,         haddockInternal      = combine haddockInternal,         haddockCss           = combine haddockCss,         haddockHscolour      = combine haddockHscolour,@@ -439,7 +449,7 @@   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,-      globalRemoteRepos  = toNubList [addInfoForKnownRepos defaultRemoteRepo],+      globalRemoteRepos  = toNubList [defaultRemoteRepo],       globalWorldFile    = toFlag worldFile     },     savedConfigureFlags  = mempty {@@ -508,23 +518,87 @@ -- we might have only have older info. This lets us fill that in even for old -- config files. ----- TODO: Once we migrate from opt-in to opt-out security for the central--- Hackage repository, we should enable security and specify keys and threshold--- for repositories that have their security setting as 'Nothing' (default). addInfoForKnownRepos :: RemoteRepo -> RemoteRepo-addInfoForKnownRepos repo@RemoteRepo{ remoteRepoName = "hackage.haskell.org" } =-      tryHttps-    $ if isOldHackageURI (remoteRepoURI repo) then defaultRemoteRepo else repo+addInfoForKnownRepos repo+  | remoteRepoName repo == remoteRepoName defaultRemoteRepo+  = useSecure . tryHttps . fixOldURI $ repo   where+    fixOldURI r+      | isOldHackageURI (remoteRepoURI r)+                  = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo }+      | otherwise = r+     tryHttps r = r { remoteRepoShouldTryHttps = True }++    useSecure r@RemoteRepo{+                  remoteRepoSecure       = secure,+                  remoteRepoRootKeys     = [],+                  remoteRepoKeyThreshold = 0+                } | secure /= Just False+            = r {+                -- Use hackage-security by default unless you opt-out with+                -- secure: False+                remoteRepoSecure       = Just True,+                remoteRepoRootKeys     = defaultHackageRemoteRepoKeys,+                remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold+              }+    useSecure r = r addInfoForKnownRepos other = other +-- | The current hackage.haskell.org repo root keys that we ship with cabal.+---+-- This lets us bootstrap trust in this repo without user intervention.+-- These keys need to be periodically updated when new root keys are added.+-- See the root key procedures for details. --+defaultHackageRemoteRepoKeys :: [String]+defaultHackageRemoteRepoKeys =+    [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0",+      "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42",+      "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3",+      "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d",+      "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"+    ]++-- | The required threshold of root key signatures for hackage.haskell.org+--+defaultHackageRemoteRepoKeyThreshold :: Int+defaultHackageRemoteRepoKeyThreshold = 3++-- -- * Config file reading -- +-- | Loads the main configuration, and applies additional defaults to give the+-- effective configuration. To loads just what is actually in the config file,+-- use 'loadRawConfig'.+-- loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig-loadConfig verbosity configFileFlag = addBaseConf $ do+loadConfig verbosity configFileFlag = do+  config <- loadRawConfig verbosity configFileFlag+  extendToEffectiveConfig config++extendToEffectiveConfig :: SavedConfig -> IO SavedConfig+extendToEffectiveConfig config = do+  base <- baseSavedConfig+  let effective0   = base `mappend` config+      globalFlags0 = savedGlobalFlags effective0+      effective  = effective0 {+                     savedGlobalFlags = globalFlags0 {+                       globalRemoteRepos =+                         overNubList (map addInfoForKnownRepos)+                                     (globalRemoteRepos globalFlags0)+                     }+                   }+  return effective++-- | Like 'loadConfig' but does not apply any additional defaults, it just+-- loads what is actually in the config file. This is thus suitable for+-- comparing or editing a config file, but not suitable for using as the+-- effective configuration.+--+loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig+loadRawConfig verbosity configFileFlag = do   (source, configFile) <- getConfigFilePathAndSource configFileFlag   minp <- readConfigFile mempty configFile   case minp of@@ -532,7 +606,6 @@       notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "."       notice verbosity $ "Config file " ++ configFile ++ " not found."       createDefaultConfigFile verbosity configFile-      loadConfig verbosity configFileFlag     Just (ParseOk ws conf) -> do       unless (null ws) $ warn verbosity $         unlines (map (showPWarning configFile) ws)@@ -544,11 +617,6 @@         ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg    where-    addBaseConf body = do-      base  <- baseSavedConfig-      extra <- body-      return (base `mappend` extra)-     sourceMsg CommandlineOption =   "commandline option"     sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"     sourceMsg Default =             "default config file"@@ -586,12 +654,13 @@         then return Nothing         else ioError ioe -createDefaultConfigFile :: Verbosity -> FilePath -> IO ()+createDefaultConfigFile :: Verbosity -> FilePath -> IO SavedConfig createDefaultConfigFile verbosity filePath = do   commentConf <- commentSavedConfig   initialConf <- initialSavedConfig   notice verbosity $ "Writing default configuration to " ++ filePath   writeConfigFile filePath commentConf initialConf+  return initialConf  writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do@@ -602,15 +671,17 @@   where     explanation = unlines       ["-- This is the configuration file for the 'cabal' command line tool."-      ,""+      ,"--"       ,"-- The available configuration options are listed below."       ,"-- Some of them have default values listed."-      ,""+      ,"--"       ,"-- Lines (like this one) beginning with '--' are comments."       ,"-- Be careful with spaces and indentation because they are"       ,"-- used to indicate layout for nested sections."-      ,""-      ,"-- Cabal library version: " ++ showVersion cabalVersion+      ,"--"+      ,"-- This config file was generated using the following versions"+      ,"-- of Cabal and cabal-install:"+      ,"-- Cabal library version: " ++ Text.display cabalVersion       ,"-- cabal-install version: " ++ showVersion Paths_cabal_install.version       ,"",""       ]@@ -624,21 +695,38 @@ commentSavedConfig = do   userInstallDirs   <- defaultInstallDirs defaultCompiler True True   globalInstallDirs <- defaultInstallDirs defaultCompiler False True-  return SavedConfig {-    savedGlobalFlags       = defaultGlobalFlags,-    savedInstallFlags      = defaultInstallFlags,-    savedConfigureExFlags  = defaultConfigExFlags,-    savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {-      configUserInstall    = toFlag defaultUserInstall,-      configAllowNewer     = Just AllowNewerNone-    },-    savedUserInstallDirs   = fmap toFlag userInstallDirs,-    savedGlobalInstallDirs = fmap toFlag globalInstallDirs,-    savedUploadFlags       = commandDefaultFlags uploadCommand,-    savedReportFlags       = commandDefaultFlags reportCommand,-    savedHaddockFlags      = defaultHaddockFlags-  }+  let conf0 = mempty {+        savedGlobalFlags       = defaultGlobalFlags {+            globalRemoteRepos = toNubList [defaultRemoteRepo]+            },+        savedInstallFlags      = defaultInstallFlags,+        savedConfigureExFlags  = defaultConfigExFlags,+        savedConfigureFlags    = (defaultConfigFlags defaultProgramDb) {+            configUserInstall    = toFlag defaultUserInstall,+            configAllowNewer     = Just (AllowNewer RelaxDepsNone),+            configAllowOlder     = Just (AllowOlder RelaxDepsNone)+            },+        savedUserInstallDirs   = fmap toFlag userInstallDirs,+        savedGlobalInstallDirs = fmap toFlag globalInstallDirs,+        savedUploadFlags       = commandDefaultFlags uploadCommand,+        savedReportFlags       = commandDefaultFlags reportCommand,+        savedHaddockFlags      = defaultHaddockFlags +        }+  conf1 <- extendToEffectiveConfig conf0+  let globalFlagsConf1 = savedGlobalFlags conf1+      conf2 = conf1 {+        savedGlobalFlags = globalFlagsConf1 {+            globalRemoteRepos = overNubList (map removeRootKeys)+                                (globalRemoteRepos globalFlagsConf1)+            }+        }+  return conf2+    where+      -- Most people don't want to see default root keys, so don't print them.+      removeRootKeys :: RemoteRepo -> RemoteRepo+      removeRootKeys r = r { remoteRepoRootKeys = [] }+ -- | All config file fields. -- configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]@@ -659,17 +747,15 @@        [simpleField "compiler"           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)           configHcFlavor (\v flags -> flags { configHcFlavor = v })-       ,let showAllowNewer Nothing               = mempty-            showAllowNewer (Just AllowNewerNone) = Disp.text "False"-            showAllowNewer (Just _)              = Disp.text "True"--            toAllowNewer True  = Just AllowNewerAll-            toAllowNewer False = Just AllowNewerNone--            pkgs = (Just . AllowNewerSome) `fmap` parseOptCommaList Text.parse-            parseAllowNewer = (toAllowNewer `fmap` Text.parse) Parse.<++ pkgs in+       ,let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse+            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in+        simpleField "allow-older"+        (showRelaxDeps . fmap unAllowOlder) parseAllowOlder+        configAllowOlder (\v flags -> flags { configAllowOlder = v })+       ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse+            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in         simpleField "allow-newer"-        showAllowNewer parseAllowNewer+        (showRelaxDeps . fmap unAllowNewer) parseAllowNewer         configAllowNewer (\v flags -> flags { configAllowNewer = v })         -- TODO: The following is a temporary fix. The "optimization"         -- and "debug-info" fields are OptArg, and viewAsFieldDescr@@ -735,7 +821,7 @@    ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)-       ["verbose", "check", "documentation"] []+       ["verbose", "check", "documentation", "publish"] []    ++ toSavedConfig liftReportFlag        (commandOptions reportCommand ParseArgs)@@ -769,6 +855,15 @@       , name `notElem` exclusions ]     optional = Parse.option mempty . fmap toFlag ++    showRelaxDeps Nothing              = mempty+    showRelaxDeps (Just RelaxDepsNone) = Disp.text "False"+    showRelaxDeps (Just _)             = Disp.text "True"++    toRelaxDeps True  = RelaxDepsAll+    toRelaxDeps False = RelaxDepsNone++ -- TODO: next step, make the deprecated fields elicit a warning. -- deprecatedFieldDescriptions :: [FieldDescr SavedConfig]@@ -855,8 +950,7 @@           knownSections    let remoteRepoSections =-          map addInfoForKnownRepos-        . reverse+          reverse         . nubBy ((==) `on` remoteRepoName)         $ remoteRepoSections0 @@ -943,8 +1037,8 @@  showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $-      case fmap ppRemoteRepoSection . fromNubList . globalRemoteRepos-           . savedGlobalFlags $ vals of+      case fmap (uncurry ppRemoteRepoSection)+           (zip (getRemoteRepos comment) (getRemoteRepos vals)) of         [] -> Disp.text ""         (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs   $+$ Disp.text ""@@ -964,6 +1058,7 @@   $+$ configFlagsSection "program-default-options" withProgramOptionsFields                          configProgramArgs   where+    getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags     mcomment = Just comment     installDirsSection name field =       ppSection "install-dirs" name installDirsFields@@ -981,11 +1076,9 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions -ppRemoteRepoSection :: RemoteRepo -> Doc-ppRemoteRepoSection vals = ppSection "repository" (remoteRepoName vals)-        remoteRepoFields def vals-  where-    def = Just (emptyRemoteRepo "ignored") { remoteRepoSecure = Just False }+ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc+ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals)+        remoteRepoFields (Just def) vals  remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields =@@ -1027,27 +1120,27 @@                            name  = fieldName field                      , name `notElem` exclusions ]   where-    exclusions = ["verbose", "builddir"]+    exclusions = ["verbose", "builddir", "for-hackage"]  -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]] withProgramsFields =   map viewAsFieldDescr $-  programConfigurationPaths' (++ "-location") defaultProgramConfiguration+  programDbPaths' (++ "-location") defaultProgramDb                              ParseArgs id (++)  -- | Fields for the 'program-default-options' section. withProgramOptionsFields :: [FieldDescr [(String, [String])]] withProgramOptionsFields =   map viewAsFieldDescr $-  programConfigurationOptions defaultProgramConfiguration ParseArgs id (++)+  programDbOptions defaultProgramDb ParseArgs id (++)  -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist. userConfigDiff :: GlobalFlags -> IO [String] userConfigDiff globalFlags = do-  userConfig <- loadConfig normal (globalConfigFile globalFlags)-  testConfig <- liftM2 mappend baseSavedConfig initialSavedConfig+  userConfig <- loadRawConfig normal (globalConfigFile globalFlags)+  testConfig <- initialSavedConfig   return $ reverse . foldl' createDiff [] . M.toList                 $ M.unionWith combine                     (M.fromList . map justFst $ filterShow testConfig)@@ -1091,8 +1184,8 @@ -- | Update the user's ~/.cabal/config' keeping the user's customizations. userConfigUpdate :: Verbosity -> GlobalFlags -> IO () userConfigUpdate verbosity globalFlags = do-  userConfig <- loadConfig normal (globalConfigFile globalFlags)-  newConfig <- liftM2 mappend baseSavedConfig initialSavedConfig+  userConfig  <- loadRawConfig normal (globalConfigFile globalFlags)+  newConfig   <- initialSavedConfig   commentConf <- commentSavedConfig   cabalFile <- getConfigFilePath $ globalConfigFile globalFlags   let backup = cabalFile ++ ".backup"
cabal/cabal-install/Distribution/Client/Configure.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Configure@@ -15,69 +14,77 @@     configure,     configureSetupScript,     chooseCabalVersion,-    checkConfigExFlags+    checkConfigExFlags,+    -- * Saved configure flags+    readConfigFlagsFrom, readConfigFlags,+    cabalConfigFlagsFile,+    writeConfigFlagsTo, writeConfigFlags,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..)-         , LabeledPackageConstraint(..), showConstraintSource ) import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )-import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName )-import Distribution.Client.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Client.Setup-         ( ConfigExFlags(..), configureCommand, filterConfigureFlags-         , RepoContext(..) )+         ( ConfigExFlags(..), RepoContext(..)+         , configureCommand, configureExCommand, filterConfigureFlags ) import Distribution.Client.Types as Source import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Targets          ( userToPackageConstraint, userConstraintPackageName )-import qualified Distribution.Client.ComponentDeps as CD import Distribution.Package (PackageId) import Distribution.Client.JobControl (Lock) +import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageIndex+                   ( PackageIndex, elemByPackageName )+import           Distribution.Solver.Types.PkgConfigDb+                   (PkgConfigDb, readPkgConfigDb)+import           Distribution.Solver.Types.SourcePackage+ import Distribution.Simple.Compiler          ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration )+import Distribution.Simple.Program (ProgramDb)+import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) import Distribution.Simple.Setup-         ( ConfigFlags(..), AllowNewer(..)+         ( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.PackageIndex          ( InstalledPackageIndex, lookupPackageName ) import Distribution.Simple.Utils          ( defaultPackageDesc ) import Distribution.Package-         ( Package(..), UnitId, packageName+         ( Package(..), packageName          , Dependency(..), thisPackageVersion          ) import qualified Distribution.PackageDescription as PkgDesc import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )+         ( finalizePD ) import Distribution.Version-         ( anyVersion, thisVersion )+         ( Version, mkVersion, anyVersion, thisVersion+         , VersionRange, orLaterVersion ) import Distribution.Simple.Utils as Utils          ( warn, notice, debug, die ) import Distribution.Simple.Setup-         ( isAllowNewer )+         ( isRelaxDeps ) import Distribution.System          ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity          ( Verbosity )-import Distribution.Version-         ( Version(..), VersionRange, orLaterVersion ) -import Control.Monad (unless)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif-import Data.Maybe (isJust, fromMaybe)+import System.FilePath ( (</>) )  -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags.@@ -87,11 +94,13 @@   where     -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed     -- for '--allow-newer' to work.-    allowNewer = isAllowNewer-                 (fromMaybe AllowNewerNone $ configAllowNewer configFlags)+    allowNewer = isRelaxDeps+                 (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags)+    allowOlder = isRelaxDeps+                 (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configFlags) -    defaultVersionRange = if allowNewer-                          then orLaterVersion (Version [1,19,2] [])+    defaultVersionRange = if allowOlder || allowNewer+                          then orLaterVersion (mkVersion [1,19,2])                           else anyVersion  -- | Configure the package found in the local directory@@ -100,17 +109,17 @@           -> RepoContext           -> Compiler           -> Platform-          -> ProgramConfiguration+          -> ProgramDb           -> ConfigFlags           -> ConfigExFlags           -> [String]           -> IO ()-configure verbosity packageDBs repoCtxt comp platform conf+configure verbosity packageDBs repoCtxt comp platform progdb   configFlags configExFlags extraArgs = do -  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb   sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-  pkgConfigDb       <- readPkgConfigDb      verbosity conf+  pkgConfigDb       <- readPkgConfigDb      verbosity progdb    checkConfigExFlags verbosity installedPkgIndex                      (packageIndex sourcePkgDb) configExFlags@@ -130,9 +139,11 @@       setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)         Nothing configureCommand (const configFlags) extraArgs -    Right installPlan -> case InstallPlan.ready installPlan of+    Right installPlan0 ->+     let installPlan = InstallPlan.configureInstallPlan installPlan0+     in case fst (InstallPlan.ready installPlan) of       [pkg@(ReadyPackage-             (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)+              (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)                                  _ _ _))] -> do         configurePackage verbosity           platform (compilerInfo comp)@@ -151,7 +162,7 @@         packageDBs         comp         platform-        conf+        progdb         (fromFlagOrDefault            (useDistPref defaultSetupScriptOptions)            (configDistPref configFlags))@@ -166,7 +177,7 @@ configureSetupScript :: PackageDBStack                      -> Compiler                      -> Platform-                     -> ProgramConfiguration+                     -> ProgramDb                      -> FilePath                      -> VersionRange                      -> Maybe Lock@@ -177,7 +188,7 @@ configureSetupScript packageDBs                      comp                      platform-                     conf+                     progdb                      distPref                      cabalVersion                      lock@@ -185,18 +196,19 @@                      index                      mpkg   = SetupScriptOptions {-      useCabalVersion   = cabalVersion-    , useCabalSpecVersion = Nothing-    , useCompiler       = Just comp-    , usePlatform       = Just platform-    , usePackageDB      = packageDBs'-    , usePackageIndex   = index'-    , useProgramConfig  = conf-    , useDistPref       = distPref-    , useLoggingHandle  = Nothing-    , useWorkingDir     = Nothing-    , setupCacheLock    = lock-    , useWin32CleanHack = False+      useCabalVersion          = cabalVersion+    , useCabalSpecVersion      = Nothing+    , useCompiler              = Just comp+    , usePlatform              = Just platform+    , usePackageDB             = packageDBs'+    , usePackageIndex          = index'+    , useProgramDb             = progdb+    , useDistPref              = distPref+    , useLoggingHandle         = Nothing+    , useWorkingDir            = Nothing+    , useExtraPathEnv          = []+    , setupCacheLock           = lock+    , useWin32CleanHack        = False     , forceExternalSetupMethod = forceExternal       -- If we have explicit setup dependencies, list them; otherwise, we give       -- the empty list of dependencies; ideally, we would fix the version of@@ -205,8 +217,9 @@       -- know the version of Cabal at this point, but only find this there.       -- Therefore, for now, we just leave this blank.     , useDependencies          = fromMaybe [] explicitSetupDeps-    , useDependenciesExclusive = isJust explicitSetupDeps-    , useVersionMacros         = isJust explicitSetupDeps+    , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps+    , useVersionMacros         = not defaultSetupDeps && isJust explicitSetupDeps+    , isInteractive            = False     }   where     -- When we are compiling a legacy setup script without an explicit@@ -224,15 +237,26 @@         -- but if the user is using an odd db stack, don't touch it         _otherwise -> (packageDBs, Just index) -    explicitSetupDeps :: Maybe [(UnitId, PackageId)]-    explicitSetupDeps = do+    maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo+    maybeSetupBuildInfo = do       ReadyPackage cpkg <- mpkg       let gpkg = packageDescription (confPkgSource cpkg)-      -- Check if there is an explicit setup stanza-      _buildInfo <- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)+      PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)++    -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If+    -- so, 'setup-depends' must not be exclusive. See #3199.+    defaultSetupDeps :: Bool+    defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends+                       maybeSetupBuildInfo++    explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]+    explicitSetupDeps = do+      -- Check if there is an explicit setup stanza.+      _buildInfo <- maybeSetupBuildInfo       -- Return the setup dependencies computed by the solver-      return [ ( uid, srcid )-             | ConfiguredId srcid uid <- CD.setupDeps (confPkgDeps cpkg)+      ReadyPackage cpkg <- mpkg+      return [ ( cid, srcid )+             | ConfiguredId srcid cid <- CD.setupDeps (confPkgDeps cpkg)              ]  -- | Warn if any constraints or preferences name packages that are not in the@@ -269,7 +293,7 @@                  -> InstalledPackageIndex                  -> SourcePackageDb                  -> PkgConfigDb-                 -> IO (Progress String String InstallPlan)+                 -> IO (Progress String String SolverInstallPlan) planLocalPackage verbosity comp platform configFlags configExFlags   installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity@@ -279,7 +303,7 @@   let -- We create a local package and ask to resolve a dependency on it       localPkg = SourcePackage {         packageInfoId             = packageId pkg,-        Source.packageDescription = pkg,+        packageDescription        = pkg,         packageSource             = LocalUnpackedPackage ".",         packageDescrOverride      = Nothing       }@@ -289,8 +313,10 @@         fromFlagOrDefault False $ configBenchmarks configFlags        resolverParams =-          removeUpperBounds-          (fromMaybe AllowNewerNone $ configAllowNewer configFlags)+          removeLowerBounds+          (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configFlags)+        . removeUpperBounds+          (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configFlags)          . addPreferences             -- preferences from the config file or command line@@ -320,8 +346,16 @@               in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget             ] +            -- Don't solve for executables, since we use an empty source+            -- package database and executables never show up in the+            -- installed package index+        . setSolveExecutables (SolveExecutables False)+         $ standardInstallPolicy             installedPkgIndex+            -- NB: We pass in an *empty* source package database,+            -- because cabal configure assumes that all dependencies+            -- have already been installed             (SourcePackageDb mempty packagePrefs)             [SpecificSourcePackage localPkg] @@ -344,7 +378,7 @@                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-                 (ReadyPackage (ConfiguredPackage spkg flags stanzas deps))+                 (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))                  extraArgs =    setupWrapper verbosity@@ -353,6 +387,7 @@   where     gpkg = packageDescription spkg     configureFlags   = filterConfigureFlags configFlags {+      configIPID = toFlag (display ipid),       configConfigurationsFlags = flags,       -- We generate the legacy constraints as well as the new style precise       -- deps.  In the end only one set gets passed to Setup.hs configure,@@ -364,12 +399,54 @@       -- Use '--exact-configuration' if supported.       configExactConfiguration = toFlag True,       configVerbosity          = toFlag verbosity,-      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas),+      -- NB: if the user explicitly specified+      -- --enable-tests/--enable-benchmarks, always respect it.+      -- (But if they didn't, let solver decide.)+      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas)+                                    `mappend` configBenchmarks configFlags,       configTests              = toFlag (TestStanzas `elem` stanzas)+                                    `mappend` configTests configFlags     } -    pkg = case finalizePackageDescription flags+    pkg = case finalizePD flags (enableStanzas stanzas)            (const True)-           platform comp [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ReadyPackage failed"+           platform comp [] gpkg of+      Left _ -> error "finalizePD ReadyPackage failed"       Right (desc, _) -> desc++-- -----------------------------------------------------------------------------+-- * Saved configure environments and flags+-- -----------------------------------------------------------------------------++-- | Read saved configure flags and restore the saved environment from the+-- specified files.+readConfigFlagsFrom :: FilePath  -- ^ path to saved flags file+                    -> IO (ConfigFlags, ConfigExFlags)+readConfigFlagsFrom flags = do+  readCommandFlags flags configureExCommand++-- | The path (relative to @--build-dir@) where the arguments to @configure@+-- should be saved.+cabalConfigFlagsFile :: FilePath -> FilePath+cabalConfigFlagsFile dist = dist </> "cabal-config-flags"++-- | Read saved configure flags and restore the saved environment from the+-- usual location.+readConfigFlags :: FilePath  -- ^ @--build-dir@+                -> IO (ConfigFlags, ConfigExFlags)+readConfigFlags dist =+  readConfigFlagsFrom (cabalConfigFlagsFile dist)++-- | Save the configure flags and environment to the specified files.+writeConfigFlagsTo :: FilePath  -- ^ path to saved flags file+                   -> Verbosity -> (ConfigFlags, ConfigExFlags)+                   -> IO ()+writeConfigFlagsTo file verb flags = do+  writeCommandFlags verb file configureExCommand flags++-- | Save the build flags to the usual location.+writeConfigFlags :: Verbosity+                 -> FilePath  -- ^ @--build-dir@+                 -> (ConfigFlags, ConfigExFlags) -> IO ()+writeConfigFlags verb dist =+  writeConfigFlagsTo (cabalConfigFlagsFile dist) verb
cabal/cabal-install/Distribution/Client/Dependency.hs view
@@ -23,13 +23,12 @@     resolveWithoutDependencies,      -- * Constructing resolver policies-    DepResolverParams(..),     PackageConstraint(..),     PackagesPreferenceDefault(..),     PackagePreference(..),-    InstalledPreference(..),      -- ** Standard policy+    basicInstallPolicy,     standardInstallPolicy,     PackageSpecifier(..), @@ -37,8 +36,6 @@     applySandboxInstallPolicy,      -- ** Extra policy options-    dontUpgradeNonUpgradeablePackages,-    hideBrokenInstalledPackages,     upgradeDependencies,     reinstallTargets, @@ -47,63 +44,49 @@     addPreferences,     setPreferenceDefault,     setReorderGoals,+    setCountConflicts,     setIndependentGoals,     setAvoidReinstalls,     setShadowPkgs,     setStrongFlags,     setMaxBackjumps,-    addSourcePackages,-    hideInstalledPackagesSpecificByUnitId,-    hideInstalledPackagesSpecificBySourcePackageId,-    hideInstalledPackagesAllVersions,+    setEnableBackjumping,+    setSolveExecutables,+    setGoalOrder,+    removeLowerBounds,     removeUpperBounds,     addDefaultSetupDependencies,   ) where -import Distribution.Client.Dependency.TopDown-         ( topDownResolver )-import Distribution.Client.Dependency.Modular+import Distribution.Solver.Modular          ( modularResolver, SolverConfig(..) )-import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.PkgConfigDb (PkgConfigDb)+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types-         ( SourcePackageDb(SourcePackageDb), SourcePackage(..)-         , ConfiguredPackage(..), ConfiguredId(..)-         , UnresolvedPkgLoc, UnresolvedSourcePackage-         , OptionalStanza(..), enableStanzas )+         ( SourcePackageDb(SourcePackageDb)+         , UnresolvedPkgLoc, UnresolvedSourcePackage ) import Distribution.Client.Dependency.Types-         ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)-         , PackageConstraint(..), showPackageConstraint-         , LabeledPackageConstraint(..), unlabelPackageConstraint-         , ConstraintSource(..), showConstraintSource-         , PackagePreferences(..), InstalledPreference(..)-         , PackagesPreferenceDefault(..)-         , Progress(..), foldProgress )+         ( PreSolver(..), Solver(..)+         , PackagesPreferenceDefault(..) ) import Distribution.Client.Sandbox.Types          ( SandboxPackageInfo(..) ) import Distribution.Client.Targets-import Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.ComponentDeps as CD-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId+         ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId          , Package(..), packageName, packageVersion-         , UnitId, Dependency(Dependency))+         , Dependency(Dependency)) import qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), SetupBuildInfo(..)-         , GenericPackageDescription(..)-         , Flag(flagName), FlagName(..) )+import qualified Distribution.PackageDescription.Configuration as PD import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )+         ( finalizePD ) import Distribution.Client.PackageUtils          ( externalBuildDepends ) import Distribution.Version-         ( VersionRange, anyVersion, thisVersion, withinRange-         , simplifyVersionRange )+         ( mkVersion, VersionRange, anyVersion, thisVersion, orLaterVersion+         , withinRange, simplifyVersionRange+         , removeLowerBound, removeUpperBound ) import Distribution.Compiler          ( CompilerInfo(..) ) import Distribution.System@@ -111,16 +94,37 @@ import Distribution.Client.Utils          ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils-         ( comparing, warn, info )+         ( comparing ) import Distribution.Simple.Configure          ( relaxPackageDeps ) import Distribution.Simple.Setup-         ( AllowNewer(..) )+         ( asBool, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Text          ( display ) import Distribution.Verbosity          ( Verbosity )+import qualified Distribution.Compat.Graph as Graph +import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.DependencyResolver+import           Distribution.Solver.Types.InstalledPreference+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageConstraint+import           Distribution.Solver.Types.PackagePath+import           Distribution.Solver.Types.PackagePreferences+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)+import           Distribution.Solver.Types.Progress+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.SourcePackage+import           Distribution.Solver.Types.Variable+ import Data.List          ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on)@@ -141,37 +145,48 @@ -- implemented in terms of adjustments to the parameters. -- data DepResolverParams = DepResolverParams {-       depResolverTargets           :: [PackageName],+       depResolverTargets           :: Set PackageName,        depResolverConstraints       :: [LabeledPackageConstraint],        depResolverPreferences       :: [PackagePreference],        depResolverPreferenceDefault :: PackagesPreferenceDefault,        depResolverInstalledPkgIndex :: InstalledPackageIndex,        depResolverSourcePkgIndex    :: PackageIndex.PackageIndex UnresolvedSourcePackage,-       depResolverReorderGoals      :: Bool,-       depResolverIndependentGoals  :: Bool,-       depResolverAvoidReinstalls   :: Bool,-       depResolverShadowPkgs        :: Bool,-       depResolverStrongFlags       :: Bool,-       depResolverMaxBackjumps      :: Maybe Int+       depResolverReorderGoals      :: ReorderGoals,+       depResolverCountConflicts    :: CountConflicts,+       depResolverIndependentGoals  :: IndependentGoals,+       depResolverAvoidReinstalls   :: AvoidReinstalls,+       depResolverShadowPkgs        :: ShadowPkgs,+       depResolverStrongFlags       :: StrongFlags,+       depResolverMaxBackjumps      :: Maybe Int,+       depResolverEnableBackjumping :: EnableBackjumping,+       -- | Whether or not to solve for dependencies on executables.+       -- This should be true, except in the legacy code path where+       -- we can't tell if an executable has been installed or not,+       -- so we shouldn't solve for them.  See #3875.+       depResolverSolveExecutables  :: SolveExecutables,++       -- | Function to override the solver's goal-ordering heuristics.+       depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering)      }  showDepResolverParams :: DepResolverParams -> String showDepResolverParams p =-     "targets: " ++ intercalate ", " (map display (depResolverTargets p))+     "targets: " ++ intercalate ", " (map display $ Set.toList (depResolverTargets p))   ++ "\nconstraints: "   ++   concatMap (("\n  " ++) . showLabeledConstraint)        (depResolverConstraints p)   ++ "\npreferences: "   ++   concatMap (("\n  " ++) . showPackagePreference)        (depResolverPreferences p)-  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault p)-  ++ "\nreorder goals: "     ++ show (depResolverReorderGoals      p)-  ++ "\nindependent goals: " ++ show (depResolverIndependentGoals  p)-  ++ "\navoid reinstalls: "  ++ show (depResolverAvoidReinstalls   p)-  ++ "\nshadow packages: "   ++ show (depResolverShadowPkgs        p)-  ++ "\nstrong flags: "      ++ show (depResolverStrongFlags       p)+  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault        p)+  ++ "\nreorder goals: "     ++ show (asBool (depResolverReorderGoals     p))+  ++ "\ncount conflicts: "   ++ show (asBool (depResolverCountConflicts   p))+  ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p))+  ++ "\navoid reinstalls: "  ++ show (asBool (depResolverAvoidReinstalls  p))+  ++ "\nshadow packages: "   ++ show (asBool (depResolverShadowPkgs       p))+  ++ "\nstrong flags: "      ++ show (asBool (depResolverStrongFlags      p))   ++ "\nmax backjumps: "     ++ maybe "infinite" show-                                     (depResolverMaxBackjumps      p)+                                     (depResolverMaxBackjumps             p)   where     showLabeledConstraint :: LabeledPackageConstraint -> String     showLabeledConstraint (LabeledPackageConstraint pc src) =@@ -212,25 +227,29 @@                        -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex =     DepResolverParams {-       depResolverTargets           = [],+       depResolverTargets           = Set.empty,        depResolverConstraints       = [],        depResolverPreferences       = [],        depResolverPreferenceDefault = PreferLatestForSelected,        depResolverInstalledPkgIndex = installedPkgIndex,        depResolverSourcePkgIndex    = sourcePkgIndex,-       depResolverReorderGoals      = False,-       depResolverIndependentGoals  = False,-       depResolverAvoidReinstalls   = False,-       depResolverShadowPkgs        = False,-       depResolverStrongFlags       = False,-       depResolverMaxBackjumps      = Nothing+       depResolverReorderGoals      = ReorderGoals False,+       depResolverCountConflicts    = CountConflicts True,+       depResolverIndependentGoals  = IndependentGoals False,+       depResolverAvoidReinstalls   = AvoidReinstalls False,+       depResolverShadowPkgs        = ShadowPkgs False,+       depResolverStrongFlags       = StrongFlags False,+       depResolverMaxBackjumps      = Nothing,+       depResolverEnableBackjumping = EnableBackjumping True,+       depResolverSolveExecutables  = SolveExecutables True,+       depResolverGoalOrder         = Nothing      }  addTargets :: [PackageName]            -> DepResolverParams -> DepResolverParams addTargets extraTargets params =     params {-      depResolverTargets = extraTargets ++ depResolverTargets params+      depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params     }  addConstraints :: [LabeledPackageConstraint]@@ -256,42 +275,68 @@       depResolverPreferenceDefault = preferenceDefault     } -setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams-setReorderGoals b params =+setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams+setReorderGoals reorder params =     params {-      depResolverReorderGoals = b+      depResolverReorderGoals = reorder     } -setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams-setIndependentGoals b params =+setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams+setCountConflicts count params =     params {-      depResolverIndependentGoals = b+      depResolverCountConflicts = count     } -setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams-setAvoidReinstalls b params =+setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams+setIndependentGoals indep params =     params {-      depResolverAvoidReinstalls = b+      depResolverIndependentGoals = indep     } -setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams-setShadowPkgs b params =+setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams+setAvoidReinstalls avoid params =     params {-      depResolverShadowPkgs = b+      depResolverAvoidReinstalls = avoid     } -setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams-setStrongFlags b params =+setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams+setShadowPkgs shadow params =     params {-      depResolverStrongFlags = b+      depResolverShadowPkgs = shadow     } +setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams+setStrongFlags sf params =+    params {+      depResolverStrongFlags = sf+    }+ setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params =     params {       depResolverMaxBackjumps = n     } +setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams+setEnableBackjumping b params =+    params {+      depResolverEnableBackjumping = b+    }++setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams+setSolveExecutables b params =+    params {+      depResolverSolveExecutables = b+    }++setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)+             -> DepResolverParams+             -> DepResolverParams+setGoalOrder order params =+    params {+      depResolverGoalOrder = order+    }+ -- | Some packages are specific to a given compiler version and should never be -- upgraded. dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams@@ -302,13 +347,11 @@       [ LabeledPackageConstraint         (PackageConstraintInstalled pkgname)         ConstraintSourceNonUpgradeablePackage-      | notElem (PackageName "base") (depResolverTargets params)-      , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"-                                   , "integer-simple" ]+      | Set.notMember (mkPackageName "base") (depResolverTargets params)+      , pkgname <- map mkPackageName [ "base", "ghc-prim", "integer-gmp"+                                     , "integer-simple" ]       , isInstalled pkgname ]-    -- TODO: the top down resolver chokes on the base constraints-    -- below when there are no targets and thus no dep on base.-    -- Need to refactor constraints separate from needing packages.+     isInstalled = not . null                 . InstalledPackageIndex.lookupPackageName                                  (depResolverInstalledPkgIndex params)@@ -322,17 +365,6 @@               (depResolverSourcePkgIndex params) pkgs     } -hideInstalledPackagesSpecificByUnitId :: [UnitId]-                                                     -> DepResolverParams-                                                     -> DepResolverParams-hideInstalledPackagesSpecificByUnitId pkgids params =-    --TODO: this should work using exclude constraints instead-    params {-      depResolverInstalledPkgIndex =-        foldl' (flip InstalledPackageIndex.deleteUnitId)-               (depResolverInstalledPkgIndex params) pkgids-    }- hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]                                                   -> DepResolverParams                                                   -> DepResolverParams@@ -355,17 +387,6 @@     }  -hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams-hideBrokenInstalledPackages params =-    hideInstalledPackagesSpecificByUnitId pkgids params-  where-    pkgids = map Installed.installedUnitId-           . InstalledPackageIndex.reverseDependencyClosure-                            (depResolverInstalledPkgIndex params)-           . map (Installed.installedUnitId . fst)-           . InstalledPackageIndex.brokenPackages-           $ depResolverInstalledPkgIndex params- -- | Remove upper bounds in dependencies using the policy specified by the -- 'AllowNewer' argument (all/some/none). --@@ -374,8 +395,8 @@ -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. -- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams-removeUpperBounds AllowNewerNone params = params-removeUpperBounds allowNewer     params =+removeUpperBounds (AllowNewer RelaxDepsNone) params = params+removeUpperBounds (AllowNewer allowNewer)    params =     params {       depResolverSourcePkgIndex = sourcePkgIndex'     }@@ -384,17 +405,33 @@      relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage     relaxDeps srcPkg = srcPkg {-      packageDescription = relaxPackageDeps allowNewer+      packageDescription = relaxPackageDeps removeUpperBound allowNewer                            (packageDescription srcPkg)       } +-- | Dual of 'removeUpperBounds'+removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams+removeLowerBounds (AllowOlder RelaxDepsNone) params = params+removeLowerBounds (AllowOlder allowNewer)    params =+    params {+      depResolverSourcePkgIndex = sourcePkgIndex'+    }+  where+    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params++    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage+    relaxDeps srcPkg = srcPkg {+      packageDescription = relaxPackageDeps removeLowerBound allowNewer+                           (packageDescription srcPkg)+      }+ -- | Supply defaults for packages without explicit Setup dependencies -- -- Note: It's important to apply 'addDefaultSetupDepends' after -- 'addSourcePackages'. Otherwise, the packages inserted by -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. ---addDefaultSetupDependencies :: (UnresolvedSourcePackage -> [Dependency])+addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency])                             -> DepResolverParams -> DepResolverParams addDefaultSetupDependencies defaultSetupDeps params =     params {@@ -410,9 +447,12 @@               PD.setupBuildInfo =                 case PD.setupBuildInfo pkgdesc of                   Just sbi -> Just sbi-                  Nothing  -> Just PD.SetupBuildInfo {-                                PD.setupDepends = defaultSetupDeps srcpkg-                              }+                  Nothing  -> case defaultSetupDeps srcpkg of+                    Nothing -> Nothing+                    Just deps -> Just PD.SetupBuildInfo {+                      PD.defaultSetupDepends = True,+                      PD.setupDepends        = deps+                    }             }           }         }@@ -427,14 +467,16 @@  reinstallTargets :: DepResolverParams -> DepResolverParams reinstallTargets params =-    hideInstalledPackagesAllVersions (depResolverTargets params) params+    hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params  -standardInstallPolicy :: InstalledPackageIndex-                      -> SourcePackageDb-                      -> [PackageSpecifier UnresolvedSourcePackage]-                      -> DepResolverParams-standardInstallPolicy+-- | A basic solver policy on which all others are built.+--+basicInstallPolicy :: InstalledPackageIndex+                   -> SourcePackageDb+                   -> [PackageSpecifier UnresolvedSourcePackage]+                   -> DepResolverParams+basicInstallPolicy     installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)     pkgSpecifiers @@ -457,6 +499,50 @@   $ basicDepResolverParams       installedPkgIndex sourcePkgIndex ++-- | The policy used by all the standard commands, install, fetch, freeze etc+-- (but not the new-build and related commands).+--+-- It extends the 'basicInstallPolicy' with a policy on setup deps.+--+standardInstallPolicy :: InstalledPackageIndex+                      -> SourcePackageDb+                      -> [PackageSpecifier UnresolvedSourcePackage]+                      -> DepResolverParams+standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers++  = addDefaultSetupDependencies mkDefaultSetupDeps++  $ basicInstallPolicy+      installedPkgIndex sourcePkgDb pkgSpecifiers++    where+      -- Force Cabal >= 1.24 dep when the package is affected by #3199.+      mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]+      mkDefaultSetupDeps srcpkg | affected        =+        Just [Dependency (mkPackageName "Cabal")+              (orLaterVersion $ mkVersion [1,24])]+                                | otherwise       = Nothing+        where+          gpkgdesc = packageDescription srcpkg+          pkgdesc  = PD.packageDescription gpkgdesc+          bt       = fromMaybe PD.Custom (PD.buildType pkgdesc)+          affected = bt == PD.Custom && hasBuildableFalse gpkgdesc++      -- Does this package contain any components with non-empty 'build-depends'+      -- and a 'buildable' field that could potentially be set to 'False'? False+      -- positives are possible.+      hasBuildableFalse :: PD.GenericPackageDescription -> Bool+      hasBuildableFalse gpkg =+        not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))+        where+          buildableConditions      = PD.extractConditions PD.buildable gpkg+          noDepConditions          = PD.extractConditions+                                     (null . PD.targetBuildDepends)    gpkg+          alwaysTrue (PD.Lit True) = True+          alwaysTrue _             = False++ applySandboxInstallPolicy :: SandboxPackageInfo                              -> DepResolverParams                              -> DepResolverParams@@ -502,19 +588,12 @@ -- ------------------------------------------------------------  chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver-chooseSolver verbosity preSolver _cinfo =+chooseSolver _verbosity preSolver _cinfo =     case preSolver of-      AlwaysTopDown -> do-        warn verbosity "Topdown solver is deprecated"-        return TopDown       AlwaysModular -> do         return Modular-      Choose -> do-        info verbosity "Choosing modular solver."-        return Modular  runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc-runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options runSolver Modular = modularResolver  -- | Run the dependency solver.@@ -528,11 +607,11 @@                     -> PkgConfigDb                     -> Solver                     -> DepResolverParams-                    -> Progress String String InstallPlan+                    -> Progress String String SolverInstallPlan      --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages resolveDependencies platform comp _pkgConfigDB _solver params-  | null (depResolverTargets params)+  | Set.null (depResolverTargets params)   = return (validateSolverResult platform comp indGoals [])   where     indGoals = depResolverIndependentGoals params@@ -541,8 +620,9 @@      Step (showDepResolverParams finalparams)   $ fmap (validateSolverResult platform comp indGoals)-  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls-                      shadowing strFlags maxBkjumps)+  $ runSolver solver (SolverConfig reordGoals cntConflicts+                      indGoals noReinstalls+                      shadowing strFlags maxBkjumps enableBj solveExes order)                      platform comp installedPkgIndex sourcePkgIndex                      pkgConfigDB preferences constraints targets   where@@ -552,23 +632,18 @@       prefs defpref       installedPkgIndex       sourcePkgIndex-      reorderGoals+      reordGoals+      cntConflicts       indGoals       noReinstalls       shadowing       strFlags-      maxBkjumps)     = dontUpgradeNonUpgradeablePackages-                      -- TODO:-                      -- The modular solver can properly deal with broken-                      -- packages and won't select them. So the-                      -- 'hideBrokenInstalledPackages' function should be moved-                      -- into a module that is specific to the top-down solver.-                      . (if solver /= Modular then hideBrokenInstalledPackages-                                              else id)-                      $ params+      maxBkjumps+      enableBj+      solveExes+      order) = dontUpgradeNonUpgradeablePackages params -    preferences = interpretPackagesPreference-                    (Set.fromList targets) defpref prefs+    preferences = interpretPackagesPreference targets defpref prefs   -- | Give an interpretation to the global 'PackagesPreference' as@@ -619,24 +694,21 @@ -- validateSolverResult :: Platform                      -> CompilerInfo-                     -> Bool+                     -> IndependentGoals                      -> [ResolverPackage UnresolvedPkgLoc]-                     -> InstallPlan+                     -> SolverInstallPlan validateSolverResult platform comp indepGoals pkgs =     case planPackagesProblems platform comp pkgs of-      [] -> case InstallPlan.new indepGoals index of+      [] -> case SolverInstallPlan.new indepGoals index of               Right plan     -> plan               Left  problems -> error (formatPlanProblems problems)       problems               -> error (formatPkgProblems problems)    where-    index = InstalledPackageIndex.fromList (map toPlanPackage pkgs)--    toPlanPackage (PreExisting pkg) = InstallPlan.PreExisting pkg-    toPlanPackage (Configured  pkg) = InstallPlan.Configured  pkg+    index = Graph.fromList pkgs      formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem-    formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem+    formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem      formatProblemMessage problems =       unlines $@@ -644,11 +716,11 @@       : "The proposed (invalid) plan contained the following problems:"       : problems       ++ "Proposed plan:"-      : [InstallPlan.showPlanIndex index]+      : [SolverInstallPlan.showPlanIndex index]   data PlanPackageProblem =-       InvalidConfiguredPackage (ConfiguredPackage UnresolvedPkgLoc) [PackageProblem]+       InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) [PackageProblem]  showPlanPackageProblem :: PlanPackageProblem -> String showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =@@ -675,14 +747,14 @@                     | InvalidDep    Dependency PackageId  showPackageProblem :: PackageProblem -> String-showPackageProblem (DuplicateFlag (PD.FlagName flag)) =-  "duplicate flag in the flag assignment: " ++ flag+showPackageProblem (DuplicateFlag flag) =+  "duplicate flag in the flag assignment: " ++ PD.unFlagName flag -showPackageProblem (MissingFlag (PD.FlagName flag)) =-  "missing an assignment for the flag: " ++ flag+showPackageProblem (MissingFlag flag) =+  "missing an assignment for the flag: " ++ PD.unFlagName flag -showPackageProblem (ExtraFlag (PD.FlagName flag)) =-  "extra flag given that is not used by the package: " ++ flag+showPackageProblem (ExtraFlag flag) =+  "extra flag given that is not used by the package: " ++ PD.unFlagName flag  showPackageProblem (DuplicateDeps pkgids) =      "duplicate packages specified as selected dependencies: "@@ -707,9 +779,9 @@ -- dependencies are satisfied by the specified packages. -- configuredPackageProblems :: Platform -> CompilerInfo-                          -> ConfiguredPackage UnresolvedPkgLoc -> [PackageProblem]+                          -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo-  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =+  (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') =      [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]   ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]@@ -720,9 +792,10 @@   ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]   ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps                             , not (packageSatisfiesDependency pkgid dep) ]+  -- TODO: sanity tests on executable deps   where     specifiedDeps :: ComponentDeps [PackageId]-    specifiedDeps = fmap (map confSrcId) specifiedDeps'+    specifiedDeps = fmap (map solverSrcId) specifiedDeps'      mergedFlags = mergeBy compare       (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))@@ -756,12 +829,13 @@     -- of the `nubOn` in `mergeDeps`.     requiredDeps :: [Dependency]     requiredDeps =-      --TODO: use something lower level than finalizePackageDescription-      case finalizePackageDescription specifiedFlags+      --TODO: use something lower level than finalizePD+      case finalizePD specifiedFlags+         (enableStanzas stanzas)          (const True)          platform cinfo          []-         (enableStanzas stanzas $ packageDescription pkg) of+         (packageDescription pkg) of         Right (resolvedPkg, _) ->              externalBuildDepends resolvedPkg           ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)@@ -791,9 +865,9 @@                            -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints                               prefs defpref installedPkgIndex sourcePkgIndex-                              _reorderGoals _indGoals _avoidReinstalls-                              _shadowing _strFlags _maxBjumps) =-    collectEithers (map selectPackage targets)+                              _reorderGoals _countConflicts _indGoals _avoidReinstalls+                              _shadowing _strFlags _maxBjumps _enableBj _solveExes _order) =+    collectEithers $ map selectPackage (Set.toList targets)   where     selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage     selectPackage pkgname@@ -831,8 +905,7 @@                       | PackageConstraintVersion name range <- pcs ]      packagePreferences :: PackageName -> PackagePreferences-    packagePreferences = interpretPackagesPreference-                           (Set.fromList targets) defpref prefs+    packagePreferences = interpretPackagesPreference targets defpref prefs   collectEithers :: [Either a b] -> Either [a] [b]
− cabal/cabal-install/Distribution/Client/Dependency/Modular.hs 
@@ -1,56 +0,0 @@-module Distribution.Client.Dependency.Modular-         ( modularResolver, SolverConfig(..)) where---- Here, we try to map between the external cabal-install solver--- interface and the internal interface that the solver actually--- expects. There are a number of type conversions to perform: we--- have to convert the package indices to the uniform index used--- by the solver; we also have to convert the initial constraints;--- and finally, we have to convert back the resulting install--- plan.--import Data.Map as M-         ( fromListWith )-import Distribution.Client.Dependency.Modular.Assignment-         ( toCPs )-import Distribution.Client.Dependency.Modular.ConfiguredConversion-         ( convCP )-import Distribution.Client.Dependency.Modular.IndexConversion-         ( convPIs )-import Distribution.Client.Dependency.Modular.Log-         ( logToProgress )-import Distribution.Client.Dependency.Modular.Package-         ( PN )-import Distribution.Client.Dependency.Modular.Solver-         ( SolverConfig(..), solve )-import Distribution.Client.Dependency.Types-         ( DependencyResolver-         , PackageConstraint(..), unlabelPackageConstraint )-import Distribution.System-         ( Platform(..) )---- | Ties the two worlds together: classic cabal-install vs. the modular--- solver. Performs the necessary translations before and after.-modularResolver :: SolverConfig -> DependencyResolver loc-modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =-  fmap (uncurry postprocess)      $ -- convert install plan-  logToProgress (maxBackjumps sc) $ -- convert log format into progress format-  solve sc cinfo idx pkgConfigDB pprefs gcs pns-    where-      -- Indices have to be converted into solver-specific uniform index.-      idx    = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx-      -- Constraints have to be converted into a finite map indexed by PN.-      gcs    = M.fromListWith (++) (map pair pcs)-        where-          pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])--      -- Results have to be converted into an install plan.-      postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)--      -- Helper function to extract the PN from a constraint.-      pcName :: PackageConstraint -> PN-      pcName (PackageConstraintVersion   pn _) = pn-      pcName (PackageConstraintInstalled pn  ) = pn-      pcName (PackageConstraintSource    pn  ) = pn-      pcName (PackageConstraintFlags     pn _) = pn-      pcName (PackageConstraintStanzas   pn _) = pn
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs 
@@ -1,150 +0,0 @@-module Distribution.Client.Dependency.Modular.Assignment-    ( Assignment(..)-    , FAssignment-    , SAssignment-    , PreAssignment(..)-    , extend-    , toCPs-    ) where--import Control.Applicative-import Control.Monad-import Data.Array as A-import Data.List as L-import Data.Map as M-import Data.Maybe-import Prelude hiding (pi)--import Language.Haskell.Extension (Extension, Language)--import Distribution.PackageDescription (FlagAssignment) -- from Cabal-import Distribution.Client.Types (OptionalStanza)-import Distribution.Client.Utils.LabeledGraph-import Distribution.Client.ComponentDeps (ComponentDeps, Component)-import qualified Distribution.Client.ComponentDeps as CD--import Distribution.Client.Dependency.Modular.Configured-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Version---- | A (partial) package assignment. Qualified package names--- are associated with instances.-type PAssignment    = Map QPN I---- | A (partial) package preassignment. Qualified package names--- are associated with constrained instances. Constrained instances--- record constraints about the instances that can still be chosen,--- and in the extreme case fix a concrete instance.-type PPreAssignment = Map QPN (CI QPN)-type FAssignment    = Map QFN Bool-type SAssignment    = Map QSN Bool---- | A (partial) assignment of variables.-data Assignment = A PAssignment FAssignment SAssignment-  deriving (Show, Eq)---- | A preassignment comprises knowledge about variables, but not--- necessarily fixed values.-data PreAssignment = PA PPreAssignment FAssignment SAssignment---- | Extend a package preassignment.------ Takes the variable that causes the new constraints, a current preassignment--- and a set of new dependency constraints.------ We're trying to extend the preassignment with each dependency one by one.--- Each dependency is for a particular variable. We check if we already have--- constraints for that variable in the current preassignment. If so, we're--- trying to merge the constraints.------ Either returns a witness of the conflict that would arise during the merge,--- or the successfully extended assignment.-extend :: (Extension -> Bool) -- ^ is a given extension supported-       -> (Language  -> Bool) -- ^ is a given language supported-       -> (PN -> VR  -> Bool) -- ^ is a given pkg-config requirement satisfiable-       -> Goal QPN-       -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment-extend extSupported langSupported pkgPresent goal@(Goal var _) = foldM extendSingle-  where--    extendSingle :: PPreAssignment -> Dep QPN-                 -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment-    extendSingle a (Ext  ext )  =-      if extSupported  ext  then Right a-                            else Left (toConflictSet goal, [Ext ext])-    extendSingle a (Lang lang)  =-      if langSupported lang then Right a-                            else Left (toConflictSet goal, [Lang lang])-    extendSingle a (Pkg pn vr)  =-      if pkgPresent pn vr then Right a-                          else Left (toConflictSet goal, [Pkg pn vr])-    extendSingle a (Dep qpn ci) =-      let ci' = M.findWithDefault (Constrained []) qpn a-      in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of-            Left (c, (d, d')) -> Left  (c, L.map (Dep qpn) (simplify (P qpn) d d'))-            Right x           -> Right x--    -- We're trying to remove trivial elements of the conflict. If we're just-    -- making a choice pkg == instance, and pkg => pkg == instance is a part-    -- of the conflict, then this info is clear from the context and does not-    -- have to be repeated.-    simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c]-    simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c]-    simplify _ c                       d                           = [c, d]---- | Delivers an ordered list of fully configured packages.------ TODO: This function is (sort of) ok. However, there's an open bug--- w.r.t. unqualification. There might be several different instances--- of one package version chosen by the solver, which will lead to--- clashes.-toCPs :: Assignment -> RevDepMap -> [CP QPN]-toCPs (A pa fa sa) rdm =-  let-    -- get hold of the graph-    g   :: Graph Component-    vm  :: Vertex -> ((), QPN, [(Component, QPN)])-    cvm :: QPN -> Maybe Vertex-    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.-    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))-                                  (M.toList rdm))-    tg :: Graph Component-    tg = transposeG g-    -- Topsort the dependency graph, yielding a list of pkgs in the right order.-    -- The graph will still contain all the installed packages, and it might-    -- contain duplicates, because several variables might actually resolve to-    -- the same package in the presence of qualified package names.-    ps :: [PI QPN]-    ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $-         topSort g-    -- Determine the flags per package, by walking over and regrouping the-    -- complete flag assignment by package.-    fapp :: Map QPN FlagAssignment-    fapp = M.fromListWith (++) $-           L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $-           M.toList $-           fa-    -- Stanzas per package.-    sapp :: Map QPN [OptionalStanza]-    sapp = M.fromListWith (++) $-           L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $-           M.toList $-           sa-    -- Dependencies per package.-    depp :: QPN -> [(Component, PI QPN)]-    depp qpn = let v :: Vertex-                   v   = fromJust (cvm qpn)-                   dvs :: [(Component, Vertex)]-                   dvs = tg A.! v-               in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs-    -- Translated to PackageDeps-    depp' :: QPN -> ComponentDeps [PI QPN]-    depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp-  in-    L.map (\ pi@(PI qpn _) -> CP pi-                                 (M.findWithDefault [] qpn fapp)-                                 (M.findWithDefault [] qpn sapp)-                                 (depp' qpn))-          ps
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs 
@@ -1,183 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Builder (buildTree) where---- Building the search tree.------ In this phase, we build a search tree that is too large, i.e, it contains--- invalid solutions. We keep track of the open goals at each point. We--- nondeterministically pick an open goal (via a goal choice node), create--- subtrees according to the index and the available solutions, and extend the--- set of open goals by superficially looking at the dependencies recorded in--- the index.------ For each goal, we keep track of all the *reasons* why it is being--- introduced. These are for debugging and error messages, mainly. A little bit--- of care has to be taken due to the way we treat flags. If a package has--- flag-guarded dependencies, we cannot introduce them immediately. Instead, we--- store the entire dependency.--import Data.List as L-import Data.Map as M-import Prelude hiding (sequence, mapM)--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ (PSQ)-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Tree--import Distribution.Client.ComponentDeps (Component)---- | The state needed during the build phase of the search tree.-data BuildState = BS {-  index :: Index,                -- ^ information about packages and their dependencies-  rdeps :: RevDepMap,            -- ^ set of all package goals, completed and open, with reverse dependencies-  open  :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals)-  next  :: BuildType,            -- ^ kind of node to generate next-  qualifyOptions :: QualifyOptions -- ^ qualification options-}---- | Extend the set of open goals with the new goals listed.------ We also adjust the map of overall goals, and keep track of the--- reverse dependencies of each of the goals.-extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState-extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs-  where-    go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState-    go g o []                                               = s { rdeps = g, open = o }-    go g o (ng@(OpenGoal (Flagged _ _ _ _)      _gr) : ngs) = go g (cons' ng () o) ngs-      -- Note: for 'Flagged' goals, we always insert, so later additions win.-      -- This is important, because in general, if a goal is inserted twice,-      -- the later addition will have better dependency information.-    go g o (ng@(OpenGoal (Stanza  _   _  )      _gr) : ngs) = go g (cons' ng () o) ngs-    go g o (ng@(OpenGoal (Simple (Dep qpn _) c) _gr) : ngs)-      | qpn == qpn'       = go                            g               o  ngs-          -- we ignore self-dependencies at this point; TODO: more care may be needed-      | qpn `M.member` g  = go (M.adjust ((c, qpn'):) qpn g)              o  ngs-      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (cons' ng () o) ngs-          -- code above is correct; insert/adjust have different arg order-    go g o (   (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs-    go g o (   (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs-    go g o (   (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs--    cons' = P.cons . forgetCompOpenGoal---- | Given the current scope, qualify all the package names in the given set of--- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->-                    BuildState -> BuildState-scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s-  where-    -- Qualify all package names-    qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps-    -- Introduce all package flags-    qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs-    -- Combine new package and flag goals-    gs     = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps)-    -- NOTE:-    ---    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially-    -- multiple times, both via the flag declaration and via dependencies.-    -- The order is potentially important, because the occurrences via-    -- dependencies may record flag-dependency information. After a number-    -- of bugs involving computing this information incorrectly, however,-    -- we're currently not using carefully computed inter-flag dependencies-    -- anymore, but instead use 'simplifyVar' when computing conflict sets-    -- to map all flags of one package to a single flag for conflict set-    -- purposes, thereby treating them all as interdependent.-    ---    -- If we ever move to a more clever algorithm again, then the line above-    -- needs to be looked at very carefully, and probably be replaced by-    -- more systematically computed flag dependency information.---- | Datatype that encodes what to build next-data BuildType =-    Goals                                  -- ^ build a goal choice node-  | OneGoal (OpenGoal ())                  -- ^ build a node for this goal-  | Instance QPN I PInfo QGoalReasonChain  -- ^ build a tree for a concrete instance-  deriving Show--build :: BuildState -> Tree QGoalReasonChain-build = ana go-  where-    go :: BuildState -> TreeF QGoalReasonChain BuildState--    -- If we have a choice between many goals, we just record the choice in-    -- the tree. We select each open goal in turn, and before we descend, remove-    -- it from the queue of open goals.-    go bs@(BS { rdeps = rds, open = gs, next = Goals })-      | P.null gs = DoneF rds-      | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })-                                              (P.splits gs))--    -- If we have already picked a goal, then the choice depends on the kind-    -- of goal.-    ---    -- For a package, we look up the instances available in the global info,-    -- and then handle each instance in turn.-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =-      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Ext goal"-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =-      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Lang goal"-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =-      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Pkg goal"-    go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) =-      case M.lookup pn idx of-        Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)-        Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->-                                                           (POption i Nothing, bs { next = Instance qpn i info gr }))-                                                         (M.toList pis)))-          -- TODO: data structure conversion is rather ugly here--    -- For a flag, we create only two subtrees, and we create them in the order-    -- that is indicated by the flag default.-    ---    -- TODO: Should we include the flag default in the tree?-    go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =-      FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b-        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),-         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))-      where-        reorder True  = id-        reorder False = reverse-        trivial = L.null t && L.null f--    -- For a stanza, we also create only two subtrees. The order is initially-    -- False, True. This can be changed later by constraints (force enabling-    -- the stanza by replacing the False branch with failure) or preferences-    -- (try enabling the stanza if possible by moving the True branch first).--    go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =-      SChoiceF qsn gr trivial (P.fromList-        [(False,                                                                  bs  { next = Goals }),-         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])-      where-        trivial = L.null t--    -- For a particular instance, we change the state: we update the scope,-    -- and furthermore we update the set of goals.-    ---    -- TODO: We could inline this above.-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) gr }) =-      go ((scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)-             { next = Goals })---- | Interface to the tree builder. Just takes an index and a list of package names,--- and computes the initial state and then the tree from there.-buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain-buildTree idx ind igs =-    build BS {-        index = idx-      , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)-      , open  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)-      , next  = Goals-      , qualifyOptions = defaultQualifyOptions idx-      }-  where-    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]--    qpns | ind       = makeIndependent igs-         | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs 
@@ -1,13 +0,0 @@-module Distribution.Client.Dependency.Modular.Configured-    ( CP(..)-    ) where--import Distribution.PackageDescription (FlagAssignment) -- from Cabal-import Distribution.Client.Types (OptionalStanza)-import Distribution.Client.ComponentDeps (ComponentDeps)--import Distribution.Client.Dependency.Modular.Package---- | A configured package is a package instance together with--- a flag assignment and complete dependencies.-data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])
− cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs 
@@ -1,54 +0,0 @@-module Distribution.Client.Dependency.Modular.ConfiguredConversion-    ( convCP-    ) where--import Data.Maybe-import Prelude hiding (pi)--import Distribution.Package (UnitId)--import Distribution.Client.Types-import Distribution.Client.Dependency.Types (ResolverPackage(..))-import qualified Distribution.Client.PackageIndex as CI-import qualified Distribution.Simple.PackageIndex as SI--import Distribution.Client.Dependency.Modular.Configured-import Distribution.Client.Dependency.Modular.Package--import Distribution.Client.ComponentDeps (ComponentDeps)---- | Converts from the solver specific result @CP QPN@ into--- a 'ResolverPackage', which can then be converted into--- the install plan.-convCP :: SI.InstalledPackageIndex ->-          CI.PackageIndex (SourcePackage loc) ->-          CP QPN -> ResolverPackage loc-convCP iidx sidx (CP qpi fa es ds) =-  case convPI qpi of-    Left  pi -> PreExisting-                  (fromJust $ SI.lookupUnitId iidx pi)-    Right pi -> Configured $ ConfiguredPackage-                  srcpkg-                  fa-                  es-                  ds'-      where-        Just srcpkg = CI.lookupPackageId sidx pi-  where-    ds' :: ComponentDeps [ConfiguredId]-    ds' = fmap (map convConfId) ds--convPI :: PI QPN -> Either UnitId PackageId-convPI (PI _ (I _ (Inst pi))) = Left pi-convPI qpi                    = Right $ confSrcId $ convConfId qpi--convConfId :: PI QPN -> ConfiguredId-convConfId (PI (Q _ pn) (I v loc)) = ConfiguredId {-      confSrcId  = sourceId-    , confInstId = installedId-    }-  where-    sourceId    = PackageIdentifier pn v-    installedId = case loc of-                    Inst pi    -> pi-                    _otherwise -> fakeUnitId sourceId
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Cycles.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Cycles (-    detectCyclesPhase-  ) where--import Prelude hiding (cycle)-import Control.Monad-import Control.Monad.Reader-import Data.Graph (SCC)-import Data.Set   (Set)-import qualified Data.Graph       as Gr-import qualified Data.Map         as Map-import qualified Data.Set         as Set-import qualified Data.Traversable as T--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree--type DetectCycles = Reader (ConflictSet QPN)---- | Find and reject any solutions that are cyclic-detectCyclesPhase :: Tree QGoalReasonChain -> Tree QGoalReasonChain-detectCyclesPhase = (`runReader` Set.empty) .  cata go-  where-    -- Most cases are simple; we just need to remember which choices we made-    go :: TreeF QGoalReasonChain (DetectCycles (Tree QGoalReasonChain)) -> DetectCycles (Tree QGoalReasonChain)-    go (PChoiceF qpn gr     cs) = PChoice qpn gr     <$> local (extendConflictSet $ P qpn) (T.sequence cs)-    go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m <$> local (extendConflictSet $ F qfn) (T.sequence cs)-    go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   <$> local (extendConflictSet $ S qsn) (T.sequence cs)-    go (GoalChoiceF         cs) = GoalChoice         <$>                                   (T.sequence cs)-    go (FailF cs reason)        = return $ Fail cs reason--    -- We check for cycles only if we have actually found a solution-    -- This minimizes the number of cycle checks we do as cycles are rare-    go (DoneF revDeps) = do-      fullSet <- ask-      return $ case findCycles fullSet revDeps of-        Nothing     -> Done revDeps-        Just relSet -> Fail relSet CyclicDependencies---- | Given the reverse dependency map from a 'Done' node in the tree, as well--- as the full conflict set containing all decisions that led to that 'Done'--- node, check if the solution is cyclic. If it is, return the conflict set--- containing all decisions that could potentially break the cycle.-findCycles :: ConflictSet QPN -> RevDepMap -> Maybe (ConflictSet QPN)-findCycles fullSet revDeps = do-    guard $ not (null cycles)-    return $ relevantConflictSet (Set.fromList (concat cycles)) fullSet-  where-    cycles :: [[QPN]]-    cycles = [vs | Gr.CyclicSCC vs <- scc]--    scc :: [SCC QPN]-    scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps--    aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN])-    aux (fr, to) = (fr, fr, map snd to)---- | Construct the relevant conflict set given the full conflict set that--- lead to this decision and the set of packages involved in the cycle-relevantConflictSet :: Set QPN -> ConflictSet QPN -> ConflictSet QPN-relevantConflictSet cycle = Set.filter isRelevant-  where-    isRelevant :: Var QPN -> Bool-    isRelevant (P qpn)                  = qpn `Set.member` cycle-    isRelevant (F (FN (PI qpn _i) _fn)) = qpn `Set.member` cycle-    isRelevant (S (SN (PI qpn _i) _sn)) = qpn `Set.member` cycle
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs 
@@ -1,413 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecordWildCards #-}-module Distribution.Client.Dependency.Modular.Dependency (-    -- * Variables-    Var(..)-  , simplifyVar-  , varPI-    -- * Conflict sets-  , ConflictSet-  , showCS-    -- * Constrained instances-  , CI(..)-  , merge-    -- * Flagged dependencies-  , FlaggedDeps-  , FlaggedDep(..)-  , Dep(..)-  , showDep-  , flattenFlaggedDeps-  , QualifyOptions(..)-  , qualifyDeps-    -- ** Setting/forgetting components-  , forgetCompOpenGoal-  , setCompFlaggedDeps-    -- * Reverse dependency map-  , RevDepMap-    -- * Goals-  , Goal(..)-  , GoalReason(..)-  , QGoalReasonChain-  , ResetGoal(..)-  , toConflictSet-  , extendConflictSet-    -- * Open goals-  , OpenGoal(..)-  , close-  ) where--import Prelude hiding (pi)--import Data.List (intercalate)-import Data.Map (Map)-import Data.Set (Set)-import qualified Data.List as L-import qualified Data.Set  as S--import Language.Haskell.Extension (Extension(..), Language(..))--import Distribution.Text--import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Version--import Distribution.Client.ComponentDeps (Component(..))--{--------------------------------------------------------------------------------  Variables--------------------------------------------------------------------------------}---- | The type of variables that play a role in the solver.--- Note that the tree currently does not use this type directly,--- and rather has separate tree nodes for the different types of--- variables. This fits better with the fact that in most cases,--- these have to be treated differently.------ TODO: This isn't the ideal location to declare the type,--- but we need them for constrained instances.-data Var qpn = P qpn | F (FN qpn) | S (SN qpn)-  deriving (Eq, Ord, Show, Functor)---- | For computing conflict sets, we map flag choice vars to a--- single flag choice. This means that all flag choices are treated--- as interdependent. So if one flag of a package ends up in a--- conflict set, then all flags are being treated as being part of--- the conflict set.-simplifyVar :: Var qpn -> Var qpn-simplifyVar (P qpn)       = P qpn-simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))-simplifyVar (S qsn)       = S qsn--showVar :: Var QPN -> String-showVar (P qpn) = showQPN qpn-showVar (F qfn) = showQFN qfn-showVar (S qsn) = showQSN qsn---- | Extract the package instance from a Var-varPI :: Var QPN -> (QPN, Maybe I)-varPI (P qpn)               = (qpn, Nothing)-varPI (F (FN (PI qpn i) _)) = (qpn, Just i)-varPI (S (SN (PI qpn i) _)) = (qpn, Just i)--{--------------------------------------------------------------------------------  Conflict sets--------------------------------------------------------------------------------}--type ConflictSet qpn = Set (Var qpn)--showCS :: ConflictSet QPN -> String-showCS = intercalate ", " . L.map showVar . S.toList--{--------------------------------------------------------------------------------  Constrained instances--------------------------------------------------------------------------------}---- | Constrained instance. If the choice has already been made, this is--- a fixed instance, and we record the package name for which the choice--- is for convenience. Otherwise, it is a list of version ranges paired with--- the goals / variables that introduced them.-data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn]-  deriving (Eq, Show, Functor)--showCI :: CI QPN -> String-showCI (Fixed i _)      = "==" ++ showI i-showCI (Constrained vr) = showVR (collapse vr)---- | Merge constrained instances. We currently adopt a lazy strategy for--- merging, i.e., we only perform actual checking if one of the two choices--- is fixed. If the merge fails, we return a conflict set indicating the--- variables responsible for the failure, as well as the two conflicting--- fragments.------ Note that while there may be more than one conflicting pair of version--- ranges, we only return the first we find.------ TODO: Different pairs might have different conflict sets. We're--- obviously interested to return a conflict that has a "better" conflict--- set in the sense the it contains variables that allow us to backjump--- further. We might apply some heuristics here, such as to change the--- order in which we check the constraints.-merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)-merge c@(Fixed i g1)       d@(Fixed j g2)-  | i == j                                    = Right c-  | otherwise                                 = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d))-merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...-  where-    go []              = Right c-    go (d@(vr, g2) : vrs)-      | checkVR vr v   = go vrs-      | otherwise      = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))-merge c@(Constrained _)    d@(Fixed _ _)      = merge d c-merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))--{--------------------------------------------------------------------------------  Flagged dependencies--------------------------------------------------------------------------------}---- | Flagged dependencies------ 'FlaggedDeps' is the modular solver's view of a packages dependencies:--- rather than having the dependencies indexed by component, each dependency--- defines what component it is in.------ However, top-level goals are also modelled as dependencies, but of course--- these don't actually belong in any component of any package. Therefore, we--- parameterize 'FlaggedDeps' and derived datatypes with a type argument that--- specifies whether or not we have a component: we only ever instantiate this--- type argument with @()@ for top-level goals, or 'Component' for everything--- else (we could express this as a kind at the type-level, but that would--- require a very recent GHC).------ Note however, crucially, that independent of the type parameters, the list--- of dependencies underneath a flag choice or stanza choices _always_ uses--- Component as the type argument. This is important: when we pick a value for--- a flag, we _must_ know what component the new dependencies belong to, or--- else we don't be able to construct fine-grained reverse dependencies.-type FlaggedDeps comp qpn = [FlaggedDep comp qpn]---- | Flagged dependencies can either be plain dependency constraints,--- or flag-dependent dependency trees.-data FlaggedDep comp qpn =-    -- | Dependencies which are conditional on a flag choice.-    Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)-    -- | Dependencies which are conditional on whether or not a stanza-    -- (e.g., a test suite or benchmark) is enabled.-  | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)-    -- | Dependencies for which are always enabled, for the component-    -- 'comp' (or requested for the user, if comp is @()@).-  | Simple (Dep qpn) comp-  deriving (Eq, Show)---- | Conversatively flatten out flagged dependencies------ NOTE: We do not filter out duplicates.-flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)]-flattenFlaggedDeps = concatMap aux-  where-    aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)]-    aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f-    aux (Stanza  _   t)   = flattenFlaggedDeps t-    aux (Simple d c)      = [(d, c)]--type TrueFlaggedDeps  qpn = FlaggedDeps Component qpn-type FalseFlaggedDeps qpn = FlaggedDeps Component qpn---- | A dependency (constraint) associates a package name with a--- constrained instance.------ 'Dep' intentionally has no 'Functor' instance because the type variable--- is used both to record the dependencies as well as who's doing the--- depending; having a 'Functor' instance makes bugs where we don't distinguish--- these two far too likely. (By rights 'Dep' ought to have two type variables.)-data Dep qpn = Dep  qpn (CI qpn)  -- dependency on a package-             | Ext  Extension     -- dependency on a language extension-             | Lang Language      -- dependency on a language version-             | Pkg  PN VR         -- dependency on a pkg-config package-  deriving (Eq, Show)--showDep :: Dep QPN -> String-showDep (Dep qpn (Fixed i (Goal v _))          ) =-  (if P qpn /= v then showVar v ++ " => " else "") ++-  showQPN qpn ++ "==" ++ showI i-showDep (Dep qpn (Constrained [(vr, Goal v _)])) =-  showVar v ++ " => " ++ showQPN qpn ++ showVR vr-showDep (Dep qpn ci                            ) =-  showQPN qpn ++ showCI ci-showDep (Ext ext)   = "requires " ++ display ext-showDep (Lang lang) = "requires " ++ display lang-showDep (Pkg pn vr) = "requires pkg-config package "-                      ++ display pn ++ display vr-                      ++ ", not found in the pkg-config database"---- | Options for goal qualification (used in 'qualifyDeps')------ See also 'defaultQualifyOptions'-data QualifyOptions = QO {-    -- | Do we have a version of base relying on another version of base?-    qoBaseShim :: Bool--    -- Should dependencies of the setup script be treated as independent?-  , qoSetupIndependent :: Bool-  }-  deriving Show---- | Apply built-in rules for package qualifiers------ NOTE: It's the _dependencies_ of a package that may or may not be independent--- from the package itself. Package flag choices must of course be consistent.-qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN-qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go-  where-    go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN-    go = map go1--    go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN-    go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)-    go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)-    go1 (Simple dep comp)    = Simple (goD dep comp) comp--    -- Suppose package B has a setup dependency on package A.-    -- This will be recorded as something like-    ---    -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason])-    ---    -- Observe that when we qualify this dependency, we need to turn that-    -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier-    -- to the goal or the goal reason chain.-    goD :: Dep PN -> Component -> Dep QPN-    goD (Ext  ext)    _    = Ext  ext-    goD (Lang lang)   _    = Lang lang-    goD (Pkg pkn vr)  _    = Pkg pkn vr-    goD (Dep  dep ci) comp-      | qBase  dep  = Dep (Q (PP ns (Base  pn)) dep) (fmap (Q pp) ci)-      | qSetup comp = Dep (Q (PP ns (Setup pn)) dep) (fmap (Q pp) ci)-      | otherwise   = Dep (Q (PP ns inheritedQ) dep) (fmap (Q pp) ci)--    -- If P has a setup dependency on Q, and Q has a regular dependency on R, then-    -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup-    -- dependency on R. We do not do this for the base qualifier however.-    ---    -- The inherited qualifier is only used for regular dependencies; for setup-    -- and base deppendencies we override the existing qualifier. See #3160 for-    -- a detailed discussion.-    inheritedQ :: Qualifier-    inheritedQ = case q of-                   Setup _     -> q-                   Unqualified -> q-                   Base _      -> Unqualified--    -- Should we qualify this goal with the 'Base' package path?-    qBase :: PN -> Bool-    qBase dep = qoBaseShim && unPackageName dep == "base"--    -- Should we qualify this goal with the 'Setup' package path?-    qSetup :: Component -> Bool-    qSetup comp = qoSetupIndependent && comp == ComponentSetup--{--------------------------------------------------------------------------------  Setting/forgetting the Component--------------------------------------------------------------------------------}--forgetCompOpenGoal :: OpenGoal Component -> OpenGoal ()-forgetCompOpenGoal = mapCompOpenGoal $ const ()--setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn-setCompFlaggedDeps = mapCompFlaggedDeps . const--{--------------------------------------------------------------------------------  Auxiliary: Mapping over the Component goal--  We don't export these, because the only type instantiations for 'a' and 'b'-  here should be () or Component. (We could express this at the type level-  if we relied on newer versions of GHC.)--------------------------------------------------------------------------------}--mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b-mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr--mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn-mapCompFlaggedDeps = L.map . mapCompFlaggedDep--mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn-mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo   t f-mapCompFlaggedDep _ (Stanza  sn     t  ) = Stanza  sn       t-mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)--{--------------------------------------------------------------------------------  Reverse dependency map--------------------------------------------------------------------------------}---- | A map containing reverse dependencies between qualified--- package names.-type RevDepMap = Map QPN [(Component, QPN)]--{--------------------------------------------------------------------------------  Goals--------------------------------------------------------------------------------}---- | Goals are solver variables paired with information about--- why they have been introduced.-data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn)-  deriving (Eq, Show, Functor)---- | Reasons why a goal can be added to a goal set.-data GoalReason qpn =-    UserGoal-  | PDependency (PI qpn)-  | FDependency (FN qpn) Bool-  | SDependency (SN qpn)-  deriving (Eq, Show, Functor)---- | The first element is the immediate reason. The rest are the reasons--- for the reasons ...-type GoalReasonChain qpn = [GoalReason qpn]--type QGoalReasonChain = GoalReasonChain QPN--class ResetGoal f where-  resetGoal :: Goal qpn -> f qpn -> f qpn--instance ResetGoal CI where-  resetGoal g (Fixed i _)       = Fixed i g-  resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)--instance ResetGoal Dep where-  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)-  resetGoal _ (Ext ext)    = Ext ext-  resetGoal _ (Lang lang)  = Lang lang-  resetGoal _ (Pkg pn vr)  = Pkg pn vr--instance ResetGoal Goal where-  resetGoal = const---- | Compute a conflict set from a goal. The conflict set contains the closure--- of goal reasons as well as the variable of the goal itself.-toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn-toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)---- | Add another variable into a conflict set-extendConflictSet :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn-extendConflictSet = S.insert . simplifyVar--goalReasonToVars :: GoalReason qpn -> ConflictSet qpn-goalReasonToVars UserGoal                 = S.empty-goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)-goalReasonToVars (FDependency qfn _)      = S.singleton (simplifyVar (F qfn))-goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)--goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn-goalReasonChainToVars = S.unions . L.map goalReasonToVars--{--------------------------------------------------------------------------------  Open goals--------------------------------------------------------------------------------}---- | For open goals as they occur during the build phase, we need to store--- additional information about flags.-data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReasonChain-  deriving (Eq, Show)---- | Closes a goal, i.e., removes all the extraneous information that we--- need only during the build phase.-close :: OpenGoal comp -> Goal QPN-close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr-close (OpenGoal (Simple (Ext     _) _) _ ) =-  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Ext goal"-close (OpenGoal (Simple (Lang    _) _) _ ) =-  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Lang goal"-close (OpenGoal (Simple (Pkg   _ _) _) _ ) =-  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Pkg goal"-close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr-close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr--{--------------------------------------------------------------------------------  Version ranges paired with origins--------------------------------------------------------------------------------}--type VROrigin qpn = (VR, Goal qpn)---- | Helper function to collapse a list of version ranges with origins into--- a single, simplified, version range.-collapse :: [VROrigin qpn] -> VR-collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs 
@@ -1,88 +0,0 @@-module Distribution.Client.Dependency.Modular.Explore-    ( backjump-    , backjumpAndExplore-    ) where--import Data.Foldable as F-import Data.Map as M-import Data.Set as S--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Log-import Distribution.Client.Dependency.Modular.Message-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Tree-import qualified Distribution.Client.Dependency.Types as T---- | This function takes the variable we're currently considering and a--- list of children's logs. Each log yields either a solution or a--- conflict set. The result is a combined log for the parent node that--- has explored a prefix of the children.------ We can stop traversing the children's logs if we find an individual--- conflict set that does not contain the current variable. In this--- case, we can just lift the conflict set to the current level,--- because the current level cannot possibly have contributed to this--- conflict, so no other choice at the current level would avoid the--- conflict.------ If any of the children might contain a successful solution, we can--- return it immediately. If all children contain conflict sets, we can--- take the union as the combined conflict set.-backjump :: F.Foldable t => Var QPN -> t (ConflictSetLog a) -> ConflictSetLog a-backjump var xs = F.foldr combine logBackjump xs S.empty-  where-    combine :: ConflictSetLog a-            -> (ConflictSet QPN -> ConflictSetLog a)-            ->  ConflictSet QPN -> ConflictSetLog a-    combine (T.Done x)    _ _               = T.Done x-    combine (T.Fail cs)   f csAcc-      | not (simplifyVar var `S.member` cs) = logBackjump cs-      | otherwise                           = f (csAcc `S.union` cs)-    combine (T.Step m ms) f cs              = T.Step m (combine ms f cs)--    logBackjump :: ConflictSet QPN -> ConflictSetLog a-    logBackjump cs = failWith (Failure cs Backjump) cs--type ConflictSetLog = T.Progress Message (ConflictSet QPN)---- | A tree traversal that simultaneously propagates conflict sets up--- the tree from the leaves and creates a log.-exploreLog :: Tree a -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))-exploreLog = cata go-  where-    go :: TreeF a (Assignment -> ConflictSetLog (Assignment, RevDepMap))-               -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))-    go (FailF c fr)          _           = failWith (Failure c fr) c-    go (DoneF rdm)           a           = succeedWith Success (a, rdm)-    go (PChoiceF qpn _     ts) (A pa fa sa)   =-      backjump (P qpn) $                          -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ...-                    r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice-      ts-    go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =-      backjump (F qfn) $                          -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> tryWith (TryF qfn k) $          -- log and ...-                    r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice-      ts-    go (SChoiceF qsn _ _   ts) (A pa fa sa)   =-      backjump (S qsn) $                          -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> tryWith (TryS qsn k) $          -- log and ...-                    r (A pa fa (M.insert qsn k sa))) -- record the pkg choice-      ts-    go (GoalChoiceF        ts) a           =-      P.casePSQ ts-        (failWith (Failure S.empty EmptyGoalChoice) S.empty) -- empty goal choice is an internal error-        (\ k v _xs -> continueWith (Next (close k)) (v a))   -- commit to the first goal choice---- | Interface.-backjumpAndExplore :: Tree a -> Log Message (Assignment, RevDepMap)-backjumpAndExplore t = toLog $ exploreLog t (A M.empty M.empty M.empty)-  where-    toLog :: T.Progress step fail done -> Log step done-    toLog = T.foldProgress T.Step (const (T.Fail ())) T.Done
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Flag-    ( FInfo(..)-    , Flag-    , FlagInfo-    , FN(..)-    , QFN-    , QSN-    , SN(..)-    , mkFlag-    , showFBool-    , showQFN-    , showQFNBool-    , showQSN-    , showQSNBool-    ) where--import Data.Map as M-import Prelude hiding (pi)--import Distribution.PackageDescription hiding (Flag) -- from Cabal--import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Types (OptionalStanza(..))---- | Flag name. Consists of a package instance and the flag identifier itself.-data FN qpn = FN (PI qpn) Flag-  deriving (Eq, Ord, Show, Functor)---- | Flag identifier. Just a string.-type Flag = FlagName--unFlag :: Flag -> String-unFlag (FlagName fn) = fn--mkFlag :: String -> Flag-mkFlag fn = FlagName fn---- | Flag info. Default value, whether the flag is manual, and--- whether the flag is weak. Manual flags can only be set explicitly.--- Weak flags are typically deferred by the solver.-data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: Bool }-  deriving (Eq, Ord, Show)---- | Flag defaults.-type FlagInfo = Map Flag FInfo---- | Qualified flag name.-type QFN = FN QPN---- | Stanza name. Paired with a package name, much like a flag.-data SN qpn = SN (PI qpn) OptionalStanza-  deriving (Eq, Ord, Show, Functor)---- | Qualified stanza name.-type QSN = SN QPN--unStanza :: OptionalStanza -> String-unStanza TestStanzas  = "test"-unStanza BenchStanzas = "bench"--showQFNBool :: QFN -> Bool -> String-showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b--showQSNBool :: QSN -> Bool -> String-showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b--showFBool :: FN qpn -> Bool -> String-showFBool (FN _ f) True  = "+" ++ unFlag f-showFBool (FN _ f) False = "-" ++ unFlag f--showSBool :: SN qpn -> Bool -> String-showSBool (SN _ s) True  = "*" ++ unStanza s-showSBool (SN _ s) False = "!" ++ unStanza s--showQFN :: QFN -> String-showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f--showQSN :: QSN -> String-showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs 
@@ -1,52 +0,0 @@-module Distribution.Client.Dependency.Modular.Index-    ( Index-    , PInfo(..)-    , defaultQualifyOptions-    , mkIndex-    ) where--import Data.List as L-import Data.Map as M-import Prelude hiding (pi)--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree--import Distribution.Client.ComponentDeps (Component)---- | An index contains information about package instances. This is a nested--- dictionary. Package names are mapped to instances, which in turn is mapped--- to info.-type Index = Map PN (Map I PInfo)---- | Info associated with a package instance.--- Currently, dependencies, flags and failure reasons.--- Packages that have a failure reason recorded for them are disabled--- globally, for reasons external to the solver. We currently use this--- for shadowing which essentially is a GHC limitation, and for--- installed packages that are broken.-data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason)-  deriving (Show)--mkIndex :: [(PN, I, PInfo)] -> Index-mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))--groupMap :: Ord a => [(a, b)] -> Map a [b]-groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)--defaultQualifyOptions :: Index -> QualifyOptions-defaultQualifyOptions idx = QO {-      qoBaseShim         = or [ dep == base-                              | -- Find all versions of base ..-                                Just is <- [M.lookup base idx]-                                -- .. which are installed ..-                              , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is-                                -- .. and flatten all their dependencies ..-                              , (Dep dep _ci, _comp) <- flattenFlaggedDeps deps-                              ]-    , qoSetupIndependent = True-    }-  where-    base = PackageName "base"
− cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs 
@@ -1,316 +0,0 @@-module Distribution.Client.Dependency.Modular.IndexConversion-    ( convPIs-    ) where--import Data.List as L-import Data.Map as M-import Data.Maybe-import Data.Monoid as Mon-import Data.Set as S-import Prelude hiding (pi)--import qualified Distribution.Client.PackageIndex as CI-import Distribution.Client.Types-import Distribution.Client.ComponentDeps (Component(..))-import Distribution.Compiler-import Distribution.InstalledPackageInfo as IPI-import Distribution.Package                          -- from Cabal-import Distribution.PackageDescription as PD         -- from Cabal-import Distribution.PackageDescription.Configuration as PDC-import qualified Distribution.Simple.PackageIndex as SI-import Distribution.System--import Distribution.Client.Dependency.Modular.Dependency as D-import Distribution.Client.Dependency.Modular.Flag as F-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree-import Distribution.Client.Dependency.Modular.Version---- | Convert both the installed package index and the source package--- index into one uniform solver index.------ We use 'allPackagesBySourcePackageId' for the installed package index--- because that returns us several instances of the same package and version--- in order of preference. This allows us in principle to \"shadow\"--- packages if there are several installed packages of the same version.--- There are currently some shortcomings in both GHC and Cabal in--- resolving these situations. However, the right thing to do is to--- fix the problem there, so for now, shadowing is only activated if--- explicitly requested.-convPIs :: OS -> Arch -> CompilerInfo -> Bool -> Bool ->-           SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index-convPIs os arch comp sip strfl iidx sidx =-  mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sidx)---- | Convert a Cabal installed package index to the simpler,--- more uniform index format of the solver.-convIPI' :: Bool -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]-convIPI' sip idx =-    -- apply shadowing whenever there are multiple installed packages with-    -- the same version-    [ maybeShadow (convIP idx pkg)-    | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx-    , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]-  where--    -- shadowing is recorded in the package info-    shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))-    shadow x                                = x---- | Convert a single installed package into the solver-specific format.-convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)-convIP idx ipi =-  case mapM (convIPId pn idx) (IPI.depends ipi) of-        Nothing  -> (pn, i, PInfo []            M.empty (Just Broken))-        Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing)- where-  -- We assume that all dependencies of installed packages are _library_ deps-  ipid = IPI.installedUnitId ipi-  i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)-  pn = pkgName (sourcePackageId ipi)-  setComp = setCompFlaggedDeps (ComponentLib (unPackageName pn))--- TODO: Installed packages should also store their encapsulations!---- | Convert dependencies specified by an installed package id into--- flagged dependencies of the solver.------ May return Nothing if the package can't be found in the index. That--- indicates that the original package having this dependency is broken--- and should be ignored.-convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN)-convIPId pn' idx ipid =-  case SI.lookupUnitId idx ipid of-    Nothing  -> Nothing-    Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)-                    pn = pkgName (sourcePackageId ipi)-                in  Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))) ())---- | Convert a cabal-install source package index to the simpler,--- more uniform index format of the solver.-convSPI' :: OS -> Arch -> CompilerInfo -> Bool ->-            CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]-convSPI' os arch cinfo strfl = L.map (convSP os arch cinfo strfl) . CI.allPackages---- | Convert a single source package into the solver-specific format.-convSP :: OS -> Arch -> CompilerInfo -> Bool -> SourcePackage loc -> (PN, I, PInfo)-convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =-  let i = I pv InRepo-  in  (pn, i, convGPD os arch cinfo strfl (PI pn i) gpd)---- We do not use 'flattenPackageDescription' or 'finalizePackageDescription'--- from 'Distribution.PackageDescription.Configuration' here, because we--- want to keep the condition tree, but simplify much of the test.---- | Convert a generic package description to a solver-specific 'PInfo'.-convGPD :: OS -> Arch -> CompilerInfo -> Bool ->-           PI PN -> GenericPackageDescription -> PInfo-convGPD os arch cinfo strfl pi@(PI pn _)-        (GenericPackageDescription pkg flags libs exes tests benchs) =-  let-    fds  = flagInfo strfl flags--    -- | We have to be careful to filter out dependencies on-    -- internal libraries, since they don't refer to real packages-    -- and thus cannot actually be solved over.  We'll do this-    -- by creating a set of package names which are "internal"-    -- and dropping them as we convert.-    ipns = S.fromList [ PackageName nm-                      | (nm, _) <- libs-                      -- Don't include the true package name;-                      -- qualification could make this relevant.-                      -- TODO: Can we qualify over internal-                      -- dependencies? Not for now!-                      , PackageName nm /= pn ]--    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) ->-            CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN-    conv comp getInfo = convCondTree os arch cinfo pi fds comp getInfo ipns .-                        PDC.addBuildableCondition getInfo--    flagged_deps-        = concatMap (\(nm, ds) -> conv (ComponentLib nm)   libBuildInfo       ds) libs-       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)   buildInfo          ds) exes-       ++ prefix (Stanza (SN pi TestStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentTest nm)  testBuildInfo      ds) tests)-       ++ prefix (Stanza (SN pi BenchStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs)-       ++ maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)--  in-    PInfo flagged_deps fds Nothing---- With convenience libraries, we have to do some work.  Imagine you--- have the following Cabal file:------      name: foo---      library foo-internal---          build-depends: external-a---      library---          build-depends: foo-internal, external-b---      library foo-helper---          build-depends: foo, external-c---      test-suite foo-tests---          build-depends: foo-helper, external-d------ What should the final flagged dependency tree be?  Ideally, it--- should look like this:------      [ Simple (Dep external-a) (Library foo-internal)---      , Simple (Dep external-b) (Library foo)---      , Stanza (SN foo TestStanzas) $---          [ Simple (Dep external-c) (Library foo-helper)---          , Simple (Dep external-d) (TestSuite foo-tests) ]---      ]------ There are two things to note:------      1. First, we eliminated the "local" dependencies foo-internal---      and foo-helper.  This are implicitly assumed to refer to "foo"---      so we don't need to have them around.  If you forget this,---      Cabal will then try to pick a version for "foo-helper" but---      no such package exists (this is the cost of overloading---      build-depends to refer to both packages and components.)------      2. Second, it is more precise to have external-c be qualified---      by a test stanza, since foo-helper only needs to be built if---      your are building the test suite (and not the main library).---      If you omit it, Cabal will always attempt to depsolve for---      foo-helper even if you aren't building the test suite.---- | Create a flagged dependency tree from a list @fds@ of flagged--- dependencies, using @f@ to form the tree node (@f@ will be--- something like @Stanza sn@).-prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn)-       -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn-prefix _ []  = []-prefix f fds = [f (concat fds)]---- | Convert flag information. Automatic flags are now considered weak--- unless strong flags have been selected explicitly.-flagInfo :: Bool -> [PD.Flag] -> FlagInfo-flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m))))---- | Internal package names, which should not be interpreted as true--- dependencies.-type IPNs = Set PN---- | Convenience function to delete a 'FlaggedDep' if it's--- for a 'PN' that isn't actually real.-filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN-filterIPNs ipns (Dependency pn _) fd-    | S.notMember pn ipns = [fd]-    | otherwise           = []---- | Convert condition trees to flagged dependencies.  Mutually--- recursive with 'convBranch'.  See 'convBranch' for an explanation--- of all arguments preceeding the input 'CondTree'.-convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->-                Component ->-                (a -> BuildInfo) ->-                IPNs ->-                CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN-convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo ipns (CondNode info ds branches) =-                 concatMap-                    (\d -> filterIPNs ipns d (D.Simple (convDep pn d) comp))-                    ds  -- unconditional package dependencies-              ++ L.map (\e -> D.Simple (Ext  e) comp) (PD.allExtensions bi) -- unconditional extension dependencies-              ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages  bi) -- unconditional language dependencies-              ++ L.map (\(Dependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies-              ++ concatMap (convBranch os arch cinfo pi fds comp getInfo ipns) branches-  where-    bi = getInfo info---- | Branch interpreter.  Mutually recursive with 'convCondTree'.------ Here, we try to simplify one of Cabal's condition tree branches into the--- solver's flagged dependency format, which is weaker. Condition trees can--- contain complex logical expression composed from flag choices and special--- flags (such as architecture, or compiler flavour). We try to evaluate the--- special flags and subsequently simplify to a tree that only depends on--- simple flag choices.------ This function takes a number of arguments:------      1. Some pre dependency-solving known information ('OS', 'Arch',---         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,------      2. The package instance @'PI' 'PN'@ which this condition tree---         came from, so that we can correctly associate @flag()@---         variables with the correct package name qualifier,------      3. The flag defaults 'FlagInfo' so that we can populate---         'Flagged' dependencies with 'FInfo',------      4. The name of the component 'Component' so we can record where---         the fine-grained information about where the component came---         from (see 'convCondTree'), and------      5. A selector to extract the 'BuildInfo' from the leaves of---         the 'CondTree' (which actually contains the needed---         dependency information.)------      6. The set of package names which should be considered internal---         dependencies, and thus not handled as dependencies.-convBranch :: OS -> Arch -> CompilerInfo ->-              PI PN -> FlagInfo ->-              Component ->-              (a -> BuildInfo) ->-              IPNs ->-              (Condition ConfVar,-               CondTree ConfVar [Dependency] a,-               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN-convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns (c', t', mf') =-  go c' (          convCondTree os arch cinfo pi fds comp getInfo ipns   t')-        (maybe [] (convCondTree os arch cinfo pi fds comp getInfo ipns) mf')-  where-    go :: Condition ConfVar ->-          FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN-    go (Lit True)  t _ = t-    go (Lit False) _ f = f-    go (CNot c)    t f = go c f t-    go (CAnd c d)  t f = go c (go d t f) f-    go (COr  c d)  t f = go c t (go d t f)-    go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f]-    go (Var (OS os')) t f-      | os == os'      = t-      | otherwise      = f-    go (Var (Arch arch')) t f-      | arch == arch'  = t-      | otherwise      = f-    go (Var (Impl cf cvr)) t f-      | matchImpl (compilerInfoId cinfo) ||-            -- fixme: Nothing should be treated as unknown, rather than empty-            --        list. This code should eventually be changed to either-            --        support partial resolution of compiler flags or to-            --        complain about incompletely configured compilers.-        any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t-      | otherwise      = f-      where-        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv--    -- If both branches contain the same package as a simple dep, we lift it to-    -- the next higher-level, but without constraints. This heuristic together-    -- with deferring flag choices will then usually first resolve this package,-    -- and try an already installed version before imposing a default flag choice-    -- that might not be what we want.-    ---    -- Note that we make assumptions here on the form of the dependencies that-    -- can occur at this point. In particular, no occurrences of Fixed, and no-    -- occurrences of multiple version ranges, as all dependencies below this-    -- point have been generated using 'convDep'.-    extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN-    extractCommon ps ps' = [ D.Simple (Dep pn1 (Constrained [(vr1 .||. vr2, Goal (P pn) [])])) comp-                           | D.Simple (Dep pn1 (Constrained [(vr1, _)])) _ <- ps-                           , D.Simple (Dep pn2 (Constrained [(vr2, _)])) _ <- ps'-                           , pn1 == pn2-                           ]---- | Convert a Cabal dependency to a solver-specific dependency.-convDep :: PN -> Dependency -> Dep PN-convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])])---- | Convert setup dependencies-convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN-convSetupBuildInfo (PI pn _i) nfo =-    L.map (\d -> D.Simple (convDep pn d) ComponentSetup) (PD.setupDepends nfo)
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs 
@@ -1,529 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Distribution.Client.Dependency.Modular.Linking (-    addLinking-  , validateLinking-  ) where--import Prelude hiding (pi)-import Control.Exception (assert)-import Control.Monad.Reader-import Control.Monad.State-import Data.Maybe (catMaybes)-import Data.Map (Map, (!))-import Data.List (intercalate)-import Data.Set (Set)-import qualified Data.Map         as M-import qualified Data.Set         as S-import qualified Data.Traversable as T--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree-import qualified Distribution.Client.Dependency.Modular.PSQ as P--import Distribution.Client.Types (OptionalStanza(..))-import Distribution.Client.ComponentDeps (Component)--{--------------------------------------------------------------------------------  Add linking--------------------------------------------------------------------------------}--type RelatedGoals = Map (PN, I) [PP]-type Linker       = Reader RelatedGoals---- | Introduce link nodes into tree tree------ Linking is a traversal of the solver tree that adapts package choice nodes--- and adds the option to link wherever appropriate: Package goals are called--- "related" if they are for the same version of the same package (but have--- different prefixes). A link option is available in a package choice node--- whenever we can choose an instance that has already been chosen for a related--- goal at a higher position in the tree.------ The code here proceeds by maintaining a finite map recording choices that--- have been made at higher positions in the tree. For each pair of package name--- and instance, it stores the prefixes at which we have made a choice for this--- package instance. Whenever we make a choice, we extend the map. Whenever we--- find a choice, we look into the map in order to find out what link options we--- have to add.-addLinking :: Tree QGoalReasonChain -> Tree QGoalReasonChain-addLinking = (`runReader` M.empty) .  cata go-  where-    go :: TreeF QGoalReasonChain (Linker (Tree QGoalReasonChain)) -> Linker (Tree QGoalReasonChain)--    -- The only nodes of interest are package nodes-    go (PChoiceF qpn gr cs) = do-      env <- ask-      cs' <- T.sequence $ P.mapWithKey (goP qpn) cs-      let newCs = concatMap (linkChoices env qpn) (P.toList cs')-      return $ PChoice qpn gr (cs' `P.union` P.fromList newCs)-    go _otherwise =-      innM _otherwise--    -- Recurse underneath package choices. Here we just need to make sure-    -- that we record the package choice so that it is available below-    goP :: QPN -> POption -> Linker (Tree QGoalReasonChain) -> Linker (Tree QGoalReasonChain)-    goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])-    goP _ _ = alreadyLinked--linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReasonChain) -> [(POption, Tree QGoalReasonChain)]-linkChoices related (Q _pp pn) (POption i Nothing, subtree) =-    map aux (M.findWithDefault [] (pn, i) related)-  where-    aux :: PP -> (POption, Tree QGoalReasonChain)-    aux pp = (POption i (Just pp), subtree)-linkChoices _ _ (POption _ (Just _), _) =-    alreadyLinked--alreadyLinked :: a-alreadyLinked = error "addLinking called on tree that already contains linked nodes"--{--------------------------------------------------------------------------------  Validation--  Validation of links is a separate pass that's performed after normal-  validation. Validation of links checks that if the tree indicates that a-  package is linked, then everything underneath that choice really matches the-  package we have linked to.--  This is interesting because it isn't unidirectional. Consider that we've-  chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.-  Now foo depends on bar. Because a.foo and b.foo are linked, it's required that-  a.bar and b.bar are also linked. However, it's not required that we actually-  choose a.bar before b.bar. Goal choice order is relatively free. It's possible-  that we choose a.bar first, but also possible that we choose b.bar first. In-  both cases, we have to recognize that we have freedom of choice for the first-  of the two, but no freedom of choice for the second.--  This is what LinkGroups are all about. Using LinkGroup, we can record (in the-  situation above) that a.bar and b.bar need to be linked even if we haven't-  chosen either of them yet.--------------------------------------------------------------------------------}--data ValidateState = VS {-      vsIndex    :: Index-    , vsLinks    :: Map QPN LinkGroup-    , vsFlags    :: FAssignment-    , vsStanzas  :: SAssignment-    , vsQualifyOptions :: QualifyOptions-    }-    deriving Show--type Validate = Reader ValidateState---- | Validate linked packages------ Verify that linked packages have------ * Linked dependencies,--- * Equal flag assignments--- * Equal stanza assignments-validateLinking :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain-validateLinking index = (`runReader` initVS) . cata go-  where-    go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)--    go (PChoiceF qpn gr cs) =-      PChoice qpn gr     <$> T.sequence (P.mapWithKey (goP qpn) cs)-    go (FChoiceF qfn gr t m cs) =-      FChoice qfn gr t m <$> T.sequence (P.mapWithKey (goF qfn) cs)-    go (SChoiceF qsn gr t cs) =-      SChoice qsn gr t   <$> T.sequence (P.mapWithKey (goS qsn) cs)--    -- For the other nodes we just recurse-    go (GoalChoiceF         cs)       = GoalChoice          <$> T.sequence cs-    go (DoneF revDepMap)              = return $ Done revDepMap-    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason--    -- Package choices-    goP :: QPN -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goP qpn@(Q _pp pn) opt@(POption i _) r = do-      vs <- ask-      let PInfo deps _ _ = vsIndex vs ! pn ! i-          qdeps          = qualifyDeps (vsQualifyOptions vs) qpn deps-      case execUpdateState (pickPOption qpn opt qdeps) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    -- Flag choices-    goF :: QFN -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goF qfn b r = do-      vs <- ask-      case execUpdateState (pickFlag qfn b) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    -- Stanza choices (much the same as flag choices)-    goS :: QSN -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goS qsn b r = do-      vs <- ask-      case execUpdateState (pickStanza qsn b) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    initVS :: ValidateState-    initVS = VS {-        vsIndex   = index-      , vsLinks   = M.empty-      , vsFlags   = M.empty-      , vsStanzas = M.empty-      , vsQualifyOptions = defaultQualifyOptions index-      }--{--------------------------------------------------------------------------------  Updating the validation state--------------------------------------------------------------------------------}--type Conflict = (ConflictSet QPN, String)--newtype UpdateState a = UpdateState {-    unUpdateState :: StateT ValidateState (Either Conflict) a-  }-  deriving (Functor, Applicative, Monad, MonadState ValidateState)--lift' :: Either Conflict a -> UpdateState a-lift' = UpdateState . lift--conflict :: Conflict -> UpdateState a-conflict = lift' . Left--execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState-execUpdateState = execStateT . unUpdateState--pickPOption :: QPN -> POption -> FlaggedDeps comp QPN -> UpdateState ()-pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i-pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps--pickConcrete :: QPN -> I -> UpdateState ()-pickConcrete qpn@(Q pp _) i = do-    vs <- get-    case M.lookup qpn (vsLinks vs) of-      -- Package is not yet in a LinkGroup. Create a new singleton link group.-      Nothing -> do-        let lg = lgSingleton qpn (Just $ PI pp i)-        updateLinkGroup lg--      -- Package is already in a link group. Since we are picking a concrete-      -- instance here, it must by definition be the canonical package.-      Just lg ->-        makeCanonical lg qpn i--pickLink :: QPN -> I -> PP -> FlaggedDeps comp QPN -> UpdateState ()-pickLink qpn@(Q pp pn) i pp' deps = do-    vs <- get-    -- Find the link group for the package we are linking to, and add this package-    ---    -- Since the builder never links to a package without having first picked a-    -- concrete instance for that package, and since we create singleton link-    -- groups for concrete instances, this link group must exist (and must-    -- in fact already have a canonical member).-    let lg = vsLinks vs ! Q pp' pn--    -- Verify here that the member we add is in fact for the same package and-    -- matches the version of the canonical instance. However, violations of-    -- these checks would indicate a bug in the linker, not a true conflict.-    let sanityCheck :: Maybe (PI PP) -> Bool-        sanityCheck Nothing              = False-        sanityCheck (Just (PI _ canonI)) = pn == lgPackage lg && i == canonI-    assert (sanityCheck (lgCanon lg)) $ return ()--    -- Since we already have a canonical member, we just need to add the new-    -- member into the group-    let lg' = lg { lgMembers = S.insert pp (lgMembers lg) }-    updateLinkGroup lg'-    linkDeps [P qpn] pp' deps--makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()-makeCanonical lg qpn@(Q pp _) i =-    case lgCanon lg of-      -- There is already a canonical member. Fail.-      Just _ ->-        conflict ( S.fromList (P qpn : lgBlame lg)-                 ,    "cannot make " ++ showQPN qpn-                   ++ " canonical member of " ++ showLinkGroup lg-                 )-      Nothing -> do-        let lg' = lg { lgCanon = Just (PI pp i) }-        updateLinkGroup lg'---- | Link the dependencies of linked parents.------ When we decide to link one package against another we walk through the--- package's direct depedencies and make sure that they're all linked to each--- other by merging their link groups (or creating new singleton link groups if--- they don't have link groups yet). We do not need to do this recursively,--- because having the direct dependencies in a link group means that we must--- have already made or will make sooner or later a link choice for one of these--- as well, and cover their dependencies at that point.-linkDeps :: [Var QPN] -> PP -> FlaggedDeps comp QPN -> UpdateState ()-linkDeps parents pp' = mapM_ go-  where-    go :: FlaggedDep comp QPN -> UpdateState ()-    go (Simple (Dep qpn@(Q _ pn) _) _) = do-      vs <- get-      let qpn' = Q pp' pn-          lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs-          lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs-      lg'' <- lift' $ lgMerge parents lg lg'-      updateLinkGroup lg''-    -- For extensions and language dependencies, there is nothing to do.-    -- No choice is involved, just checking, so there is nothing to link.-    go (Simple (Ext  _)             _) = return ()-    go (Simple (Lang _)             _) = return ()-    -- Similarly for pkg-config constraints-    go (Simple (Pkg  _ _)           _) = return ()-    go (Flagged fn _ t f) = do-      vs <- get-      case M.lookup fn (vsFlags vs) of-        Nothing    -> return () -- flag assignment not yet known-        Just True  -> linkDeps (F fn:parents) pp' t-        Just False -> linkDeps (F fn:parents) pp' f-    go (Stanza sn t) = do-      vs <- get-      case M.lookup sn (vsStanzas vs) of-        Nothing    -> return () -- stanza assignment not yet known-        Just True  -> linkDeps (S sn:parents) pp' t-        Just False -> return () -- stanza not enabled; no new deps--pickFlag :: QFN -> Bool -> UpdateState ()-pickFlag qfn b = do-    modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }-    verifyFlag qfn-    linkNewDeps (F qfn) b--pickStanza :: QSN -> Bool -> UpdateState ()-pickStanza qsn b = do-    modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }-    verifyStanza qsn-    linkNewDeps (S qsn) b---- | Link dependencies that we discover after making a flag choice.------ When we make a flag choice for a package, then new dependencies for that--- package might become available. If the package under consideration is in a--- non-trivial link group, then these new dependencies have to be linked as--- well. In linkNewDeps, we compute such new dependencies and make sure they are--- linked.-linkNewDeps :: Var QPN -> Bool -> UpdateState ()-linkNewDeps var b = do-    vs <- get-    let (qpn@(Q pp pn), Just i) = varPI var-        PInfo deps _ _          = vsIndex vs ! pn ! i-        qdeps                   = qualifyDeps (vsQualifyOptions vs) qpn deps-        lg                      = vsLinks vs ! qpn-        (parents, newDeps)      = findNewDeps vs qdeps-        linkedTo                = S.delete pp (lgMembers lg)-    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (P qpn : parents) pp' newDeps-  where-    findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)-    findNewDeps vs = concatMapUnzip (findNewDeps' vs)--    findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)-    findNewDeps' _  (Simple _ _)        = ([], [])-    findNewDeps' vs (Flagged qfn _ t f) =-      case (F qfn == var, M.lookup qfn (vsFlags vs)) of-        (True, _)    -> ([F qfn], if b then t else f)-        (_, Nothing) -> ([], []) -- not yet known-        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f)-                        in (F qfn:parents, deps)-    findNewDeps' vs (Stanza qsn t) =-      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of-        (True, _)    -> ([S qsn], if b then t else [])-        (_, Nothing) -> ([], []) -- not yet known-        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else [])-                        in (S qsn:parents, deps)--updateLinkGroup :: LinkGroup -> UpdateState ()-updateLinkGroup lg = do-    verifyLinkGroup lg-    modify $ \vs -> vs {-        vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))-                  `M.union` vsLinks vs-      }-  where-    aux pp = (Q pp (lgPackage lg), lg)--{--------------------------------------------------------------------------------  Verification--------------------------------------------------------------------------------}--verifyLinkGroup :: LinkGroup -> UpdateState ()-verifyLinkGroup lg =-    case lgInstance lg of-      -- No instance picked yet. Nothing to verify-      Nothing ->-        return ()--      -- We picked an instance. Verify flags and stanzas-      -- TODO: The enumeration of OptionalStanza names is very brittle;-      -- if a constructor is added to the datatype we won't notice it here-      Just i -> do-        vs <- get-        let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i-            flags   = M.keys finfo-            stanzas = [TestStanzas, BenchStanzas]-        forM_ flags $ \fn -> do-          let flag = FN (PI (lgPackage lg) i) fn-          verifyFlag' flag lg-        forM_ stanzas $ \sn -> do-          let stanza = SN (PI (lgPackage lg) i) sn-          verifyStanza' stanza lg--verifyFlag :: QFN -> UpdateState ()-verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do-    vs <- get-    -- We can only pick a flag after picking an instance; link group must exist-    verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)--verifyStanza :: QSN -> UpdateState ()-verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do-    vs <- get-    -- We can only pick a stanza after picking an instance; link group must exist-    verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn)---- | Verify that all packages in the link group agree on flag assignments------ For the given flag and the link group, obtain all assignments for the flag--- that have already been made for link group members, and check that they are--- equal.-verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()-verifyFlag' (FN (PI pn i) fn) lg = do-    vs <- get-    let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg))-        vals  = map (`M.lookup` vsFlags vs) flags-    if allEqual (catMaybes vals) -- We ignore not-yet assigned flags-      then return ()-      else conflict ( S.fromList (map F flags) `S.union` lgConflictSet lg-                    , "flag " ++ show fn ++ " incompatible"-                    )---- | Verify that all packages in the link group agree on stanza assignments------ For the given stanza and the link group, obtain all assignments for the--- stanza that have already been made for link group members, and check that--- they are equal.------ This function closely mirrors 'verifyFlag''.-verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()-verifyStanza' (SN (PI pn i) sn) lg = do-    vs <- get-    let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg))-        vals    = map (`M.lookup` vsStanzas vs) stanzas-    if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas-      then return ()-      else conflict ( S.fromList (map S stanzas) `S.union` lgConflictSet lg-                    , "stanza " ++ show sn ++ " incompatible"-                    )--{--------------------------------------------------------------------------------  Link groups--------------------------------------------------------------------------------}---- | Set of packages that must be linked together------ A LinkGroup is between several qualified package names. In the validation--- state, we maintain a map vsLinks from qualified package names to link groups.--- There is an invariant that for all members of a link group, vsLinks must map--- to the same link group. The function updateLinkGroup can be used to--- re-establish this invariant after creating or expanding a LinkGroup.-data LinkGroup = LinkGroup {-      -- | The name of the package of this link group-      lgPackage :: PN--      -- | The canonical member of this link group (the one where we picked-      -- a concrete instance). Once we have picked a canonical member, all-      -- other packages must link to this one.-      ---      -- We may not know this yet (if we are constructing link groups-      -- for dependencies)-    , lgCanon :: Maybe (PI PP)--      -- | The members of the link group-    , lgMembers :: Set PP--      -- | The set of variables that should be added to the conflict set if-      -- something goes wrong with this link set (in addition to the members-      -- of the link group itself)-    , lgBlame :: [Var QPN]-    }-    deriving Show---- | Package version of this group------ This is only known once we have picked a canonical element.-lgInstance :: LinkGroup -> Maybe I-lgInstance = fmap (\(PI _ i) -> i) . lgCanon--showLinkGroup :: LinkGroup -> String-showLinkGroup lg =-    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"-  where-    showMember :: PP -> String-    showMember pp = case lgCanon lg of-                      Just (PI pp' _i) | pp == pp' -> "*"-                      _otherwise                   -> ""-                 ++ case lgInstance lg of-                      Nothing -> showQPN (qpn pp)-                      Just i  -> showPI (PI (qpn pp) i)--    qpn :: PP -> QPN-    qpn pp = Q pp (lgPackage lg)---- | Creates a link group that contains a single member.-lgSingleton :: QPN -> Maybe (PI PP) -> LinkGroup-lgSingleton (Q pp pn) canon = LinkGroup {-      lgPackage = pn-    , lgCanon   = canon-    , lgMembers = S.singleton pp-    , lgBlame   = []-    }--lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup-lgMerge blame lg lg' = do-    canon <- pick (lgCanon lg) (lgCanon lg')-    return LinkGroup {-        lgPackage = lgPackage lg-      , lgCanon   = canon-      , lgMembers = lgMembers lg `S.union` lgMembers lg'-      , lgBlame   = blame ++ lgBlame lg ++ lgBlame lg'-      }-  where-    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)-    pick Nothing  Nothing  = Right Nothing-    pick (Just x) Nothing  = Right $ Just x-    pick Nothing  (Just y) = Right $ Just y-    pick (Just x) (Just y) =-      if x == y then Right $ Just x-                else Left ( S.unions [-                               S.fromList blame-                             , lgConflictSet lg-                             , lgConflictSet lg'-                             ]-                          ,    "cannot merge " ++ showLinkGroup lg-                            ++ " and " ++ showLinkGroup lg'-                          )--lgConflictSet :: LinkGroup -> ConflictSet QPN-lgConflictSet lg = S.fromList (map aux (S.toList (lgMembers lg)) ++ lgBlame lg)-  where-    aux pp = P (Q pp (lgPackage lg))--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}--allEqual :: Eq a => [a] -> Bool-allEqual []       = True-allEqual [_]      = True-allEqual (x:y:ys) = x == y && allEqual (y:ys)--concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c])-concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs 
@@ -1,106 +0,0 @@-module Distribution.Client.Dependency.Modular.Log-    ( Log-    , continueWith-    , failWith-    , logToProgress-    , succeedWith-    , tryWith-    ) where--import Control.Applicative-import Data.List as L-import Data.Maybe (isNothing)-import Data.Set as S--import Distribution.Client.Dependency.Types -- from Cabal--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Message-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree (FailReason(..))---- | The 'Log' datatype.------ Represents the progress of a computation lazily.------ Parameterized over the type of actual messages and the final result.-type Log m a = Progress m () a--messages :: Progress step fail done -> [step]-messages = foldProgress (:) (const []) (const [])---- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.--- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the--- limit is 'Just 0', backtracking is completely disabled.-logToProgress :: Maybe Int -> Log Message a -> Progress String String a-logToProgress mbj l = let-                        es = proc (Just 0) l -- catch first error (always)-                        ms = useFirstError (proc mbj l)-                      in go es es -- trace for first error-                            (showMessages (const True) True ms) -- run with backjump limit applied-  where-    -- Proc takes the allowed number of backjumps and a 'Progress' and explores the-    -- messages until the maximum number of backjumps has been reached. It filters out-    -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates-    -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the-    -- original success result or replaces the original failure with 'Nothing'.-    proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b-    proc _        (Done x)                          = Done x-    proc _        (Fail _)                          = Fail Nothing-    proc mbj'     (Step   (Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))-      | cs == cs'                                   = proc mbj' xs -- repeated backjumps count as one-    proc (Just 0) (Step   (Failure cs Backjump)  _) = Fail (Just cs)-    proc (Just n) (Step x@(Failure _  Backjump) xs) = Step x (proc (Just (n - 1)) xs)-    proc mbj'     (Step x                       xs) = Step x (proc mbj'           xs)--    -- Sets the conflict set from the first backjump as the final error, and records-    -- whether the search was exhaustive.-    useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b-                  -> Progress Message (Bool, Maybe (ConflictSet QPN)) b-    useFirstError = replace Nothing-      where-        replace _       (Done x)                          = Done x-        replace cs'     (Fail cs)                         = -- 'Nothing' means backjump limit not reached.-                                                            -- Prefer first error over later error.-                                                            Fail (isNothing cs, cs' <|> cs)-        replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs-        replace cs'     (Step x                       xs) = Step x $ replace cs' xs--    -- The first two arguments are both supposed to be the log up to the first error.-    -- That's the error that will always be printed in case we do not find a solution.-    -- We pass this log twice, because we evaluate it in parallel with the full log,-    -- but we also want to retain the reference to its beginning for when we print it.-    -- This trick prevents a space leak!-    ---    -- The third argument is the full log, ending with either the solution or the-    -- exhaustiveness and first conflict set.-    go :: Progress Message a b-       -> Progress Message a b-       -> Progress String (Bool, Maybe (ConflictSet QPN)) b-       -> Progress String String b-    go ms (Step _ ns) (Step x xs)           = Step x (go ms ns xs)-    go ms r           (Step x xs)           = Step x (go ms r  xs)-    go ms _           (Fail (exh, Just cs)) = Fail $-                                              "Could not resolve dependencies:\n" ++-                                              unlines (messages $ showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++-                                              (if exh then "Dependency tree exhaustively searched.\n"-                                                      else "Backjump limit reached (" ++ currlimit mbj ++-                                                               "change with --max-backjumps or try to run with --reorder-goals).\n")-                                                  where currlimit (Just n) = "currently " ++ show n ++ ", "-                                                        currlimit Nothing  = ""-    go _  _           (Done s)              = Done s-    go _  _           (Fail (_, Nothing))   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen--failWith :: step -> fail -> Progress step fail done-failWith s f = Step s (Fail f)--succeedWith :: step -> done -> Progress step fail done-succeedWith s d = Step s (Done d)--continueWith :: step -> Progress step fail done -> Progress step fail done-continueWith = Step--tryWith :: Message-        -> Progress Message fail done-        -> Progress Message fail done-tryWith m = Step m . Step Enter . foldProgress Step (failWith Leave) Done
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Distribution.Client.Dependency.Modular.Message (-    Message(..),-    showMessages-  ) where--import qualified Data.List as L-import Prelude hiding (pi)--import Distribution.Text -- from Cabal--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree-         ( FailReason(..), POption(..) )-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..), showConstraintSource, Progress(..) )--data Message =-    Enter           -- ^ increase indentation level-  | Leave           -- ^ decrease indentation level-  | TryP QPN POption-  | TryF QFN Bool-  | TryS QSN Bool-  | Next (Goal QPN)-  | Success-  | Failure (ConflictSet QPN) FailReason---- | Transforms the structured message type to actual messages (strings).------ Takes an additional relevance predicate. The predicate gets a stack of goal--- variables and can decide whether messages regarding these goals are relevant.--- You can plug in 'const True' if you're interested in a full trace. If you--- want a slice of the trace concerning a particular conflict set, then plug in--- a predicate returning 'True' on the empty stack and if the head is in the--- conflict set.------ The second argument indicates if the level numbers should be shown. This is--- recommended for any trace that involves backtracking, because only the level--- numbers will allow to keep track of backjumps.-showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b-showMessages p sl = go [] 0-  where-    -- The stack 'v' represents variables that are currently assigned by the-    -- solver.  'go' pushes a variable for a recursive call when it encounters-    -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'.-    -- When 'go' processes a package goal, or a package goal followed by a-    -- 'Failure', it calls 'atLevel' with the goal variable at the head of the-    -- stack so that the predicate can also select messages relating to package-    -- goal choices.-    go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b-    go !_ !_ (Done x)                           = Done x-    go !_ !_ (Fail x)                           = Fail x-    -- complex patterns-    go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        goPReject v l qpn [i] c fr ms-    go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)-    go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =-        (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =-        let v' = add (P qpn) v-        in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)-    go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))-        | c == c' = go v l ms-    -- standard display-    go !v !l (Step Enter                    ms) = go v          (l+1) ms-    go !v !l (Step Leave                    ms) = go (drop 1 v) (l-1) ms-    go !v !l (Step (TryP qpn i)             ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)-    go !v !l (Step (TryF qfn b)             ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)-    go !v !l (Step (TryS qsn b)             ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)-    go !v !l (Step (Next _)                 ms) = go v l ms -- ignore flag goals in the log-    go !v !l (Step (Success)                ms) = (atLevel v l $ "done") (go v l ms)-    go !v !l (Step (Failure c fr)           ms) = (atLevel v l $ showFailure c fr) (go v l ms)--    showPackageGoal :: QPN -> QGoalReasonChain -> String-    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGRs gr--    showFailure :: ConflictSet QPN -> FailReason -> String-    showFailure c fr = "fail" ++ showFR c fr--    add :: Var QPN -> [Var QPN] -> [Var QPN]-    add v vs = simplifyVar v : vs--    -- special handler for many subsequent package rejections-    goPReject :: [Var QPN]-              -> Int-              -> QPN-              -> [POption]-              -> ConflictSet QPN-              -> FailReason-              -> Progress Message a b-              -> Progress String a b-    goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))-      | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms-    goPReject v l qpn is c fr ms =-        (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)--    -- write a message, but only if it's relevant; we can also enable or disable the display of the current level-    atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b-    atLevel v l x xs-      | sl && p v = let s = show l-                    in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs-      | p v       = Step x xs-      | otherwise = xs--showQPNPOpt :: QPN -> POption -> String-showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =-  case linkedTo of-    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption-    Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)--showGRs :: QGoalReasonChain -> String-showGRs (gr : _) = showGR gr-showGRs []       = ""--showGR :: GoalReason QPN -> String-showGR UserGoal            = " (user goal)"-showGR (PDependency pi)    = " (dependency of " ++ showPI pi            ++ ")"-showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b    ++ ")"-showGR (SDependency qsn)   = " (dependency of " ++ showQSNBool qsn True ++ ")"--showFR :: ConflictSet QPN -> FailReason -> String-showFR _ InconsistentInitialConstraints   = " (inconsistent initial constraints)"-showFR _ (Conflicting ds)                 = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"-showFR _ CannotInstall                    = " (only already installed instances can be used)"-showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"-showFR _ Shadowed                         = " (shadowed by another installed package with same version)"-showFR _ Broken                           = " (package is broken)"-showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display vr ++ ")"-showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"-showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"-showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"-showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"-showFR _ (BuildFailureNotInIndex pn)      = " (unknown package: " ++ display pn ++ ")"-showFR c Backjump                         = " (backjumping, conflict set: " ++ showCS c ++ ")"-showFR _ MultipleInstances                = " (multiple instances)"-showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")"-showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")"--- The following are internal failures. They should not occur. In the--- interest of not crashing unnecessarily, we still just print an error--- message though.-showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"-showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"-showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"--constraintSource :: ConstraintSource -> String-constraintSource src = "constraint from " ++ showConstraintSource src
− cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.PSQ-    ( PSQ(..)  -- Unit test needs constructor access-    , Degree(..)-    , casePSQ-    , cons-    , degree-    , delete-    , dminimumBy-    , length-    , lookup-    , filter-    , filterKeys-    , firstOnly-    , fromList-    , isZeroOrOne-    , keys-    , map-    , mapKeys-    , mapWithKey-    , mapWithKeyState-    , minimumBy-    , null-    , prefer-    , preferByKeys-    , preferOrElse-    , snoc-    , sortBy-    , sortByKeys-    , splits-    , toList-    , union-    ) where---- Priority search queues.------ I am not yet sure what exactly is needed. But we need a data structure with--- key-based lookup that can be sorted. We're using a sequence right now with--- (inefficiently implemented) lookup, because I think that queue-based--- operations and sorting turn out to be more efficiency-critical in practice.--import Control.Arrow (first, second)--import qualified Data.Foldable as F-import Data.Function-import qualified Data.List as S-import Data.Ord (comparing)-import Data.Traversable-import Prelude hiding (foldr, length, lookup, filter, null, map)--newtype PSQ k v = PSQ [(k, v)]-  deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP--keys :: PSQ k v -> [k]-keys (PSQ xs) = fmap fst xs--lookup :: Eq k => k -> PSQ k v -> Maybe v-lookup k (PSQ xs) = S.lookup k xs--map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2-map f (PSQ xs) = PSQ (fmap (second f) xs)--mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v-mapKeys f (PSQ xs) = PSQ (fmap (first f) xs)--mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b-mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)--mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b-mapWithKeyState p (PSQ xs) s0 =-  PSQ (F.foldr (\ (k, v) r s -> case p s k v of-                                  (w, n) -> (k, w) : (r n))-               (const []) xs s0)--delete :: Eq k => k -> PSQ k a -> PSQ k a-delete k (PSQ xs) = PSQ (snd (S.partition ((== k) . fst) xs))--fromList :: [(k, a)] -> PSQ k a-fromList = PSQ--cons :: k -> a -> PSQ k a -> PSQ k a-cons k x (PSQ xs) = PSQ ((k, x) : xs)--snoc :: PSQ k a -> k -> a -> PSQ k a-snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])--casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r-casePSQ (PSQ xs) n c =-  case xs of-    []          -> n-    (k, v) : ys -> c k v (PSQ ys)--splits :: PSQ k a -> PSQ k (a, PSQ k a)-splits = go id-  where-    go f xs = casePSQ xs-        (PSQ [])-        (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys))--sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a-sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)--sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a-sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)---- | Given a measure in form of a pseudo-peano-natural number,--- determine the approximate minimum. This is designed to stop--- even traversing the list as soon as we find any element with--- measure 'ZeroOrOne'.------ Always returns a one-element queue (except if the queue is--- empty, then we return an empty queue again).----dminimumBy :: (a -> Degree) -> PSQ k a -> PSQ k a-dminimumBy _   (PSQ [])       = PSQ []-dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs-  where-    go ZeroOrOne v _ = PSQ [v]-    go _ v []        = PSQ [v]-    go c v (y : ys)  = case compare c d of-      LT -> go c v ys-      EQ -> go c v ys-      GT -> go d y ys-      where-        d = sel (snd y)--minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a-minimumBy sel (PSQ xs) =-  PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]---- | Will partition the list according to the predicate. If--- there is any element that satisfies the precidate, then only--- the elements satisfying the predicate are returned.--- Otherwise, the rest is returned.----prefer :: (a -> Bool) -> PSQ k a -> PSQ k a-prefer p (PSQ xs) =-  let-    (pro, con) = S.partition (p . snd) xs-  in-    if S.null pro then PSQ con else PSQ pro---- | Variant of 'prefer' that takes a continuation for the case--- that there are none of the desired elements.-preferOrElse :: (a -> Bool) -> (PSQ k a -> PSQ k a) -> PSQ k a -> PSQ k a-preferOrElse p k (PSQ xs) =-  let-    (pro, con) = S.partition (p . snd) xs-  in-    if S.null pro then k (PSQ con) else PSQ pro---- | Variant of 'prefer' that takes a predicate on the keys--- rather than on the values.----preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-preferByKeys p (PSQ xs) =-  let-    (pro, con) = S.partition (p . fst) xs-  in-    if S.null pro then PSQ con else PSQ pro--filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)--filter :: (a -> Bool) -> PSQ k a -> PSQ k a-filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)--length :: PSQ k a -> Int-length (PSQ xs) = S.length xs---- | Approximation of the branching degree.------ This is designed for computing the branching degree of a goal choice--- node. If the degree is 0 or 1, it is always good to take that goal,--- because we can either abort immediately, or have no other choice anyway.------ So we do not actually want to compute the full degree (which is--- somewhat costly) in cases where we have such an easy choice.----data Degree = ZeroOrOne | Two | Other-  deriving (Show, Eq)--instance Ord Degree where-  compare ZeroOrOne _         = LT -- lazy approximation-  compare _         ZeroOrOne = GT -- approximation-  compare Two       Two       = EQ-  compare Two       Other     = LT-  compare Other     Two       = GT-  compare Other     Other     = EQ--degree :: PSQ k a -> Degree-degree (PSQ [])     = ZeroOrOne-degree (PSQ [_])    = ZeroOrOne-degree (PSQ [_, _]) = Two-degree (PSQ _)      = Other--null :: PSQ k a -> Bool-null (PSQ xs) = S.null xs--isZeroOrOne :: PSQ k a -> Bool-isZeroOrOne (PSQ [])  = True-isZeroOrOne (PSQ [_]) = True-isZeroOrOne _         = False--firstOnly :: PSQ k a -> PSQ k a-firstOnly (PSQ [])      = PSQ []-firstOnly (PSQ (x : _)) = PSQ [x]--toList :: PSQ k a -> [(k, a)]-toList (PSQ xs) = xs--union :: PSQ k a -> PSQ k a -> PSQ k a-union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys)
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs 
@@ -1,175 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Package-  ( I(..)-  , Loc(..)-  , PackageId-  , PackageIdentifier(..)-  , PackageName(..)-  , PI(..)-  , PN-  , PP(..)-  , Namespace(..)-  , Qualifier(..)-  , QPN-  , QPV-  , Q(..)-  , instI-  , makeIndependent-  , primaryPP-  , showI-  , showPI-  , showQPN-  , unPN-  ) where--import Data.List as L--import Distribution.Package -- from Cabal-import Distribution.Text    -- from Cabal--import Distribution.Client.Dependency.Modular.Version---- | A package name.-type PN = PackageName---- | Unpacking a package name.-unPN :: PN -> String-unPN (PackageName pn) = pn---- | Package version. A package name plus a version number.-type PV = PackageId---- | Qualified package version.-type QPV = Q PV---- | Package id. Currently just a black-box string.-type PId = UnitId---- | Location. Info about whether a package is installed or not, and where--- exactly it is located. For installed packages, uniquely identifies the--- package instance via its 'PId'.------ TODO: More information is needed about the repo.-data Loc = Inst PId | InRepo-  deriving (Eq, Ord, Show)---- | Instance. A version number and a location.-data I = I Ver Loc-  deriving (Eq, Ord, Show)---- | String representation of an instance.-showI :: I -> String-showI (I v InRepo)   = showVer v-showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid-  where-    -- A hack to extract the beginning of the package ABI hash-    shortId (SimpleUnitId (ComponentId i))-            = snip (splitAt 4) (++ "...")-            . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)-            $ i-    snip p f xs = case p xs of-                    (ys, zs) -> (if L.null zs then id else f) ys---- | Package instance. A package name and an instance.-data PI qpn = PI qpn I-  deriving (Eq, Ord, Show, Functor)---- | String representation of a package instance.-showPI :: PI QPN -> String-showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i--instI :: I -> Bool-instI (I _ (Inst _)) = True-instI _              = False---- | A package path consists of a namespace and a package path inside that--- namespace.-data PP = PP Namespace Qualifier-  deriving (Eq, Ord, Show)---- | Top-level namespace------ Package choices in different namespaces are considered completely independent--- by the solver.-data Namespace =-    -- | The default namespace-    DefaultNamespace--    -- | Independent namespace-    ---    -- For now we just number these (rather than giving them more structure).-  | Independent Int-  deriving (Eq, Ord, Show)---- | Qualifier of a package within a namespace (see 'PP')-data Qualifier =-    -- | Top-level dependency in this namespace-    Unqualified--    -- | Any dependency on base is considered independent-    ---    -- This makes it possible to have base shims.-  | Base PN--    -- | Setup dependency-    ---    -- By rights setup dependencies ought to be nestable; after all, the setup-    -- dependencies of a package might themselves have setup dependencies, which-    -- are independent from everything else. However, this very quickly leads to-    -- infinite search trees in the solver. Therefore we limit ourselves to-    -- a single qualifier (within a given namespace).-  | Setup PN-  deriving (Eq, Ord, Show)---- | Is the package in the primary group of packages. In particular this--- does not include packages pulled in as setup deps.----primaryPP :: PP -> Bool-primaryPP (PP _ns q) = go q-  where-    go Unqualified = True-    go (Base  _)   = True-    go (Setup _)   = False---- | String representation of a package path.------ NOTE: The result of 'showPP' is either empty or results in a period, so that--- it can be prepended to a package name.-showPP :: PP -> String-showPP (PP ns q) =-    case ns of-      DefaultNamespace -> go q-      Independent i    -> show i ++ "." ++ go q-  where-    -- Print the qualifier-    ---    -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is-    -- there to make sure different dependencies on base are all independent.-    -- So we want to print something like @"A.base"@, where the @"A."@ part-    -- is the qualifier and @"base"@ is the actual dependency (which, for the-    -- 'Base' qualifier, will always be @base@).-    go Unqualified = ""-    go (Setup pn)  = display pn ++ "-setup."-    go (Base  pn)  = display pn ++ "."---- | A qualified entity. Pairs a package path with the entity.-data Q a = Q PP a-  deriving (Eq, Ord, Show)---- | Standard string representation of a qualified entity.-showQ :: (a -> String) -> (Q a -> String)-showQ showa (Q pp x) = showPP pp ++ showa x---- | Qualified package name.-type QPN = Q PN---- | String representation of a qualified package path.-showQPN :: QPN -> String-showQPN = showQ display---- | Create artificial parents for each of the package names, making--- them all independent.-makeIndependent :: [PN] -> [QPN]-makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]-                               , let pp = PP (Independent i) Unqualified-                     ]
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs 
@@ -1,394 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Preference-    ( avoidReinstalls-    , deferSetupChoices-    , deferWeakFlagChoices-    , enforceManualFlags-    , enforcePackageConstraints-    , enforceSingleInstanceRestriction-    , firstGoal-    , preferBaseGoalChoice-    , preferEasyGoalChoices-    , preferLinked-    , preferPackagePreferences-    , preferReallyEasyGoalChoices-    , requireInstalled-    ) where---- Reordering or pruning the tree in order to prefer or make certain choices.--import qualified Data.List as L-import qualified Data.Map as M-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-import Control.Applicative-#endif-import qualified Data.Set as S-import Prelude hiding (sequence)-import Control.Monad.Reader hiding (sequence)-import Data.Map (Map)-import Data.Traversable (sequence)--import Distribution.Client.Dependency.Types-  ( PackageConstraint(..), LabeledPackageConstraint(..), ConstraintSource(..)-  , PackagePreferences(..), InstalledPreference(..) )-import Distribution.Client.Types-  ( OptionalStanza(..) )--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Tree-import Distribution.Client.Dependency.Modular.Version---- | Generic abstraction for strategies that just rearrange the package order.--- Only packages that match the given predicate are reordered.-packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a-packageOrderFor p cmp' = trav go-  where-    go (PChoiceF v@(Q _ pn) r cs)-      | p pn                        = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs)-      | otherwise                   = PChoiceF v r                               cs-    go x                            = x--    cmp :: PN -> POption -> POption -> Ordering-    cmp pn (POption i _) (POption i' _) = cmp' pn i i'---- | Prefer to link packages whenever possible-preferLinked :: Tree a -> Tree a-preferLinked = trav go-  where-    go (PChoiceF qn a  cs) = PChoiceF qn a (P.sortByKeys cmp cs)-    go x                   = x--    cmp (POption _ linkedTo) (POption _ linkedTo') = cmpL linkedTo linkedTo'--    cmpL Nothing  Nothing  = EQ-    cmpL Nothing  (Just _) = GT-    cmpL (Just _) Nothing  = LT-    cmpL (Just _) (Just _) = EQ---- | Ordering that treats versions satisfying more preferred ranges as greater---   than versions satisfying less preferred ranges.-preferredVersionsOrdering :: [VR] -> Ver -> Ver -> Ordering-preferredVersionsOrdering vrs v1 v2 = compare (check v1) (check v2)-  where-     check v = Prelude.length . Prelude.filter (==True) .-               Prelude.map (flip checkVR v) $ vrs---- | Traversal that tries to establish package preferences (not constraints).--- Works by reordering choice nodes. Also applies stanza preferences.-preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a-preferPackagePreferences pcs = preferPackageStanzaPreferences pcs-                             . packageOrderFor (const True) preference-  where-    preference pn i1@(I v1 _) i2@(I v2 _) =-      let PackagePreferences vrs ipref _ = pcs pn-      in  preferredVersionsOrdering vrs v1 v2 `mappend` -- combines lexically-          locationsOrdering ipref i1 i2--    -- Note that we always rank installed before uninstalled, and later-    -- versions before earlier, but we can change the priority of the-    -- two orderings.-    locationsOrdering PreferInstalled v1 v2 =-      preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2-    locationsOrdering PreferLatest v1 v2 =-      preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2---- | Ordering that treats installed instances as greater than uninstalled ones.-preferInstalledOrdering :: I -> I -> Ordering-preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ-preferInstalledOrdering (I _ (Inst _)) _              = GT-preferInstalledOrdering _              (I _ (Inst _)) = LT-preferInstalledOrdering _              _              = EQ---- | Compare instances by their version numbers.-preferLatestOrdering :: I -> I -> Ordering-preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2---- | Traversal that tries to establish package stanza enable\/disable--- preferences. Works by reordering the branches of stanza choices.-preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a-preferPackageStanzaPreferences pcs = trav go-  where-    go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts) | primaryPP pp =-        let PackagePreferences _ _ spref = pcs pn-            enableStanzaPref = s `elem` spref-                  -- move True case first to try enabling the stanza-            ts' | enableStanzaPref = P.sortByKeys (flip compare) ts-                | otherwise        = ts-         in SChoiceF qsn gr True ts'   -- True: now weak choice-    go x = x---- | Helper function that tries to enforce a single package constraint on a--- given instance for a P-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintP :: PP-                          -> ConflictSet QPN-                          -> I-                          -> LabeledPackageConstraint-                          -> Tree a-                          -> Tree a-processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r-  | src == ConstraintSourceUserTarget && not (primaryPP pp)         = r-    -- the constraints arising from targets, like "foo-1.0" only apply to-    -- the main packages in the solution, they don't constrain setup deps--processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc-  where-    go (I v _) (PackageConstraintVersion _ vr)-        | checkVR vr v  = r-        | otherwise     = Fail c (GlobalConstraintVersion vr src)-    go _       (PackageConstraintInstalled _)-        | instI i       = r-        | otherwise     = Fail c (GlobalConstraintInstalled src)-    go _       (PackageConstraintSource    _)-        | not (instI i) = r-        | otherwise     = Fail c (GlobalConstraintSource src)-    go _       _ = r---- | Helper function that tries to enforce a single package constraint on a--- given flag setting for an F-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintF :: Flag-                          -> ConflictSet QPN-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree a-                          -> Tree a-processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc-  where-    go (PackageConstraintFlags _ fa) =-        case L.lookup f fa of-          Nothing            -> r-          Just b | b == b'   -> r-                 | otherwise -> Fail c (GlobalConstraintFlag src)-    go _                             = r---- | Helper function that tries to enforce a single package constraint on a--- given flag setting for an F-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintS :: OptionalStanza-                          -> ConflictSet QPN-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree a-                          -> Tree a-processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc-  where-    go (PackageConstraintStanzas _ ss) =-        if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)-                                 else r-    go _                               = r---- | Traversal that tries to establish various kinds of user constraints. Works--- by selectively disabling choices that have been ruled out by global user--- constraints.-enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]-                          -> Tree QGoalReasonChain-                          -> Tree QGoalReasonChain-enforcePackageConstraints pcs = trav go-  where-    go (PChoiceF qpn@(Q pp pn)              gr      ts) =-      let c = toConflictSet (Goal (P qpn) gr)-          -- compose the transformation functions for each of the relevant constraint-          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP pp c i pc) id-                           (M.findWithDefault [] pn pcs)-      in PChoiceF qpn gr      (P.mapWithKey g ts)-    go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =-      let c = toConflictSet (Goal (F qfn) gr)-          -- compose the transformation functions for each of the relevant constraint-          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id-                           (M.findWithDefault [] pn pcs)-      in FChoiceF qfn gr tr m (P.mapWithKey g ts)-    go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr   ts) =-      let c = toConflictSet (Goal (S qsn) gr)-          -- compose the transformation functions for each of the relevant constraint-          g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id-                           (M.findWithDefault [] pn pcs)-      in SChoiceF qsn gr tr   (P.mapWithKey g ts)-    go x = x---- | Transformation that tries to enforce manual flags. Manual flags--- can only be re-set explicitly by the user. This transformation should--- be run after user preferences have been enforced. For manual flags,--- it checks if a user choice has been made. If not, it disables all but--- the first choice.-enforceManualFlags :: Tree QGoalReasonChain -> Tree QGoalReasonChain-enforceManualFlags = trav go-  where-    go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $-      let c = toConflictSet (Goal (F qfn) gr)-      in  case span isDisabled (P.toList ts) of-            ([], y : ys) -> P.fromList (y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)-            _            -> ts -- something has been manually selected, leave things alone-      where-        isDisabled (_, Fail _ (GlobalConstraintFlag _)) = True-        isDisabled _                                    = False-    go x                                                   = x---- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain-requireInstalled p = trav go-  where-    go (PChoiceF v@(Q _ pn) gr cs)-      | p pn      = PChoiceF v gr (P.mapWithKey installed cs)-      | otherwise = PChoiceF v gr                         cs-      where-        installed (POption (I _ (Inst _)) _) x = x-        installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall-    go x          = x---- | Avoid reinstalls.------ This is a tricky strategy. If a package version is installed already and the--- same version is available from a repo, the repo version will never be chosen.--- This would result in a reinstall (either destructively, or potentially,--- shadowing). The old instance won't be visible or even present anymore, but--- other packages might have depended on it.------ TODO: It would be better to actually check the reverse dependencies of installed--- packages. If they're not depended on, then reinstalling should be fine. Even if--- they are, perhaps this should just result in trying to reinstall those other--- packages as well. However, doing this all neatly in one pass would require to--- change the builder, or at least to change the goal set after building.-avoidReinstalls :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain-avoidReinstalls p = trav go-  where-    go (PChoiceF qpn@(Q _ pn) gr cs)-      | p pn      = PChoiceF qpn gr disableReinstalls-      | otherwise = PChoiceF qpn gr cs-      where-        disableReinstalls =-          let installed = [ v | (POption (I v (Inst _)) _, _) <- P.toList cs ]-          in  P.mapWithKey (notReinstall installed) cs--        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =-          Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall-        notReinstall _ _ x =-          x-    go x          = x---- | Always choose the first goal in the list next, abandoning all--- other choices.------ This is unnecessary for the default search strategy, because--- it descends only into the first goal choice anyway,--- but may still make sense to just reduce the tree size a bit.-firstGoal :: Tree a -> Tree a-firstGoal = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs)-    go x                = x-    -- Note that we keep empty choice nodes, because they mean success.---- | Transformation that tries to make a decision on base as early as--- possible. In nearly all cases, there's a single choice for the base--- package. Also, fixing base early should lead to better error messages.-preferBaseGoalChoice :: Tree a -> Tree a-preferBaseGoalChoice = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs)-    go x                = x--    isBase :: OpenGoal comp -> Bool-    isBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = True-    isBase _                                                              = False---- | Deal with setup dependencies after regular dependencies, so that we can--- will link setup depencencies against package dependencies when possible-deferSetupChoices :: Tree a -> Tree a-deferSetupChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs)-    go x                = x--    noSetup :: OpenGoal comp -> Bool-    noSetup (OpenGoal (Simple (Dep (Q (PP _ns (Setup _)) _) _) _) _) = False-    noSetup _                                                        = True---- | Transformation that tries to avoid making weak flag choices early.--- Weak flags are trivial flags (not influencing dependencies) or such--- flags that are explicitly declared to be weak in the index.-deferWeakFlagChoices :: Tree a -> Tree a-deferWeakFlagChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs))-    go x                = x--    noWeakStanza :: Tree a -> Bool-    noWeakStanza (SChoice _ _ True _) = False-    noWeakStanza _                    = True--    noWeakFlag :: Tree a -> Bool-    noWeakFlag (FChoice _ _ True _ _) = False-    noWeakFlag _                      = True---- | Transformation that sorts choice nodes so that--- child nodes with a small branching degree are preferred.------ Only approximates the number of choices in the branches.--- In particular, we try to take any goal immediately if it has--- a branching degree of 0 (guaranteed failure) or 1 (no other--- choice possible).------ Returns at most one choice.----preferEasyGoalChoices :: Tree a -> Tree a-preferEasyGoalChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs)-      -- (a different implementation that seems slower):-      -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs))-    go x                = x---- | A variant of 'preferEasyGoalChoices' that just keeps the--- ones with a branching degree of 0 or 1. Note that unlike--- 'preferEasyGoalChoices', this may return more than one--- choice.----preferReallyEasyGoalChoices :: Tree a -> Tree a-preferReallyEasyGoalChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.prefer zeroOrOneChoices xs)-    go x                = x---- | Monad used internally in enforceSingleInstanceRestriction-type EnforceSIR = Reader (Map (PI PN) QPN)---- | Enforce ghc's single instance restriction------ From the solver's perspective, this means that for any package instance--- (that is, package name + package version) there can be at most one qualified--- goal resolving to that instance (there may be other goals _linking_ to that--- instance however).-enforceSingleInstanceRestriction :: Tree QGoalReasonChain -> Tree QGoalReasonChain-enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go-  where-    go :: TreeF QGoalReasonChain (EnforceSIR (Tree QGoalReasonChain)) -> EnforceSIR (Tree QGoalReasonChain)--    -- We just verify package choices.-    go (PChoiceF qpn gr cs) =-      PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs)-    go _otherwise =-      innM _otherwise--    -- The check proper-    goP :: QPN -> POption -> EnforceSIR (Tree QGoalReasonChain) -> EnforceSIR (Tree QGoalReasonChain)-    goP qpn@(Q _ pn) (POption i linkedTo) r = do-      let inst = PI pn i-      env <- ask-      case (linkedTo, M.lookup inst env) of-        (Just _, _) ->-          -- For linked nodes we don't check anything-          r-        (Nothing, Nothing) ->-          -- Not linked, not already used-          local (M.insert inst qpn) r-        (Nothing, Just qpn') -> do-          -- Not linked, already used. This is an error-          return $ Fail (S.fromList [P qpn, P qpn']) MultipleInstances
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs 
@@ -1,100 +0,0 @@-module Distribution.Client.Dependency.Modular.Solver-    ( SolverConfig(..)-    , solve-    ) where--import Data.Map as M--import Distribution.Compiler (CompilerInfo)--import Distribution.Client.PkgConfigDb (PkgConfigDb)--import Distribution.Client.Dependency.Types--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Builder-import Distribution.Client.Dependency.Modular.Cycles-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Explore-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Log-import Distribution.Client.Dependency.Modular.Message-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.Preference as P-import Distribution.Client.Dependency.Modular.Validate-import Distribution.Client.Dependency.Modular.Linking---- | Various options for the modular solver.-data SolverConfig = SolverConfig {-  preferEasyGoalChoices :: Bool,-  independentGoals      :: Bool,-  avoidReinstalls       :: Bool,-  shadowPkgs            :: Bool,-  strongFlags           :: Bool,-  maxBackjumps          :: Maybe Int-}---- | Run all solver phases.------ In principle, we have a valid tree after 'validationPhase', which--- means that every 'Done' node should correspond to valid solution.------ There is one exception, though, and that is cycle detection, which--- has been added relatively recently. Cycles are only removed directly--- before exploration.------ Semantically, there is no difference. Cycle detection, as implemented--- now, only occurs for 'Done' nodes we encounter during exploration,--- and cycle detection itself does not change the shape of the tree,--- it only marks some 'Done' nodes as 'Fail', if they contain cyclic--- solutions.------ There is a tiny performance impact, however, in doing cycle detection--- directly after validation. Probably because cycle detection maintains--- some information, and the various reorderings implemented by--- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more--- costly if that information is already around during the reorderings.------ With the current positioning directly before the 'explorePhase', there--- seems to be no statistically significant performance impact of cycle--- detection in the common case where there are no cycles.----solve :: SolverConfig ->                      -- ^ solver parameters-         CompilerInfo ->-         Index ->                             -- ^ all available packages as an index-         PkgConfigDb ->                       -- ^ available pkg-config pkgs-         (PN -> PackagePreferences) ->        -- ^ preferences-         Map PN [LabeledPackageConstraint] -> -- ^ global constraints-         [PN] ->                              -- ^ global goals-         Log Message (Assignment, RevDepMap)-solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =-  explorePhase     $-  detectCyclesPhase$-  heuristicsPhase  $-  preferencesPhase $-  validationPhase  $-  prunePhase       $-  buildPhase-  where-    explorePhase     = backjumpAndExplore-    heuristicsPhase  = (if preferEasyGoalChoices sc-                         then P.preferEasyGoalChoices -- also leaves just one choice-                         else P.firstGoal) . -- after doing goal-choice heuristics, commit to the first choice (saves space)-                       P.deferWeakFlagChoices .-                       P.deferSetupChoices .-                       P.preferBaseGoalChoice .-                       P.preferLinked-    preferencesPhase = P.preferPackagePreferences userPrefs-    validationPhase  = P.enforceManualFlags . -- can only be done after user constraints-                       P.enforcePackageConstraints userConstraints .-                       P.enforceSingleInstanceRestriction .-                       validateLinking idx .-                       validateTree cinfo idx pkgConfigDB-    prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .-                       -- packages that can never be "upgraded":-                       P.requireInstalled (`elem` [ PackageName "base"-                                                  , PackageName "ghc-prim"-                                                  , PackageName "integer-gmp"-                                                  , PackageName "integer-simple"-                                                  ])-    buildPhase       = addLinking $ buildTree idx (independentGoals sc) userGoals
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs 
@@ -1,169 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.Tree-    ( FailReason(..)-    , POption(..)-    , Tree(..)-    , TreeF(..)-    , ana-    , cata-    , choices-    , dchoices-    , inn-    , innM-    , para-    , trav-    , zeroOrOneChoices-    ) where--import Control.Monad hiding (mapM, sequence)-import Data.Foldable-import Data.Traversable-import Prelude hiding (foldr, mapM, sequence)--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ (PSQ)-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Version-import Distribution.Client.Dependency.Types ( ConstraintSource(..) )---- | Type of the search tree. Inlining the choice nodes for now.-data Tree a =-    PChoice     QPN a           (PSQ POption       (Tree a))-  | FChoice     QFN a Bool Bool (PSQ Bool          (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual-  | SChoice     QSN a Bool      (PSQ Bool          (Tree a)) -- Bool indicates whether it's trivial-  | GoalChoice                  (PSQ (OpenGoal ()) (Tree a)) -- PSQ should never be empty-  | Done        RevDepMap-  | Fail        (ConflictSet QPN) FailReason-  deriving (Eq, Show, Functor)-  -- Above, a choice is called trivial if it clearly does not matter. The-  -- special case of triviality we actually consider is if there are no new-  -- dependencies introduced by this node.-  ---  -- A (flag) choice is called weak if we do want to defer it. This is the-  -- case for flags that should be implied by what's currently installed on-  -- the system, as opposed to flags that are used to explicitly enable or-  -- disable some functionality.---- | A package option is a package instance with an optional linking annotation------ The modular solver has a number of package goals to solve for, and can only--- pick a single package version for a single goal. In order to allow to--- install multiple versions of the same package as part of a single solution--- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both--- be qualified goals for @P@, allowing to pick a difference version of package--- @P@ for @0.P@ and @1.P@.------ Linking is an essential part of this story. In addition to picking a specific--- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or--- vice versa). It means that @1.P@ and @0.P@ really must be the very same package--- (and hence must have the same build time configuration, and their--- dependencies must also be the exact same).------ See <http://www.well-typed.com/blog/2015/03/qualified-goals/> for details.-data POption = POption I (Maybe PP)-  deriving (Eq, Show)--data FailReason = InconsistentInitialConstraints-                | Conflicting [Dep QPN]-                | CannotInstall-                | CannotReinstall-                | Shadowed-                | Broken-                | GlobalConstraintVersion VR ConstraintSource-                | GlobalConstraintInstalled ConstraintSource-                | GlobalConstraintSource ConstraintSource-                | GlobalConstraintFlag ConstraintSource-                | ManualFlag-                | BuildFailureNotInIndex PN-                | MalformedFlagChoice QFN-                | MalformedStanzaChoice QSN-                | EmptyGoalChoice-                | Backjump-                | MultipleInstances-                | DependenciesNotLinked String-                | CyclicDependencies-  deriving (Eq, Show)---- | Functor for the tree type.-data TreeF a b =-    PChoiceF    QPN a           (PSQ POption       b)-  | FChoiceF    QFN a Bool Bool (PSQ Bool          b)-  | SChoiceF    QSN a Bool      (PSQ Bool          b)-  | GoalChoiceF                 (PSQ (OpenGoal ()) b)-  | DoneF       RevDepMap-  | FailF       (ConflictSet QPN) FailReason-  deriving (Functor, Foldable, Traversable)--out :: Tree a -> TreeF a (Tree a)-out (PChoice    p i     ts) = PChoiceF    p i     ts-out (FChoice    p i b m ts) = FChoiceF    p i b m ts-out (SChoice    p i b   ts) = SChoiceF    p i b   ts-out (GoalChoice         ts) = GoalChoiceF         ts-out (Done       x         ) = DoneF       x-out (Fail       c x       ) = FailF       c x--inn :: TreeF a (Tree a) -> Tree a-inn (PChoiceF    p i     ts) = PChoice    p i     ts-inn (FChoiceF    p i b m ts) = FChoice    p i b m ts-inn (SChoiceF    p i b   ts) = SChoice    p i b   ts-inn (GoalChoiceF         ts) = GoalChoice         ts-inn (DoneF       x         ) = Done       x-inn (FailF       c x       ) = Fail       c x--innM :: Monad m => TreeF a (m (Tree a)) -> m (Tree a)-innM (PChoiceF    p i     ts) = liftM (PChoice    p i    ) (sequence ts)-innM (FChoiceF    p i b m ts) = liftM (FChoice    p i b m) (sequence ts)-innM (SChoiceF    p i b   ts) = liftM (SChoice    p i b  ) (sequence ts)-innM (GoalChoiceF         ts) = liftM (GoalChoice        ) (sequence ts)-innM (DoneF       x         ) = return $ Done     x-innM (FailF       c x       ) = return $ Fail     c x---- | Determines whether a tree is active, i.e., isn't a failure node.-active :: Tree a -> Bool-active (Fail _ _) = False-active _          = True---- | Determines how many active choices are available in a node. Note that we--- count goal choices as having one choice, always.-choices :: Tree a -> Int-choices (PChoice    _ _     ts) = P.length (P.filter active ts)-choices (FChoice    _ _ _ _ ts) = P.length (P.filter active ts)-choices (SChoice    _ _ _   ts) = P.length (P.filter active ts)-choices (GoalChoice         _ ) = 1-choices (Done       _         ) = 1-choices (Fail       _ _       ) = 0---- | Variant of 'choices' that only approximates the number of choices.-dchoices :: Tree a -> P.Degree-dchoices (PChoice    _ _     ts) = P.degree (P.filter active ts)-dchoices (FChoice    _ _ _ _ ts) = P.degree (P.filter active ts)-dchoices (SChoice    _ _ _   ts) = P.degree (P.filter active ts)-dchoices (GoalChoice         _ ) = P.ZeroOrOne-dchoices (Done       _         ) = P.ZeroOrOne-dchoices (Fail       _ _       ) = P.ZeroOrOne---- | Variant of 'choices' that only approximates the number of choices.-zeroOrOneChoices :: Tree a -> Bool-zeroOrOneChoices (PChoice    _ _     ts) = P.isZeroOrOne (P.filter active ts)-zeroOrOneChoices (FChoice    _ _ _ _ ts) = P.isZeroOrOne (P.filter active ts)-zeroOrOneChoices (SChoice    _ _ _   ts) = P.isZeroOrOne (P.filter active ts)-zeroOrOneChoices (GoalChoice         _ ) = True-zeroOrOneChoices (Done       _         ) = True-zeroOrOneChoices (Fail       _ _       ) = True---- | Catamorphism on trees.-cata :: (TreeF a b -> b) -> Tree a -> b-cata phi x = (phi . fmap (cata phi) . out) x--trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b-trav psi x = cata (inn . psi) x---- | Paramorphism on trees.-para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b-para phi = phi . fmap (\ x -> (para phi x, x)) . out---- | Anamorphism on trees.-ana :: (b -> TreeF a b) -> b -> Tree a-ana psi = inn . fmap (ana psi) . psi
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs 
@@ -1,270 +0,0 @@-module Distribution.Client.Dependency.Modular.Validate (validateTree) where---- Validation of the tree.------ The task here is to make sure all constraints hold. After validation, any--- assignment returned by exploration of the tree should be a complete valid--- assignment, i.e., actually constitute a solution.--import Control.Applicative-import Control.Monad.Reader hiding (sequence)-import Data.List as L-import Data.Map as M-import Data.Set as S-import Data.Traversable-import Prelude hiding (sequence)--import Language.Haskell.Extension (Extension, Language)--import Distribution.Compiler (CompilerInfo(..))--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Tree-import Distribution.Client.Dependency.Modular.Version (VR)--import Distribution.Client.ComponentDeps (Component)-import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)---- In practice, most constraints are implication constraints (IF we have made--- a number of choices, THEN we also have to ensure that). We call constraints--- that for which the preconditions are fulfilled ACTIVE. We maintain a set--- of currently active constraints that we pass down the node.------ We aim at detecting inconsistent states as early as possible.------ Whenever we make a choice, there are two things that need to happen:------   (1) We must check that the choice is consistent with the currently---       active constraints.------   (2) The choice increases the set of active constraints. For the new---       active constraints, we must check that they are consistent with---       the current state.------ We can actually merge (1) and (2) by saying the the current choice is--- a new active constraint, fixing the choice.------ If a test fails, we have detected an inconsistent state. We can--- disable the current subtree and do not have to traverse it any further.------ We need a good way to represent the current state, i.e., the current--- set of active constraints. Since the main situation where we have to--- search in it is (1), it seems best to store the state by package: for--- every package, we store which versions are still allowed. If for any--- package, we have inconsistent active constraints, we can also stop.--- This is a particular way to read task (2):------   (2, weak) We only check if the new constraints are consistent with---       the choices we've already made, and add them to the active set.------   (2, strong) We check if the new constraints are consistent with the---       choices we've already made, and the constraints we already have.------ It currently seems as if we're implementing the weak variant. However,--- when used together with 'preferEasyGoalChoices', we will find an--- inconsistent state in the very next step.------ What do we do about flags?------ Like for packages, we store the flag choices we have already made.--- Now, regarding (1), we only have to test whether we've decided the--- current flag before. Regarding (2), the interesting bit is in discovering--- the new active constraints. To this end, we look up the constraints for--- the package the flag belongs to, and traverse its flagged dependencies.--- Wherever we find the flag in question, we start recording dependencies--- underneath as new active dependencies. If we encounter other flags, we--- check if we've chosen them already and either proceed or stop.---- | The state needed during validation.-data ValidateState = VS {-  supportedExt  :: Extension -> Bool,-  supportedLang :: Language  -> Bool,-  presentPkgs   :: PN -> VR  -> Bool,-  index :: Index,-  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies-  pa    :: PreAssignment,-  qualifyOptions :: QualifyOptions-}--type Validate = Reader ValidateState--validate :: Tree QGoalReasonChain -> Validate (Tree QGoalReasonChain)-validate = cata go-  where-    go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)--    go (PChoiceF qpn gr     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr) ts)-    go (FChoiceF qfn gr b m ts) =-      do-        -- Flag choices may occur repeatedly (because they can introduce new constraints-        -- in various places). However, subsequent choices must be consistent. We thereby-        -- collapse repeated flag choice nodes.-        PA _ pfa _ <- asks pa -- obtain current flag-preassignment-        case M.lookup qfn pfa of-          Just rb -> -- flag has already been assigned; collapse choice to the correct branch-                     case P.lookup rb ts of-                       Just t  -> goF qfn gr rb t-                       Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)-          Nothing -> -- flag choice is new, follow both branches-                     FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts)-    go (SChoiceF qsn gr b   ts) =-      do-        -- Optional stanza choices are very similar to flag choices.-        PA _ _ psa <- asks pa -- obtain current stanza-preassignment-        case M.lookup qsn psa of-          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch-                     case P.lookup rb ts of-                       Just t  -> goS qsn gr rb t-                       Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn)-          Nothing -> -- stanza choice is new, follow both branches-                     SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn gr) ts)--    -- We don't need to do anything for goal choices or failure nodes.-    go (GoalChoiceF              ts) = GoalChoice <$> sequence ts-    go (DoneF    rdm               ) = pure (Done rdm)-    go (FailF    c fr              ) = pure (Fail c fr)--    -- What to do for package nodes ...-    goP :: QPN -> QGoalReasonChain -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goP qpn@(Q _pp pn) gr (POption i _) r = do-      PA ppa pfa psa <- asks pa    -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs-      idx            <- asks index -- obtain the index-      svd            <- asks saved -- obtain saved dependencies-      qo             <- asks qualifyOptions-      -- obtain dependencies and index-dictated exclusions introduced by the choice-      let (PInfo deps _ mfr) = idx ! pn ! i-      -- qualify the deps in the current scope-      let qdeps = qualifyDeps qo qpn deps-      -- the new active constraints are given by the instance we have chosen,-      -- plus the dependency information we have for that instance-      let goal = Goal (P qpn) gr-      let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)-      -- We now try to extend the partial assignment with the new active constraints.-      let mnppa = extend extSupported langSupported pkgPresent goal ppa newactives-      -- In case we continue, we save the scoped dependencies-      let nsvd = M.insert qpn qdeps svd-      case mfr of-        Just fr -> -- The index marks this as an invalid choice. We can stop.-                   return (Fail (toConflictSet goal) fr)-        _       -> case mnppa of-                     Left (c, d) -> -- We have an inconsistency. We can stop.-                                    return (Fail c (Conflicting d))-                     Right nppa  -> -- We have an updated partial assignment for the recursive validation.-                                    local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r--    -- What to do for flag nodes ...-    goF :: QFN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goF qfn@(FN (PI qpn _i) _f) gr b r = do-      PA ppa pfa psa <- asks pa -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs   -- obtain the present pkg-config pkgs-      svd <- asks saved         -- obtain saved dependencies-      -- Note that there should be saved dependencies for the package in question,-      -- because while building, we do not choose flags before we see the packages-      -- that define them.-      let qdeps = svd ! qpn-      -- We take the *saved* dependencies, because these have been qualified in the-      -- correct scope.-      ---      -- Extend the flag assignment-      let npfa = M.insert qfn b pfa-      -- We now try to get the new active dependencies we might learn about because-      -- we have chosen a new flag.-      let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps-      -- As in the package case, we try to extend the partial assignment.-      case extend extSupported langSupported pkgPresent (Goal (F qfn) gr) ppa newactives of-        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found-        Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r--    -- What to do for stanza nodes (similar to flag nodes) ...-    goS :: QSN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goS qsn@(SN (PI qpn _i) _f) gr b r = do-      PA ppa pfa psa <- asks pa -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs-      svd <- asks saved         -- obtain saved dependencies-      -- Note that there should be saved dependencies for the package in question,-      -- because while building, we do not choose flags before we see the packages-      -- that define them.-      let qdeps = svd ! qpn-      -- We take the *saved* dependencies, because these have been qualified in the-      -- correct scope.-      ---      -- Extend the flag assignment-      let npsa = M.insert qsn b psa-      -- We now try to get the new active dependencies we might learn about because-      -- we have chosen a new flag.-      let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps-      -- As in the package case, we try to extend the partial assignment.-      case extend extSupported langSupported pkgPresent (Goal (S qsn) gr) ppa newactives of-        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found-        Right nppa  -> local (\ s -> s { pa = PA nppa pfa npsa }) r---- | We try to extract as many concrete dependencies from the given flagged--- dependencies as possible. We make use of all the flag knowledge we have--- already acquired.-extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]-extractDeps fa sa deps = do-  d <- deps-  case d of-    Simple sd _         -> return sd-    Flagged qfn _ td fd -> case M.lookup qfn fa of-                             Nothing    -> mzero-                             Just True  -> extractDeps fa sa td-                             Just False -> extractDeps fa sa fd-    Stanza qsn td       -> case M.lookup qsn sa of-                             Nothing    -> mzero-                             Just True  -> extractDeps fa sa td-                             Just False -> []---- | We try to find new dependencies that become available due to the given--- flag or stanza choice. We therefore look for the choice in question, and then call--- 'extractDeps' for everything underneath.-extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]-extractNewDeps v gr b fa sa = go-  where-    go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)-    go deps = do-      d <- deps-      case d of-        Simple _ _           -> mzero-        Flagged qfn' _ td fd-          | v == F qfn'      -> L.map (resetGoal (Goal v gr)) $-                                if b then extractDeps fa sa td else extractDeps fa sa fd-          | otherwise        -> case M.lookup qfn' fa of-                                  Nothing    -> mzero-                                  Just True  -> go td-                                  Just False -> go fd-        Stanza qsn' td-          | v == S qsn'      -> L.map (resetGoal (Goal v gr)) $-                                if b then extractDeps fa sa td else []-          | otherwise        -> case M.lookup qsn' sa of-                                  Nothing    -> mzero-                                  Just True  -> go td-                                  Just False -> []---- | Interface.-validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree QGoalReasonChain -> Tree QGoalReasonChain-validateTree cinfo idx pkgConfigDb t = runReader (validate t) VS {-    supportedExt   = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported-                           (\ es -> let s = S.fromList es in \ x -> S.member x s)-                           (compilerInfoExtensions cinfo)-  , supportedLang  = maybe (const True)-                           (flip L.elem) -- use list lookup because language list is small and no Ord instance-                           (compilerInfoLanguages  cinfo)-  , presentPkgs    = pkgConfigPkgIsPresent pkgConfigDb-  , index          = idx-  , saved          = M.empty-  , pa             = PA M.empty M.empty M.empty-  , qualifyOptions = defaultQualifyOptions idx-  }
− cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs 
@@ -1,53 +0,0 @@-module Distribution.Client.Dependency.Modular.Version-    ( Ver-    , VR-    , anyVR-    , checkVR-    , eqVR-    , showVer-    , showVR-    , simplifyVR-    , (.&&.)-    , (.||.)-    ) where--import qualified Distribution.Version as CV -- from Cabal-import Distribution.Text -- from Cabal---- | Preliminary type for versions.-type Ver = CV.Version---- | String representation of a version.-showVer :: Ver -> String-showVer = display---- | Version range. Consists of a lower and upper bound.-type VR = CV.VersionRange---- | String representation of a version range.-showVR :: VR -> String-showVR = display---- | Unconstrained version range.-anyVR :: VR-anyVR = CV.anyVersion---- | Version range fixing a single version.-eqVR :: Ver -> VR-eqVR = CV.thisVersion---- | Intersect two version ranges.-(.&&.) :: VR -> VR -> VR-(.&&.) = CV.intersectVersionRanges---- | Union of two version ranges.-(.||.) :: VR -> VR -> VR-(.||.) = CV.unionVersionRanges---- | Simplify a version range.-simplifyVR :: VR -> VR-simplifyVR = CV.simplifyVersionRange---- | Checking a version against a version range.-checkVR :: VR -> Ver -> Bool-checkVR = flip CV.withinRange
− cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs 
@@ -1,1081 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.-------------------------------------------------------------------------------module Distribution.Client.Dependency.TopDown (-    topDownResolver-  ) where--import Distribution.Client.Dependency.TopDown.Types-import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints-import Distribution.Client.Dependency.TopDown.Constraints-         ( Satisfiable(..) )-import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..)-         , UnresolvedPkgLoc, UnresolvedSourcePackage-         , enableStanzas, ConfiguredId(..), fakeUnitId )-import Distribution.Client.Dependency.Types-         ( DependencyResolver, ResolverPackage(..)-         , PackageConstraint(..), unlabelPackageConstraint-         , PackagePreferences(..), InstalledPreference(..)-         , Progress(..), foldProgress )--import qualified Distribution.Client.PackageIndex as PackageIndex-import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.Client.ComponentDeps-         ( ComponentDeps )-import qualified Distribution.Client.ComponentDeps as CD-import Distribution.Client.PackageIndex-         ( PackageIndex )-import Distribution.Package-         ( PackageName(..), PackageId, PackageIdentifier(..)-         , UnitId(..), ComponentId(..)-         , Package(..), packageVersion, packageName-         , Dependency(Dependency), thisPackageVersion, simplifyDependency )-import Distribution.PackageDescription-         ( PackageDescription(buildDepends) )-import Distribution.Client.PackageUtils-         ( externalBuildDepends )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription, flattenPackageDescription )-import Distribution.Version-         ( Version(..), VersionRange, withinRange, simplifyVersionRange-         , UpperBound(..), asVersionIntervals )-import Distribution.Compiler-         ( CompilerInfo )-import Distribution.System-         ( Platform )-import Distribution.Simple.Utils-         ( equating, comparing )-import Distribution.Text-         ( display )--import Data.List-         ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy )-import Data.Maybe-         ( fromJust, fromMaybe, catMaybes )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(mempty) )-#endif-import Control.Monad-         ( guard )-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Map as Map-import qualified Data.Graph as Graph-import qualified Data.Array as Array-import Control.Exception-         ( assert )---- --------------------------------------------------------------- * Search state types--- --------------------------------------------------------------type Constraints  = Constraints.Constraints-                      InstalledPackageEx UnconfiguredPackage ExclusionReason-type SelectedPackages = PackageIndex SelectedPackage---- --------------------------------------------------------------- * The search tree type--- --------------------------------------------------------------data SearchSpace inherited pkg-   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]-   | Failure Failure---- --------------------------------------------------------------- * Traverse a search tree--- --------------------------------------------------------------explore :: (PackageName -> PackagePreferences)-        -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)-                       SelectablePackage-        -> Progress Log Failure (SelectedPackages, Constraints)--explore _    (Failure failure)       = Fail failure-explore _    (ChoiceNode (s,c,_) []) = Done (s,c)-explore pref (ChoiceNode _ choices)  =-  case [ choice | [choice] <- choices ] of-    ((_, node'):_) -> Step (logInfo node') (explore pref node')-    []             -> Step (logInfo node') (explore pref node')-      where-        choice     = minimumBy (comparing topSortNumber) choices-        pkgname    = packageName . fst . head $ choice-        (_, node') = maximumBy (bestByPref pkgname) choice-  where-    topSortNumber choice = case fst (head choice) of-      InstalledOnly        (InstalledPackageEx  _ i _) -> i-      SourceOnly           (UnconfiguredPackage _ i _ _) -> i-      InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i--    bestByPref pkgname = case packageInstalledPreference of-        PreferLatest    ->-          comparing (\(p,_) -> (               isPreferred p, packageId p))-        PreferInstalled ->-          comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))-      where-        isInstalled (SourceOnly _) = False-        isInstalled _              = True-        isPreferred p = length . filter (packageVersion p `withinRange`) $-                        preferredVersions--        (PackagePreferences preferredVersions packageInstalledPreference _)-          = pref pkgname--    logInfo node = Select selected discarded-      where (selected, discarded) = case node of-              Failure    _               -> ([], [])-              ChoiceNode (_,_,changes) _ -> changes---- --------------------------------------------------------------- * Generate a search tree--- --------------------------------------------------------------type ConfigurePackage = PackageIndex SelectablePackage-                     -> SelectablePackage-                     -> Either [Dependency] SelectedPackage---- | (packages selected, packages discarded)-type SelectionChanges = ([SelectedPackage], [PackageId])--searchSpace :: ConfigurePackage-            -> Constraints-            -> SelectedPackages-            -> SelectionChanges-            -> Set PackageName-            -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)-                           SelectablePackage-searchSpace configure constraints selected changes next =-  assert (Set.null (selectedSet `Set.intersection` next)) $-  assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $-  assert (next `Set.isSubsetOf` Constraints.packages constraints) $--  ChoiceNode (selected, constraints, changes)-    [ [ (pkg, select name pkg)-      | pkg <- PackageIndex.lookupPackageName available name ]-    | name <- Set.elems next ]-  where-    available = Constraints.choices constraints--    selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))--    select name pkg = case configure available pkg of-      Left missing -> Failure $ ConfigureFailed pkg-                        [ (dep, Constraints.conflicting constraints dep)-                        | dep <- missing ]-      Right pkg' ->-        case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of-          Left failure       -> Failure failure-          Right (constraints', newDiscarded) ->-            searchSpace configure-              constraints' selected' (newSelected, newDiscarded) next'-        where-          selected' = foldl' (flip PackageIndex.insert) selected newSelected-          newSelected =-            case Constraints.isPaired constraints (packageId pkg) of-              Nothing     -> [pkg']-              Just pkgid' -> [pkg', pkg'']-                where-                  Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)-                    (PackageIndex.lookupPackageId available pkgid')--          newPkgs   = [ name'-                      | (Dependency name' _, _) <- newDeps-                      , null (PackageIndex.lookupPackageName selected' name') ]-          newDeps   = concatMap packageConstraints newSelected-          next'     = Set.delete name-                    $ foldl' (flip Set.insert) next newPkgs--packageConstraints :: SelectedPackage -> [(Dependency, Bool)]-packageConstraints = either installedConstraints availableConstraints-                   . preferSource-  where-    preferSource (InstalledOnly        pkg) = Left pkg-    preferSource (SourceOnly           pkg) = Right pkg-    preferSource (InstalledAndSource _ pkg) = Right pkg-    installedConstraints (InstalledPackageEx    _ _ deps) =-      [ (thisPackageVersion dep, True)-      | dep <- deps ]-    availableConstraints (SemiConfiguredPackage _ _ _ deps) =-      [ (dep, False) | dep <- deps ]--addDeps :: Constraints -> [PackageName] -> Constraints-addDeps =-  foldr $ \pkgname cs ->-            case Constraints.addTarget pkgname cs of-              Satisfiable cs' () -> cs'-              _                  -> impossible "addDeps unsatisfiable"--constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints-              -> [PackageId]-              -> Either Failure (Constraints, [PackageId])-constrainDeps pkg []         cs discard =-  case addPackageSelectConstraint (packageId pkg) cs of-    Satisfiable cs' discard' -> Right (cs', discard' ++ discard)-    _                        -> impossible "constrainDeps unsatisfiable(1)"-constrainDeps pkg ((dep, installedConstraint):deps) cs discard =-  case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of-    Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)-    Unsatisfiable            -> impossible "constrainDeps unsatisfiable(2)"-    ConflictsWith conflicts  ->-      Left (DependencyConflict pkg dep installedConstraint conflicts)---- --------------------------------------------------------------- * The main algorithm--- --------------------------------------------------------------search :: ConfigurePackage-       -> (PackageName -> PackagePreferences)-       -> Constraints-       -> Set PackageName-       -> Progress Log Failure (SelectedPackages, Constraints)-search configure pref constraints =-  explore pref . searchSpace configure constraints mempty ([], [])---- --------------------------------------------------------------- * The top level resolver--- ---------------------------------------------------------------- | The main exported resolver, with string logging and failure types to fit--- the standard 'DependencyResolver' interface.----topDownResolver :: DependencyResolver UnresolvedPkgLoc-topDownResolver platform cinfo installedPkgIndex sourcePkgIndex _pkgConfigDB-                preferences constraints targets =-    mapMessages $ topDownResolver'-                    platform cinfo-                    (convertInstalledPackageIndex installedPkgIndex)-                    sourcePkgIndex-                    preferences-                    (map unlabelPackageConstraint constraints)-                    targets-  where-    mapMessages :: Progress Log Failure a -> Progress String String a-    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done---- | The native resolver with detailed structured logging and failure types.----topDownResolver' :: Platform -> CompilerInfo-                 -> PackageIndex InstalledPackage-                 -> PackageIndex UnresolvedSourcePackage-                 -> (PackageName -> PackagePreferences)-                 -> [PackageConstraint]-                 -> [PackageName]-                 -> Progress Log Failure [ResolverPackage UnresolvedPkgLoc]-topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex-                 preferences constraints targets =-      fmap (uncurry finalise)-    . (\cs -> search configure preferences cs initialPkgNames)-  =<< pruneBottomUp platform cinfo-  =<< addTopLevelConstraints constraints-  =<< addTopLevelTargets targets emptyConstraintSet--  where-    configure   = configurePackage platform cinfo-    emptyConstraintSet :: Constraints-    emptyConstraintSet = Constraints.empty-      (annotateInstalledPackages          topSortNumber installedPkgIndex')-      (annotateSourcePackages constraints topSortNumber sourcePkgIndex')-    (installedPkgIndex', sourcePkgIndex') =-      selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames-    topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex'--    initialPkgNames = Set.fromList targets--    finalise selected' constraints' =-        map toResolverPackage-      . PackageIndex.allPackages-      . fst . improvePlan installedPkgIndex' constraints'-      . PackageIndex.fromList-      $ finaliseSelectedPackages preferences selected' constraints'--    toResolverPackage :: FinalSelectedPackage -> ResolverPackage UnresolvedPkgLoc-    toResolverPackage (SelectedInstalled (InstalledPackage pkg _))-                                              = PreExisting pkg-    toResolverPackage (SelectedSource    pkg) = Configured  pkg--addTopLevelTargets :: [PackageName]-                   -> Constraints-                   -> Progress a Failure Constraints-addTopLevelTargets []         cs = Done cs-addTopLevelTargets (pkg:pkgs) cs =-  case Constraints.addTarget pkg cs of-    Satisfiable cs' ()       -> addTopLevelTargets pkgs cs'-    Unsatisfiable            -> Fail (NoSuchPackage pkg)-    ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts"---addTopLevelConstraints :: [PackageConstraint] -> Constraints-                       -> Progress Log Failure Constraints-addTopLevelConstraints []                                      cs = Done cs-addTopLevelConstraints (PackageConstraintFlags   _   _  :deps) cs =-  addTopLevelConstraints deps cs--addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs =-  case addTopLevelVersionConstraint pkg ver cs of-    Satisfiable cs' pkgids  ->-      Step (AppliedVersionConstraint pkg ver pkgids)-           (addTopLevelConstraints deps cs')--    Unsatisfiable           ->-      Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)--    ConflictsWith conflicts ->-      Fail (TopLevelVersionConstraintConflict pkg ver conflicts)--addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs =-  case addTopLevelInstalledConstraint pkg cs of-    Satisfiable cs' pkgids  ->-      Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids)-           (addTopLevelConstraints deps cs')--    Unsatisfiable           ->-      Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint)--    ConflictsWith conflicts ->-      Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts)--addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =-  case addTopLevelSourceConstraint pkg cs of-    Satisfiable cs' pkgids  ->-      Step (AppliedInstalledConstraint pkg SourceConstraint pkgids)-            (addTopLevelConstraints deps cs')--    Unsatisfiable           ->-      Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint)--    ConflictsWith conflicts ->-      Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)--addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs =-    addTopLevelConstraints deps cs---- | Add exclusion on available packages that cannot be configured.----pruneBottomUp :: Platform -> CompilerInfo-              -> Constraints -> Progress Log Failure Constraints-pruneBottomUp platform comp constraints =-    foldr prune Done (initialPackages constraints) constraints--  where-    prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs-      where-        unconfigurable =-          [ (pkg, missing) -- if necessary we could look up missing reasons-          | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs-          , Left missing <- [configure cs pkg'] ]--    addExcludeConstraint (pkg, missing) rest cs =-      let reason = ExcludedByConfigureFail missing in-      case addPackageExcludeConstraint (packageId pkg) reason cs of-        Satisfiable cs' [pkgid]| packageId pkg == pkgid-                         -> Step (ExcludeUnconfigurable pkgid) (rest cs')-        Satisfiable _ _  -> impossible "pruneBottomUp satisfiable"-        _                -> Fail $ ConfigureFailed pkg-                              [ (dep, Constraints.conflicting cs dep)-                              | dep <- missing ]--    configure cs (UnconfiguredPackage (SourcePackage _ pkg _ _) _ flags stanzas) =-      finalizePackageDescription flags (dependencySatisfiable cs)-                                 platform comp [] (enableStanzas stanzas pkg)-    dependencySatisfiable cs =-      not . null . PackageIndex.lookupDependency (Constraints.choices cs)--    -- collect each group of packages (by name) in reverse topsort order-    initialPackages =-        reverse-      . sortBy (comparing (topSortNumber . head))-      . PackageIndex.allPackagesByName-      . Constraints.choices--    topSortNumber (InstalledOnly        (InstalledPackageEx  _ i _)) = i-    topSortNumber (SourceOnly           (UnconfiguredPackage _ i _ _)) = i-    topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i--    getSourcePkg (InstalledOnly      _     ) = Nothing-    getSourcePkg (SourceOnly           spkg) = Just spkg-    getSourcePkg (InstalledAndSource _ spkg) = Just spkg---configurePackage :: Platform -> CompilerInfo -> ConfigurePackage-configurePackage platform cinfo available spkg = case spkg of-  InstalledOnly      ipkg      -> Right (InstalledOnly ipkg)-  SourceOnly              apkg -> fmap SourceOnly (configure apkg)-  InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)-                                       (configure apkg)-  where-  configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) =-    case finalizePackageDescription flags dependencySatisfiable-                                    platform cinfo []-                                    (enableStanzas stanzas p) of-      Left missing        -> Left missing-      Right (pkg, flags') -> Right $-        SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg)--  dependencySatisfiable = not . null . PackageIndex.lookupDependency available---- | Annotate each installed packages with its set of transitive dependencies--- and its topological sort number.----annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)-                          -> PackageIndex InstalledPackage-                          -> PackageIndex InstalledPackageEx-annotateInstalledPackages dfsNumber installed = PackageIndex.fromList-  [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)-  | pkg <- PackageIndex.allPackages installed ]-  where-    transitiveDepends :: InstalledPackage -> [PackageId]-    transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph-                      . fromJust . toVertex . packageId-    (graph, toPkg, toVertex) = dependencyGraph installed----- | Annotate each available packages with its topological sort number and any--- user-supplied partial flag assignment.----annotateSourcePackages :: [PackageConstraint]-                       -> (PackageName -> TopologicalSortNumber)-                       -> PackageIndex UnresolvedSourcePackage-                       -> PackageIndex UnconfiguredPackage-annotateSourcePackages constraints dfsNumber sourcePkgIndex =-    PackageIndex.fromList-      [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name)-      | pkg <- PackageIndex.allPackages sourcePkgIndex-      , let name = packageName pkg ]-  where-    flagsFor = fromMaybe [] . flip Map.lookup flagsMap-    flagsMap = Map.fromList-      [ (name, flags)-      | PackageConstraintFlags name flags <- constraints ]-    stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap-    stanzasMap = Map.fromListWith (++)-        [ (name, stanzas)-        | PackageConstraintStanzas name stanzas <- constraints ]---- | One of the heuristics we use when guessing which path to take in the--- search space is an ordering on the choices we make. It's generally better--- to make decisions about packages higer in the dep graph first since they--- place constraints on packages lower in the dep graph.------ To pick them in that order we annotate each package with its topological--- sort number. So if package A depends on package B then package A will have--- a lower topological sort number than B and we'll make a choice about which--- version of A to pick before we make a choice about B (unless there is only--- one possible choice for B in which case we pick that immediately).------ To construct these topological sort numbers we combine and flatten the--- installed and source package sets. We consider only dependencies between--- named packages, not including versions and for not-yet-configured packages--- we look at all the possible dependencies, not just those under any single--- flag assignment. This means we can actually get impossible combinations of--- edges and even cycles, but that doesn't really matter here, it's only a--- heuristic.----topologicalSortNumbering :: PackageIndex InstalledPackage-                         -> PackageIndex UnresolvedSourcePackage-                         -> (PackageName -> TopologicalSortNumber)-topologicalSortNumbering installedPkgIndex sourcePkgIndex =-    \pkgname -> let Just vertex = toVertex pkgname-                 in topologicalSortNumbers Array.! vertex-  where-    topologicalSortNumbers = Array.array (Array.bounds graph)-                                         (zip (Graph.topSort graph) [0..])-    (graph, _, toVertex)   = Graph.graphFromEdges $-         [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex-         , let deps = [ packageName dep-                      | pkg' <- pkgs-                      , dep  <- sourceDeps pkg' ] ]-      ++ [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex-         , let deps = [ depName-                      | SourcePackage _ pkg' _ _ <- pkgs-                      , Dependency depName _ <--                          buildDepends (flattenPackageDescription pkg') ] ]---- | We don't need the entire index (which is rather large and costly if we--- force it by examining the whole thing). So trace out the maximul subset of--- each index that we could possibly ever need. Do this by flattening packages--- and looking at the names of all possible dependencies.----selectNeededSubset :: PackageIndex InstalledPackage-                   -> PackageIndex UnresolvedSourcePackage-                   -> Set PackageName-                   -> (PackageIndex InstalledPackage-                      ,PackageIndex UnresolvedSourcePackage)-selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty-  where-    select :: PackageIndex InstalledPackage-           -> PackageIndex UnresolvedSourcePackage-           -> Set PackageName-           -> (PackageIndex InstalledPackage-              ,PackageIndex UnresolvedSourcePackage)-    select installedPkgIndex' sourcePkgIndex' remaining-      | Set.null remaining = (installedPkgIndex', sourcePkgIndex')-      | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining''-      where-        (next, remaining') = Set.deleteFindMin remaining-        moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next-        moreSource    = PackageIndex.lookupPackageName sourcePkgIndex next-        moreRemaining = -- we filter out packages already included in the indexes-                        -- this avoids an infinite loop if a package depends on itself-                        -- like base-3.0.3.0 with base-4.0.0.0-                        filter notAlreadyIncluded-                      $ [ packageName dep-                        | pkg <- moreInstalled-                        , dep <- sourceDeps pkg ]-                     ++ [ name-                        | SourcePackage _ pkg _ _ <- moreSource-                        , Dependency name _ <--                            buildDepends (flattenPackageDescription pkg) ]-        installedPkgIndex'' = foldl' (flip PackageIndex.insert)-                                     installedPkgIndex' moreInstalled-        sourcePkgIndex''    = foldl' (flip PackageIndex.insert)-                                     sourcePkgIndex' moreSource-        remaining''         = foldl' (flip          Set.insert)-                                     remaining' moreRemaining-        notAlreadyIncluded name =-            null (PackageIndex.lookupPackageName installedPkgIndex' name)-         && null (PackageIndex.lookupPackageName sourcePkgIndex' name)----- | The old top down solver assumes that installed packages are indexed by--- their source package id. But these days they're actually indexed by an--- installed package id and there can be many installed packages with the same--- source package id. This function tries to do a convertion, but it can only--- be partial.----convertInstalledPackageIndex :: InstalledPackageIndex-                             -> PackageIndex InstalledPackage-convertInstalledPackageIndex index' = PackageIndex.fromList-    -- There can be multiple installed instances of each package version,-    -- like when the same package is installed in the global & user DBs.-    -- InstalledPackageIndex.allPackagesBySourcePackageId gives us the-    -- installed packages with the most preferred instances first, so by-    -- picking the first we should get the user one. This is almost but not-    -- quite the same as what ghc does.-    [ InstalledPackage ipkg (sourceDepsOf index' ipkg)-    | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ]-  where-    -- The InstalledPackageInfo only lists dependencies by the-    -- UnitId, which means we do not directly know the corresponding-    -- source dependency. The only way to find out is to lookup the-    -- UnitId to get the InstalledPackageInfo and look at its-    -- source PackageId. But if the package is broken because it depends on-    -- other packages that do not exist then we have a problem we cannot find-    -- the original source package id. Instead we make up a bogus package id.-    -- This should have the same effect since it should be a dependency on a-    -- nonexistent package.-    sourceDepsOf index ipkg =-      [ maybe (brokenPackageId depid) packageId mdep-      | let depids = InstalledPackageInfo.depends ipkg-            getpkg = InstalledPackageIndex.lookupUnitId index-      , (depid, mdep) <- zip depids (map getpkg depids) ]--    brokenPackageId (SimpleUnitId (ComponentId str)) =-      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])---- --------------------------------------------------------------- * Post processing the solution--- --------------------------------------------------------------finaliseSelectedPackages :: (PackageName -> PackagePreferences)-                         -> SelectedPackages-                         -> Constraints-                         -> [FinalSelectedPackage]-finaliseSelectedPackages pref selected constraints =-  map finaliseSelected (PackageIndex.allPackages selected)-  where-    remainingChoices = Constraints.choices constraints-    finaliseSelected (InstalledOnly      ipkg     ) = finaliseInstalled ipkg-    finaliseSelected (SourceOnly              apkg) = finaliseSource Nothing apkg-    finaliseSelected (InstalledAndSource ipkg apkg) =-      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of-                                        --picked package not in constraints-        Nothing                       -> impossible "finaliseSelected no pkg"-                                        -- to constrain to avail only:-        Just (SourceOnly _)           -> impossible "finaliseSelected src only"-        Just (InstalledOnly _)        -> finaliseInstalled ipkg-        Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg--    finaliseInstalled (InstalledPackageEx pkg _ _) = SelectedInstalled pkg-    finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =-        SelectedSource (ConfiguredPackage pkg flags stanzas deps')-      where-        -- We cheat in the cabal solver, and classify all dependencies as-        -- library dependencies.-        deps' :: ComponentDeps [ConfiguredId]-        deps' = CD.fromLibraryDeps (unPackageName (packageName pkg))-                                   (map (confId . pickRemaining mipkg) deps)--    -- InstalledOrSource indicates that we either have a source package-    -- available, or an installed one, or both. In the case that we have both-    -- available, we don't yet know if we can pick the installed one (the-    -- dependencies may not match up, for instance); this is verified in-    -- `improvePlan`.-    ---    -- This means that at this point we cannot construct a valid installed-    -- package ID yet for the dependencies. We therefore have two options:-    ---    -- * We could leave the installed package ID undefined here, and have a-    --   separate pass over the output of the top-down solver, fixing all-    --   dependencies so that if we depend on an already installed package we-    --   use the proper installed package ID.-    ---    -- * We can _always_ use fake installed IDs, irrespective of whether we the-    --   dependency is on an already installed package or not. This is okay-    --   because (i) the top-down solver does not (and never will) support-    --   multiple package instances, and (ii) we initialize the FakeMap with-    --   fake IDs for already installed packages.-    ---    -- For now we use the second option; if however we change the implementation-    -- of these fake IDs so that we do away with the FakeMap and update a-    -- package reverse dependencies as we execute the install plan and discover-    -- real package IDs, then this is no longer possible and we have to-    -- implement the first option (see also Note [FakeMap] in Cabal).-    confId :: InstalledOrSource InstalledPackageEx UnconfiguredPackage -> ConfiguredId-    confId pkg = ConfiguredId {-        confSrcId  = packageId pkg-      , confInstId = fakeUnitId (packageId pkg)-      }--    pickRemaining mipkg dep@(Dependency _name versionRange) =-          case PackageIndex.lookupDependency remainingChoices dep of-            []        -> impossible "pickRemaining no pkg"-            [pkg']    -> pkg'-            remaining -> assert (checkIsPaired remaining)-                       $ maximumBy bestByPref remaining-      where-        -- We order candidate packages to pick for a dependency by these-        -- three factors. The last factor is just highest version wins.-        bestByPref =-          comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))-        -- Is the package already used by the installed version of this-        -- package? If so we should pick that first. This stops us from doing-        -- silly things like deciding to rebuild haskell98 against base 3.-        isCurrent = case mipkg :: Maybe InstalledPackageEx of-          Nothing   -> \_ -> False-          Just ipkg -> \p -> packageId p `elem` sourceDeps ipkg-        -- If there is no upper bound on the version range then we apply a-        -- preferred version according to the hackage or user's suggested-        -- version constraints. TODO: distinguish hacks from prefs-        bounded = boundedAbove versionRange-        isPreferred p-          | bounded   = boundedRank -- this is a dummy constant-          | otherwise = length . filter (packageVersion p `withinRange`) $-                        preferredVersions-          where (PackagePreferences preferredVersions _ _) = pref (packageName p)-        boundedRank = 0 -- any value will do--        boundedAbove :: VersionRange -> Bool-        boundedAbove vr = case asVersionIntervals vr of-          []        -> True -- this is the inconsistent version range.-          intervals -> case last intervals of-            (_,   UpperBound _ _) -> True-            (_, NoUpperBound    ) -> False--        -- We really only expect to find more than one choice remaining when-        -- we're finalising a dependency on a paired package.-        checkIsPaired [p1, p2] =-          case Constraints.isPaired constraints (packageId p1) of-            Just p2'   -> packageId p2' == packageId p2-            Nothing    -> False-        checkIsPaired _ = False---- | Improve an existing installation plan by, where possible, swapping--- packages we plan to install with ones that are already installed.--- This may add additional constraints due to the dependencies of installed--- packages on other installed packages.----improvePlan :: PackageIndex InstalledPackage-            -> Constraints-            -> PackageIndex FinalSelectedPackage-            -> (PackageIndex FinalSelectedPackage, Constraints)-improvePlan installed constraints0 selected0 =-  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)-  where-    improve (selected, constraints) = fromMaybe (selected, constraints)-                                    . improvePkg selected constraints--    -- The idea is to improve the plan by swapping a configured package for-    -- an equivalent installed one. For a particular package the condition is-    -- that the package be in a configured state, that a the same version be-    -- already installed with the exact same dependencies and all the packages-    -- in the plan that it depends on are in the installed state-    improvePkg selected constraints pkgid = do-      SelectedSource pkg  <- PackageIndex.lookupPackageId selected  pkgid-      ipkg                <- PackageIndex.lookupPackageId installed pkgid-      guard $ all (isInstalled selected) (sourceDeps pkg)-      tryInstalled selected constraints [ipkg]--    isInstalled selected pkgid =-      case PackageIndex.lookupPackageId selected pkgid of-        Just (SelectedInstalled _) -> True-        _                          -> False--    tryInstalled :: PackageIndex FinalSelectedPackage -> Constraints-                 -> [InstalledPackage]-                 -> Maybe (PackageIndex FinalSelectedPackage, Constraints)-    tryInstalled selected constraints [] = Just (selected, constraints)-    tryInstalled selected constraints (pkg:pkgs) =-      case constraintsOk (packageId pkg) (sourceDeps pkg) constraints of-        Nothing           -> Nothing-        Just constraints' -> tryInstalled selected' constraints' pkgs'-          where-            selected' = PackageIndex.insert (SelectedInstalled pkg) selected-            pkgs'      = catMaybes (map notSelected (sourceDeps pkg)) ++ pkgs-            notSelected pkgid =-              case (PackageIndex.lookupPackageId installed pkgid-                   ,PackageIndex.lookupPackageId selected  pkgid) of-                (Just pkg', Nothing) -> Just pkg'-                _                    -> Nothing--    constraintsOk _     []              constraints = Just constraints-    constraintsOk pkgid (pkgid':pkgids) constraints =-      case addPackageDependencyConstraint pkgid dep True constraints of-        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'-        _                          -> Nothing-      where-        dep = thisPackageVersion pkgid'--    reverseTopologicalOrder :: PackageIndex FinalSelectedPackage -> [PackageId]-    reverseTopologicalOrder index = map (packageId . toPkg)-                                  . Graph.topSort-                                  . Graph.transposeG-                                  $ graph-      where (graph, toPkg, _) = dependencyGraph index---- --------------------------------------------------------------- * Adding and recording constraints--- --------------------------------------------------------------addPackageSelectConstraint :: PackageId -> Constraints-                           -> Satisfiable Constraints-                                [PackageId] ExclusionReason-addPackageSelectConstraint pkgid =-    Constraints.constrain pkgname constraint reason-  where-    pkgname          = packageName pkgid-    constraint ver _ = ver == packageVersion pkgid-    reason           = SelectedOther pkgid--addPackageExcludeConstraint :: PackageId -> ExclusionReason-                            -> Constraints-                            -> Satisfiable Constraints-                                           [PackageId] ExclusionReason-addPackageExcludeConstraint pkgid reason =-    Constraints.constrain pkgname constraint reason-  where-    pkgname = packageName pkgid-    constraint ver installed-      | ver == packageVersion pkgid = installed-      | otherwise                   = True--addPackageDependencyConstraint :: PackageId -> Dependency -> Bool-                               -> Constraints-                               -> Satisfiable Constraints-                                    [PackageId] ExclusionReason-addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange)-                                     installedConstraint =-    Constraints.constrain pkgname constraint reason-  where-    constraint ver installed = ver `withinRange` verrange-                            && if installedConstraint then installed else True-    reason = ExcludedByPackageDependency pkgid dep installedConstraint--addTopLevelVersionConstraint :: PackageName -> VersionRange-                             -> Constraints-                             -> Satisfiable Constraints-                                  [PackageId] ExclusionReason-addTopLevelVersionConstraint pkgname verrange =-    Constraints.constrain pkgname constraint reason-  where-    constraint ver _installed = ver `withinRange` verrange-    reason = ExcludedByTopLevelConstraintVersion pkgname verrange--addTopLevelInstalledConstraint,-  addTopLevelSourceConstraint :: PackageName-                              -> Constraints-                              -> Satisfiable Constraints-                                   [PackageId] ExclusionReason-addTopLevelInstalledConstraint pkgname =-    Constraints.constrain pkgname constraint reason-  where-    constraint _ver installed = installed-    reason = ExcludedByTopLevelConstraintInstalled pkgname--addTopLevelSourceConstraint pkgname =-    Constraints.constrain pkgname constraint reason-  where-    constraint _ver installed = not installed-    reason = ExcludedByTopLevelConstraintSource pkgname----- --------------------------------------------------------------- * Reasons for constraints--- ---------------------------------------------------------------- | For every constraint we record we also record the reason that constraint--- is needed. So if we end up failing due to conflicting constraints then we--- can give an explnanation as to what was conflicting and why.----data ExclusionReason =--     -- | We selected this other version of the package. That means we exclude-     -- all the other versions.-     SelectedOther PackageId--     -- | We excluded this version of the package because it failed to-     -- configure probably because of unsatisfiable deps.-   | ExcludedByConfigureFail [Dependency]--     -- | We excluded this version of the package because another package that-     -- we selected imposed a dependency which this package did not satisfy.-   | ExcludedByPackageDependency PackageId Dependency Bool--     -- | We excluded this version of the package because it did not satisfy-     -- a dependency given as an original top level input.-     ---   | ExcludedByTopLevelConstraintVersion   PackageName VersionRange-   | ExcludedByTopLevelConstraintInstalled PackageName-   | ExcludedByTopLevelConstraintSource    PackageName--  deriving Eq---- | Given an excluded package and the reason it was excluded, produce a human--- readable explanation.----showExclusionReason :: PackageId -> ExclusionReason -> String-showExclusionReason pkgid (SelectedOther pkgid') =-  display pkgid ++ " was excluded because " ++-  display pkgid' ++ " was selected instead"-showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) =-  display pkgid ++ " was excluded because it could not be configured. "-  ++ "It requires " ++ listOf displayDep missingDeps-showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint)-  = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires "- ++ (if installedConstraint then "an installed instance of " else "")- ++ displayDep dep-showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) =-  display pkgid ++ " was excluded because of the top level constraint " ++-  displayDep (Dependency pkgname verRange)-showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname)-  = display pkgid ++ " was excluded because of the top level constraint '"- ++ display pkgname ++ " installed' which means that only installed instances "- ++ "of the package may be selected."-showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname)-  = display pkgid ++ " was excluded because of the top level constraint '"- ++ display pkgname ++ " source' which means that only source versions "- ++ "of the package may be selected."----- --------------------------------------------------------------- * Logging progress and failures--- --------------------------------------------------------------data Log = Select [SelectedPackage] [PackageId]-         | AppliedVersionConstraint   PackageName VersionRange [PackageId]-         | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId]-         | ExcludeUnconfigurable PackageId--data Failure-   = NoSuchPackage-       PackageName-   | ConfigureFailed-       SelectablePackage-       [(Dependency, [(PackageId, [ExclusionReason])])]-   | DependencyConflict-       SelectedPackage Dependency Bool-       [(PackageId, [ExclusionReason])]-   | TopLevelVersionConstraintConflict-       PackageName VersionRange-       [(PackageId, [ExclusionReason])]-   | TopLevelVersionConstraintUnsatisfiable-       PackageName VersionRange-   | TopLevelInstallConstraintConflict-       PackageName InstalledConstraint-       [(PackageId, [ExclusionReason])]-   | TopLevelInstallConstraintUnsatisfiable-       PackageName InstalledConstraint--showLog :: Log -> String-showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of-  ("", y) -> y-  (x, "") -> x-  (x,  y) -> x ++ " and " ++ y--  where-    selectedMsg  = "selecting " ++ case selected of-      []     -> ""-      [s]    -> display (packageId s) ++ " " ++ kind s-      (s:ss) -> listOf id-              $ (display (packageId s) ++ " " ++ kind s)-              : [ display (packageVersion s') ++ " " ++ kind s'-                | s' <- ss ]--    kind (InstalledOnly _)        = "(installed)"-    kind (SourceOnly _)           = "(source)"-    kind (InstalledAndSource _ _) = "(installed or source)"--    discardedMsg = case discarded of-      []  -> ""-      _   -> "discarding " ++ listOf id-        [ element-        | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)-        , element <- display pkgid : map (display . packageVersion) pkgids ]-showLog (AppliedVersionConstraint pkgname ver pkgids) =-     "applying constraint " ++ display (Dependency pkgname ver)-  ++ if null pkgids-       then ""-       else " which excludes " ++ listOf display pkgids-showLog (AppliedInstalledConstraint pkgname inst pkgids) =-     "applying constraint " ++ display pkgname ++ " '"-  ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "-  ++ if null pkgids-       then ""-       else "which excludes " ++ listOf display pkgids-showLog (ExcludeUnconfigurable pkgid) =-     "excluding " ++ display pkgid ++ " (it cannot be configured)"--showFailure :: Failure -> String-showFailure (NoSuchPackage pkgname) =-     "The package " ++ display pkgname ++ " is unknown."-showFailure (ConfigureFailed pkg missingDeps) =-     "cannot configure " ++ displayPkg pkg ++ ". It requires "-  ++ listOf (displayDep . fst) missingDeps-  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)--  where-    whyNot (Dependency name ver) [] =-         "There is no available version of " ++ display name-      ++ " that satisfies " ++ displayVer ver--    whyNot dep conflicts =-         "For the dependency on " ++ displayDep dep-      ++ " there are these packages: " ++ listOf display pkgs-      ++ ". However none of them are available.\n"-      ++ unlines [ showExclusionReason (packageId pkg') reason-                 | (pkg', reasons) <- conflicts, reason <- reasons ]--      where pkgs = map fst conflicts--showFailure (DependencyConflict pkg dep installedConstraint conflicts) =-     "dependencies conflict: "-  ++ displayPkg pkg ++ " requires "-  ++ (if installedConstraint then "an installed instance of " else "")-  ++ displayDep dep ++ " however:\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelVersionConstraintConflict name ver conflicts) =-     "constraints conflict: we have the top level constraint "-  ++ displayDep (Dependency name ver) ++ ", but\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =-     "There is no available version of " ++ display name-      ++ " that satisfies " ++ displayVer ver--showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) =-     "constraints conflict: "-  ++ "top level constraint '" ++ display name ++ " installed' however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) =-     "There is no installed version of " ++ display name--showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) =-     "constraints conflict: "-  ++ "top level constraint '" ++ display name ++ " source' however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) =-     "There is no available source version of " ++ display name--displayVer :: VersionRange -> String-displayVer = display . simplifyVersionRange--displayDep :: Dependency -> String-displayDep = display . simplifyDependency----- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------impossible :: String -> a-impossible msg = internalError $ "assertion failure: " ++ msg--internalError :: String -> a-internalError msg = error $ "internal error: " ++ msg--displayPkg :: Package pkg => pkg -> String-displayPkg = display . packageId--listOf :: (a -> String) -> [a] -> String-listOf _    []   = []-listOf disp [x0] = disp x0-listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs-  where go x []       = " and " ++ disp x-        go x (x':xs') = ", " ++ disp x ++ go x' xs'---- --------------------------------------------------------------- * Construct a dependency graph--- ---------------------------------------------------------------- | Builds a graph of the package dependencies.------ Dependencies on other packages that are not in the index are discarded.--- You can check if there are any such dependencies with 'brokenPackages'.------ The top-down solver gets its own implementation, because both--- `dependencyGraph` in `Distribution.Client.PlanIndex` (in cabal-install) and--- `dependencyGraph` in `Distribution.Simple.PackageIndex` (in Cabal) both work--- with `PackageIndex` from `Cabal` (that is, a package index indexed by--- installed package IDs rather than package names).------ Ideally we would switch the top-down solver over to use that too, so that--- this duplication could be avoided, but that's a bit of work and the top-down--- solver is legacy code anyway.------ (NOTE: This is called at two types: InstalledPackage and FinalSelectedPackage.)-dependencyGraph :: PackageSourceDeps pkg-                => PackageIndex pkg-                -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    PackageId -> Maybe Graph.Vertex)-dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)-  where-    graph = Array.listArray bounds $-            map (catMaybes . map pkgIdToVertex . sourceDeps) pkgs-    vertexToPkg vertex = pkgTable Array.! vertex-    pkgIdToVertex = binarySearch 0 topBound--    pkgTable   = Array.listArray bounds pkgs-    pkgIdTable = Array.listArray bounds (map packageId pkgs)-    pkgs = sortBy (comparing packageId) (PackageIndex.allPackages index)-    topBound = length pkgs - 1-    bounds = (0, topBound)--    binarySearch a b key-      | a > b     = Nothing-      | otherwise = case compare key (pkgIdTable Array.! mid) of-          LT -> binarySearch a (mid-1) key-          EQ -> Just mid-          GT -> binarySearch (mid+1) b key-      where mid = (a + b) `div` 2
− cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs 
@@ -1,599 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.TopDown.Constraints--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org--- Stability   :  provisional--- Portability :  portable------ A set of satisfiable constraints on a set of packages.-------------------------------------------------------------------------------module Distribution.Client.Dependency.TopDown.Constraints (-  Constraints,-  empty,-  packages,-  choices,-  isPaired,--  addTarget,-  constrain,-  Satisfiable(..),-  conflicting,-  ) where--import Distribution.Client.Dependency.TopDown.Types-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex-        ( PackageIndex )-import Distribution.Package-         ( PackageName, PackageId, PackageIdentifier(..)-         , Package(packageId), packageName, packageVersion-         , Dependency )-import Distribution.Version-         ( Version )-import Distribution.Client.Utils-         ( mergeBy, MergeResult(..) )--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(mempty) )-#endif-import Data.Either-         ( partitionEithers )-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import Data.Set (Set)-import Control.Exception-         ( assert )----- | A set of satisfiable constraints on a set of packages.------ The 'Constraints' type keeps track of a set of targets (identified by--- package name) that we know that we need. It also keeps track of a set of--- constraints over all packages in the environment.------ It maintains the guarantee that, for the target set, the constraints are--- satisfiable, meaning that there is at least one instance available for each--- package name that satisfies the constraints on that package name.------ Note that it is possible to over-constrain a package in the environment that--- is not in the target set -- the satisfiability guarantee is only maintained--- for the target set. This is useful because it allows us to exclude packages--- without needing to know if it would ever be needed or not (e.g. allows--- excluding broken installed packages).------ Adding a constraint for a target package can fail if it would mean that--- there are no remaining choices.------ Adding a constraint for package that is not a target never fails.------ Adding a new target package can fail if that package already has conflicting--- constraints.----data Constraints installed source reason-   = Constraints--       -- | Targets that we know we need. This is the set for which we-       -- guarantee the constraints are satisfiable.-       !(Set PackageName)--       -- | The available/remaining set. These are packages that have available-       -- choices remaining. This is guaranteed to cover the target packages,-       -- but can also cover other packages in the environment. New targets can-       -- only be added if there are available choices remaining for them.-       !(PackageIndex (InstalledOrSource installed source))--       -- | The excluded set. Choices that we have excluded by applying-       -- constraints. Excluded choices are tagged with the reason.-       !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason))--       -- | Paired choices, this is an ugly hack.-       !(Map PackageName (Version, Version))--       -- | Purely for the invariant, we keep a copy of the original index-       !(PackageIndex (InstalledOrSource installed source))----- | Reasons for excluding all, or some choices for a package version.------ Each package version can have a source instance, an installed instance or--- both. We distinguish reasons for constraints that excluded both instances,--- from reasons for constraints that excluded just one instance.----data ExcludedPkg pkg reason-   = ExcludedPkg pkg-       [reason] -- ^ reasons for excluding both source and installed instances-       [reason] -- ^ reasons for excluding the installed instance-       [reason] -- ^ reasons for excluding the source instance--instance Package pkg => Package (ExcludedPkg pkg reason) where-  packageId (ExcludedPkg p _ _ _) = packageId p----- | There is a conservation of packages property. Packages are never gained or--- lost, they just transfer from the remaining set to the excluded set.----invariant :: (Package installed, Package source)-          => Constraints installed source a -> Bool-invariant (Constraints targets available excluded _ original) =--    -- Relationship between available, excluded and original-    all check merged--    -- targets is a subset of available- && all (PackageIndex.elemByPackageName available) (Set.elems targets)--  where-    merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)-                     (PackageIndex.allPackages original)-                     (mergeBy (\a b -> packageId a `compare` packageId b)-                              (PackageIndex.allPackages available)-                              (PackageIndex.allPackages excluded))-      where-        mergedPackageId (OnlyInLeft  p  ) = packageId p-        mergedPackageId (OnlyInRight   p) = packageId p-        mergedPackageId (InBoth      p _) = packageId p--    -- If the package was originally installed only, then-    check (InBoth (InstalledOnly _) cur) = case cur of-      -- now it's either still remaining as installed only-      OnlyInLeft               (InstalledOnly _)              -> True-      -- or it has been excluded-      OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True-      _                                                       -> False--    -- If the package was originally available only, then-    check (InBoth (SourceOnly _) cur) = case cur of-      -- now it's either still remaining as source only-      OnlyInLeft               (SourceOnly _)              -> True-      -- or it has been excluded-      OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True-      _                                                    -> False--    -- If the package was originally installed and source, then-    check (InBoth (InstalledAndSource _ _) cur) = case cur of-      -- We can have both remaining:-      OnlyInLeft               (InstalledAndSource _ _)        -> True--      -- both excluded, in particular it can have had the just source or-      -- installed excluded and later had both excluded so we do not mind if-      -- the source or installed excluded is empty or non-empty.-      OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True--      -- the installed remaining and the source excluded:-      InBoth                   (InstalledOnly _)-                  (ExcludedPkg (SourceOnly _) [] [] (_:_))     -> True--      -- the source remaining and the installed excluded:-      InBoth                   (SourceOnly _)-                  (ExcludedPkg (InstalledOnly _) [] (_:_) [])  -> True-      _                                                        -> False--    check _ = False----- | An update to the constraints can move packages between the two piles--- but not gain or loose packages.-transitionsTo :: (Package installed, Package source)-              => Constraints installed source a-              -> Constraints installed source a -> Bool-transitionsTo constraints @(Constraints _ available  excluded  _ _)-              constraints'@(Constraints _ available' excluded' _ _) =--     invariant constraints && invariant constraints'-  && null availableGained  && null excludedLost-  &&    map (mapInstalledOrSource packageId packageId) availableLost-     == map (mapInstalledOrSource packageId packageId) excludedGained--  where-    (availableLost, availableGained)-      = partitionEithers (foldr lostAndGained [] availableChange)--    (excludedLost, excludedGained)-      = partitionEithers (foldr lostAndGained [] excludedChange)--    availableChange =-      mergeBy (\a b -> packageId a `compare` packageId b)-        (PackageIndex.allPackages available)-        (PackageIndex.allPackages available')--    excludedChange =-      mergeBy (\a b -> packageId a `compare` packageId b)-        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded  ]-        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ]--    lostAndGained mr rest = case mr of-      OnlyInLeft pkg                    -> Left pkg : rest-      InBoth (InstalledAndSource pkg _)-             (SourceOnly _)             -> Left (InstalledOnly pkg) : rest-      InBoth (InstalledAndSource _ pkg)-             (InstalledOnly _)          -> Left (SourceOnly pkg) : rest-      InBoth (SourceOnly _)-             (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest-      InBoth (InstalledOnly _)-             (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest-      OnlyInRight pkg                   -> Right pkg : rest-      _                                 -> rest--    mapInstalledOrSource f g pkg = case pkg of-      InstalledOnly      a   -> InstalledOnly (f a)-      SourceOnly           b -> SourceOnly    (g b)-      InstalledAndSource a b -> InstalledAndSource (f a) (g b)---- | We construct 'Constraints' with an initial 'PackageIndex' of all the--- packages available.----empty :: PackageIndex InstalledPackageEx-      -> PackageIndex UnconfiguredPackage-      -> Constraints InstalledPackageEx UnconfiguredPackage reason-empty installed source =-    Constraints targets pkgs excluded pairs pkgs-  where-    targets  = mempty-    excluded = mempty-    pkgs = PackageIndex.fromList-         . map toInstalledOrSource-         $ mergeBy (\a b -> packageId a `compare` packageId b)-                   (PackageIndex.allPackages installed)-                   (PackageIndex.allPackages source)-    toInstalledOrSource (OnlyInLeft  i  ) = InstalledOnly      i-    toInstalledOrSource (OnlyInRight   a) = SourceOnly           a-    toInstalledOrSource (InBoth      i a) = InstalledAndSource i a--    -- pick up cases like base-3 and 4 where one version depends on the other:-    pairs = Map.fromList-      [ (name, (packageVersion pkgid1, packageVersion pkgid2))-      | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed-      , let name   = packageName pkg1-            pkgid1 = packageId pkg1-            pkgid2 = packageId pkg2-      ,    any ((pkgid1==) . packageId) (sourceDeps pkg2)-        || any ((pkgid2==) . packageId) (sourceDeps pkg1) ]----- | The package targets.----packages :: Constraints installed source reason-         -> Set PackageName-packages (Constraints ts _ _ _ _) = ts----- | The package choices that are still available.----choices :: Constraints installed source reason-        -> PackageIndex (InstalledOrSource installed source)-choices (Constraints _ available _ _ _) = available--isPaired :: Constraints installed source reason-         -> PackageId -> Maybe PackageId-isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) =-  case Map.lookup name pairs of-    Just (v1, v2)-      | version == v1 -> Just (PackageIdentifier name v2)-      | version == v2 -> Just (PackageIdentifier name v1)-    _                 -> Nothing---data Satisfiable constraints discarded reason-       = Satisfiable constraints discarded-       | Unsatisfiable-       | ConflictsWith [(PackageId, [reason])]---addTarget :: (Package installed, Package source)-          => PackageName-          -> Constraints installed source reason-          -> Satisfiable (Constraints installed source reason)-                         () reason-addTarget pkgname-          constraints@(Constraints targets available excluded paired original)--    -- If it's already a target then there's no change-  | pkgname `Set.member` targets-  = Satisfiable constraints ()--    -- If there is some possible choice available for this target then we're ok-  | PackageIndex.elemByPackageName available pkgname-  = let targets'     = Set.insert pkgname targets-        constraints' = Constraints targets' available excluded paired original-     in assert (constraints `transitionsTo` constraints') $-        Satisfiable constraints' ()--    -- If it's not available and it is excluded then we return the conflicts-  | PackageIndex.elemByPackageName excluded pkgname-  = ConflictsWith conflicts--    -- Otherwise, it's not available and it has not been excluded so the-    -- package is simply completely unknown.-  | otherwise-  = Unsatisfiable--  where-    conflicts =-      [ (packageId pkg, reasons)-      | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname-      , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices-      , let reasons = isReasons ++ iReasons ++ sReasons ]---constrain :: (Package installed, Package source)-          => PackageName                -- ^ which package to constrain-          -> (Version -> Bool -> Bool)  -- ^ the constraint test-          -> reason                     -- ^ the reason for the constraint-          -> Constraints installed source reason-          -> Satisfiable (Constraints installed source reason)-                         [PackageId] reason-constrain pkgname constraint reason-          constraints@(Constraints targets available excluded paired original)--  | pkgname `Set.member` targets  &&  not anyRemaining-  = if null conflicts then Unsatisfiable-                      else ConflictsWith conflicts--  | otherwise-  = let constraints' = Constraints targets available' excluded' paired original-     in assert (constraints `transitionsTo` constraints') $-        Satisfiable constraints' (map packageId newExcluded)--  where-    -- This tells us if any packages would remain at all for this package name if-    -- we applied this constraint. This amounts to checking if any package-    -- satisfies the given constraint, including version range and installation-    -- status.-    ---    (available', excluded', newExcluded, anyRemaining, conflicts) =-      updatePkgsStatus-        available excluded-        [] False []-        (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg')-                 (PackageIndex.lookupPackageName available pkgname)-                 (PackageIndex.lookupPackageName excluded  pkgname))--    testConstraint pkg =-      let ver = packageVersion pkg in-      case Map.lookup (packageName pkg) paired of--        Just (v1, v2)-          | ver == v1 || ver == v2-          -> case pkg of-               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)-               SourceOnly    spkg -> SourceOnly    (spkg, sOk)-               InstalledAndSource ipkg spkg ->-                 InstalledAndSource (ipkg, iOk) (spkg, sOk)-          where-            iOk = constraint v1 True  || constraint v2 True-            sOk = constraint v1 False || constraint v2 False--        _ -> case pkg of-               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)-               SourceOnly    spkg -> SourceOnly    (spkg, sOk)-               InstalledAndSource ipkg spkg ->-                 InstalledAndSource (ipkg, iOk) (spkg, sOk)-          where-            iOk = constraint ver True-            sOk = constraint ver False--    -- For the info about available and excluded versions of the package in-    -- question, update the info given the current constraint-    ---    -- We update the available package map and the excluded package map-    -- we also collect:-    --   * the change in available packages (for logging)-    --   * whether there are any remaining choices-    --   * any constraints that conflict with the current constraint--    updatePkgsStatus _ _ nePkgs ok cs _-      | seq nePkgs $ seq ok $ seq cs False = undefined--    updatePkgsStatus aPkgs ePkgs nePkgs ok cs []-      = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs)--    updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) =-        let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg-            nePkgs' = maybeCons mnePkg nePkgs-            cs'     = maybeCons mc cs-         in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs--    maybeCons Nothing  xs = xs-    maybeCons (Just x) xs = x:xs---    -- For the info about an available or excluded version of the package in-    -- question, update the info given the current constraint.-    ---    updatePkgStatus aPkgs ePkgs pkg =-      case viewPackageStatus pkg of-        AllAvailable (InstalledOnly (aiPkg, False)) ->-          removeAvailable False-            (InstalledOnly aiPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])-            Nothing--        AllAvailable (SourceOnly (asPkg, False)) ->-          removeAvailable False-            (SourceOnly asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])-            Nothing--        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) ->-          removeAvailable False-            (InstalledAndSource aiPkg asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] [])-            Nothing--        AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) ->-          removeAvailable True-            (SourceOnly asPkg)-            (PackageIndex.insert (InstalledOnly aiPkg))-            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])-            Nothing--        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) ->-          removeAvailable True-            (InstalledOnly aiPkg)-            (PackageIndex.insert (SourceOnly asPkg))-            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])-            Nothing--        AllAvailable _ -> noChange True Nothing--        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) ->-          removeAvailable False-            (InstalledOnly aiPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs)-            Nothing--        AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) ->-          addExtraExclusion True-            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))-            Nothing--        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) ->-          removeAvailable  True-            (InstalledOnly aiPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs)-            (Just (pkgid, srs))--        AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) ->-          noChange True-            (Just (pkgid, srs))--        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) ->-          removeAvailable  False-            (SourceOnly asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs [])-            Nothing--        ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) ->-          removeAvailable False-            (SourceOnly asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason])-            (Just (pkgid, irs))--        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) ->-          addExtraExclusion True-            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])-            Nothing--        ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) ->-          noChange True-            (Just (pkgid, irs))--        AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])-            Nothing--        AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) ->-          noChange False-            (Just (pkgid, irs))--        AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) ->-          addExtraExclusion False-            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))-            Nothing--        AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) ->-          noChange False-            (Just (pkgid, srs))--        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs)-            Nothing--        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs))-            (Just (pkgid, irs))--        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs)-            (Just (pkgid, srs))--        AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) ->-          noChange False-            (Just (pkgid, isrs ++ irs ++ srs))--      where-        removeAvailable ok nePkg adjustAvailable ePkg c =-          let aPkgs' = adjustAvailable aPkgs-              ePkgs' = PackageIndex.insert ePkg ePkgs-           in aPkgs' `seq` ePkgs' `seq`-              (aPkgs', ePkgs', Just nePkg, ok, c)--        addExtraExclusion ok ePkg c =-          let ePkgs' = PackageIndex.insert ePkg ePkgs-           in ePkgs' `seq`-              (aPkgs, ePkgs', Nothing, ok, c)--        noChange ok c =-          (aPkgs, ePkgs, Nothing, ok, c)--        pkgid = case pkg of OnlyInLeft  p   -> packageId p-                            OnlyInRight p   -> packageId p-                            InBoth      p _ -> packageId p---    viewPackageStatus-      :: (Package installed, Package source)-      => MergeResult (InstalledOrSource installed source)-                     (ExcludedPkg (InstalledOrSource installed source) reason)-      -> PackageStatus (installed, Bool) (source, Bool) reason-    viewPackageStatus merged =-        case merged of-          OnlyInLeft aPkg ->-            AllAvailable (testConstraint aPkg)--          OnlyInRight (ExcludedPkg ePkg isrs irs srs) ->-            AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs)--          InBoth (InstalledOnly aiPkg)-                 (ExcludedPkg (SourceOnly esPkg) [] [] srs) ->-            case testConstraint (InstalledAndSource aiPkg esPkg) of-              InstalledAndSource (aiPkg', iOk) (esPkg', sOk) ->-                AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs)-              _ -> impossible--          InBoth (SourceOnly asPkg)-                 (ExcludedPkg (InstalledOnly eiPkg) [] irs []) ->-            case testConstraint (InstalledAndSource eiPkg asPkg) of-              InstalledAndSource (eiPkg', iOk) (asPkg', sOk) ->-                ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk)-              _ -> impossible-          _ -> impossible-      where-        impossible = error "impossible: viewPackageStatus invariant violation"---- A intermediate structure that enumerates all the possible cases given the--- invariant. This helps us to get simpler and complete pattern matching in--- updatePkg above----data PackageStatus installed source reason-   = AllAvailable (InstalledOrSource installed source)-   | AllExcluded  (ExcludedPkg (InstalledOrSource installed source) reason)-   | AvailableExcluded installed (ExcludedPkg source reason)-   | ExcludedAvailable (ExcludedPkg installed reason) source---conflicting :: (Package installed, Package source)-            => Constraints installed source reason-            -> Dependency-            -> [(PackageId, [reason])]-conflicting (Constraints _ _ excluded _ _) dep =-  [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO-  | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <--      PackageIndex.lookupDependency excluded dep ]
− cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs 
@@ -1,144 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.TopDown.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Types for the top-down dependency resolver.-------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.TopDown.Types where--import Distribution.Client.Types-         ( ConfiguredPackage(..)-         , UnresolvedPkgLoc, UnresolvedSourcePackage-         , OptionalStanza, ConfiguredId(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.Client.ComponentDeps as CD--import Distribution.Package-         ( PackageId, PackageIdentifier, Dependency-         , Package(packageId) )-import Distribution.PackageDescription-         ( FlagAssignment )---- --------------------------------------------------------------- * The various kinds of packages--- --------------------------------------------------------------type SelectablePackage-   = InstalledOrSource InstalledPackageEx UnconfiguredPackage--type SelectedPackage-   = InstalledOrSource InstalledPackageEx SemiConfiguredPackage--data InstalledOrSource installed source-   = InstalledOnly      installed-   | SourceOnly                   source-   | InstalledAndSource installed source-  deriving Eq--data FinalSelectedPackage-   = SelectedInstalled InstalledPackage-   | SelectedSource    (ConfiguredPackage UnresolvedPkgLoc)--type TopologicalSortNumber = Int---- | InstalledPackage caches its dependencies as source package IDs.-data InstalledPackage-   = InstalledPackage-       InstalledPackageInfo-       [PackageId]--data InstalledPackageEx-   = InstalledPackageEx-       InstalledPackage-       !TopologicalSortNumber-       [PackageIdentifier]    -- transitive closure of installed deps--data UnconfiguredPackage-   = UnconfiguredPackage-       UnresolvedSourcePackage-       !TopologicalSortNumber-       FlagAssignment-       [OptionalStanza]--data SemiConfiguredPackage-   = SemiConfiguredPackage-       UnresolvedSourcePackage           -- package info-       FlagAssignment                    -- total flag assignment for the package-       [OptionalStanza]                  -- enabled optional stanzas-       [Dependency]                      -- dependencies we end up with when we apply-                                         -- the flag assignment--instance Package InstalledPackage where-  packageId (InstalledPackage pkg _) = packageId pkg--instance Package InstalledPackageEx where-  packageId (InstalledPackageEx p _ _) = packageId p--instance Package UnconfiguredPackage where-  packageId (UnconfiguredPackage p _ _ _) = packageId p--instance Package SemiConfiguredPackage where-  packageId (SemiConfiguredPackage p _ _ _) = packageId p--instance (Package installed, Package source)-      => Package (InstalledOrSource installed source) where-  packageId (InstalledOnly      p  ) = packageId p-  packageId (SourceOnly         p  ) = packageId p-  packageId (InstalledAndSource p _) = packageId p--instance Package FinalSelectedPackage where-  packageId (SelectedInstalled pkg) = packageId pkg-  packageId (SelectedSource    pkg) = packageId pkg----- | We can have constraints on selecting just installed or just source--- packages.------ In particular, installed packages can only depend on other installed--- packages while packages that are not yet installed but which we plan to--- install can depend on installed or other not-yet-installed packages.----data InstalledConstraint = InstalledConstraint-                         | SourceConstraint-  deriving (Eq, Show)---- | Package dependencies------ The top-down solver uses its down type class for package dependencies,--- because it wants to know these dependencies as PackageIds, rather than as--- ComponentIds (so it cannot use PackageFixedDeps).------ Ideally we would switch the top-down solver over to use ComponentIds--- throughout; that means getting rid of this type class, and changing over the--- package index type to use Cabal's rather than cabal-install's. That will--- avoid the need for the local definitions of dependencyGraph and--- reverseTopologicalOrder in the top-down solver.------ Note that the top-down solver does not (and probably will never) make a--- distinction between the various kinds of dependencies, so we return a flat--- list here. If we get rid of this type class then any use of `sourceDeps`--- should be replaced by @fold . depends@.-class Package a => PackageSourceDeps a where-  sourceDeps :: a -> [PackageIdentifier]--instance PackageSourceDeps InstalledPackageEx where-  sourceDeps (InstalledPackageEx _ _ deps) = deps--instance PackageSourceDeps (ConfiguredPackage loc) where-  sourceDeps cpkg = map confSrcId $ CD.nonSetupDeps (confPkgDeps cpkg)--instance PackageSourceDeps InstalledPackage where-  sourceDeps (InstalledPackage _ deps) = deps--instance PackageSourceDeps FinalSelectedPackage where-  sourceDeps (SelectedInstalled pkg) = sourceDeps pkg-  sourceDeps (SelectedSource    pkg) = sourceDeps pkg-
cabal/cabal-install/Distribution/Client/Dependency/Types.hs view
@@ -1,193 +1,45 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.------------------------------------------------------------------------------ module Distribution.Client.Dependency.Types (     PreSolver(..),     Solver(..),-    DependencyResolver,-    ResolverPackage(..), -    PackageConstraint(..),-    showPackageConstraint,-    PackagePreferences(..),-    InstalledPreference(..),     PackagesPreferenceDefault(..), -    Progress(..),-    foldProgress,--    LabeledPackageConstraint(..),-    ConstraintSource(..),-    unlabelPackageConstraint,-    showConstraintSource-   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-         ( Applicative(..) )-#endif-import Control.Applicative-         ( Alternative(..) )- import Data.Char          ( isAlpha, toLower )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif -import Distribution.Client.PkgConfigDb-         ( PkgConfigDb )-import Distribution.Client.Types-         ( OptionalStanza(..), SourcePackage(..), ConfiguredPackage )- import qualified Distribution.Compat.ReadP as Parse          ( pfail, munch1 )-import Distribution.PackageDescription-         ( FlagAssignment, FlagName(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.Client.PackageIndex as PackageIndex-         ( PackageIndex )-import Distribution.Simple.PackageIndex ( InstalledPackageIndex )-import Distribution.Package-         ( PackageName )-import Distribution.Version-         ( VersionRange, simplifyVersionRange )-import Distribution.Compiler-         ( CompilerInfo )-import Distribution.System-         ( Platform ) import Distribution.Text-         ( Text(..), display )+         ( Text(..) )  import Text.PrettyPrint          ( text ) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) -import Prelude hiding (fail) - -- | All the solvers that can be selected.-data PreSolver = AlwaysTopDown | AlwaysModular | Choose+data PreSolver = AlwaysModular   deriving (Eq, Ord, Show, Bounded, Enum, Generic)  -- | All the solvers that can be used.-data Solver = TopDown | Modular+data Solver = Modular   deriving (Eq, Ord, Show, Bounded, Enum, Generic)  instance Binary PreSolver instance Binary Solver  instance Text PreSolver where-  disp AlwaysTopDown = text "topdown"   disp AlwaysModular = text "modular"-  disp Choose        = text "choose"   parse = do     name <- Parse.munch1 isAlpha     case map toLower name of-      "topdown" -> return AlwaysTopDown       "modular" -> return AlwaysModular-      "choose"  -> return Choose       _         -> Parse.pfail --- | A dependency resolver is a function that works out an installation plan--- given the set of installed and available packages and a set of deps to--- solve for.------ The reason for this interface is because there are dozens of approaches to--- solving the package dependency problem and we want to make it easy to swap--- in alternatives.----type DependencyResolver loc = Platform-                           -> CompilerInfo-                           -> InstalledPackageIndex-                           -> PackageIndex.PackageIndex (SourcePackage loc)-                           -> PkgConfigDb-                           -> (PackageName -> PackagePreferences)-                           -> [LabeledPackageConstraint]-                           -> [PackageName]-                           -> Progress String String [ResolverPackage loc]---- | The dependency resolver picks either pre-existing installed packages--- or it picks source packages along with package configuration.------ This is like the 'InstallPlan.PlanPackage' but with fewer cases.----data ResolverPackage loc = PreExisting InstalledPackageInfo-                         | Configured  (ConfiguredPackage loc)---- | Per-package constraints. Package constraints must be respected by the--- solver. Multiple constraints for each package can be given, though obviously--- it is possible to construct conflicting constraints (eg impossible version--- range or inconsistent flag assignment).----data PackageConstraint-   = PackageConstraintVersion   PackageName VersionRange-   | PackageConstraintInstalled PackageName-   | PackageConstraintSource    PackageName-   | PackageConstraintFlags     PackageName FlagAssignment-   | PackageConstraintStanzas   PackageName [OptionalStanza]-  deriving (Eq,Show,Generic)--instance Binary PackageConstraint---- | Provide a textual representation of a package constraint--- for debugging purposes.----showPackageConstraint :: PackageConstraint -> String-showPackageConstraint (PackageConstraintVersion pn vr) =-  display pn ++ " " ++ display (simplifyVersionRange vr)-showPackageConstraint (PackageConstraintInstalled pn) =-  display pn ++ " installed"-showPackageConstraint (PackageConstraintSource pn) =-  display pn ++ " source"-showPackageConstraint (PackageConstraintFlags pn fs) =-  "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs)-  where-    showFlag (FlagName f) True  = "+" ++ f-    showFlag (FlagName f) False = "-" ++ f-showPackageConstraint (PackageConstraintStanzas pn ss) =-  "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss)-  where-    showStanza TestStanzas  = "test"-    showStanza BenchStanzas = "bench"---- | Per-package preferences on the version. It is a soft constraint that the--- 'DependencyResolver' should try to respect where possible. It consists of--- an 'InstalledPreference' which says if we prefer versions of packages--- that are already installed. It also has (possibly multiple)--- 'PackageVersionPreference's which are suggested constraints on the version--- number. The resolver should try to use package versions that satisfy--- the maximum number of the suggested version constraints.------ It is not specified if preferences on some packages are more important than--- others.----data PackagePreferences = PackagePreferences [VersionRange]-                                             InstalledPreference-                                             [OptionalStanza]---- | Whether we prefer an installed version of a package or simply the latest--- version.----data InstalledPreference = PreferInstalled | PreferLatest-  deriving Show- -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available. --@@ -212,107 +64,3 @@      --    | PreferLatestForSelected   deriving Show---- | A type to represent the unfolding of an expensive long running--- calculation that may fail. We may get intermediate steps before the final--- result which may be used to indicate progress and\/or logging messages.----data Progress step fail done = Step step (Progress step fail done)-                             | Fail fail-                             | Done done-  deriving Functor---- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two--- base cases, one for a final result and one for failure.------ Eg to convert into a simple 'Either' result use:------ > foldProgress (flip const) Left Right----foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)-             -> Progress step fail done -> a-foldProgress step fail done = fold-  where fold (Step s p) = step s (fold p)-        fold (Fail f)   = fail f-        fold (Done r)   = done r--instance Monad (Progress step fail) where-  return   = pure-  p >>= f  = foldProgress Step Fail f p--instance Applicative (Progress step fail) where-  pure a  = Done a-  p <*> x = foldProgress Step Fail (flip fmap x) p--instance Monoid fail => Alternative (Progress step fail) where-  empty   = Fail mempty-  p <|> q = foldProgress Step (const q) Done p---- | 'PackageConstraint' labeled with its source.-data LabeledPackageConstraint-   = LabeledPackageConstraint PackageConstraint ConstraintSource--unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint-unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc---- | Source of a 'PackageConstraint'.-data ConstraintSource =--  -- | Main config file, which is ~/.cabal/config by default.-  ConstraintSourceMainConfig FilePath--  -- | Local cabal.project file-  | ConstraintSourceProjectConfig FilePath--  -- | Sandbox config file, which is ./cabal.sandbox.config by default.-  | ConstraintSourceSandboxConfig FilePath--  -- | User config file, which is ./cabal.config by default.-  | ConstraintSourceUserConfig FilePath--  -- | Flag specified on the command line.-  | ConstraintSourceCommandlineFlag--  -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@-  -- implies @package==0.1.0.0@.-  | ConstraintSourceUserTarget--  -- | Internal requirement to use installed versions of packages like ghc-prim.-  | ConstraintSourceNonUpgradeablePackage--  -- | Internal requirement to use the add-source version of a package when that-  -- version is installed and the source is modified.-  | ConstraintSourceModifiedAddSourceDep--  -- | Internal constraint used by @cabal freeze@.-  | ConstraintSourceFreeze--  -- | Constraint specified by a config file, a command line flag, or a user-  -- target, when a more specific source is not known.-  | ConstraintSourceConfigFlagOrTarget--  -- | The source of the constraint is not specified.-  | ConstraintSourceUnknown-  deriving (Eq, Show, Generic)--instance Binary ConstraintSource---- | Description of a 'ConstraintSource'.-showConstraintSource :: ConstraintSource -> String-showConstraintSource (ConstraintSourceMainConfig path) =-    "main config " ++ path-showConstraintSource (ConstraintSourceProjectConfig path) =-    "project config " ++ path-showConstraintSource (ConstraintSourceSandboxConfig path) =-    "sandbox config " ++ path-showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path-showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"-showConstraintSource ConstraintSourceUserTarget = "user target"-showConstraintSource ConstraintSourceNonUpgradeablePackage =-    "non-upgradeable package"-showConstraintSource ConstraintSourceModifiedAddSourceDep =-    "modified add-source dependency"-showConstraintSource ConstraintSourceFreeze = "cabal freeze"-showConstraintSource ConstraintSourceConfigFlagOrTarget =-    "config file, command line flag, or user target"-showConstraintSource ConstraintSourceUnknown = "unknown source"
cabal/cabal-install/Distribution/Client/DistDirLayout.hs view
@@ -5,17 +5,45 @@ -- The layout of the .\/dist\/ directory where cabal keeps all of it's state -- and build artifacts. ---module Distribution.Client.DistDirLayout where+module Distribution.Client.DistDirLayout (+    -- 'DistDirLayout'+    DistDirLayout(..),+    DistDirParams(..),+    defaultDistDirLayout, +    -- * 'CabalDirLayout'+    CabalDirLayout(..),+    defaultCabalDirLayout,+) where+ import System.FilePath import Distribution.Package-         ( PackageId )+         ( PackageId, ComponentId, UnitId ) import Distribution.Compiler-import Distribution.Simple.Compiler (PackageDB(..))+import Distribution.Simple.Compiler (PackageDB(..), OptimisationLevel(..)) import Distribution.Text+import Distribution.Types.ComponentName+import Distribution.System import Distribution.Client.Types          ( InstalledPackageId ) +-- | Information which can be used to construct the path to+-- the build directory of a build.  This is LESS fine-grained+-- than what goes into the hashed 'InstalledPackageId',+-- and for good reason: we don't want this path to change if+-- the user, say, adds a dependency to their project.+data DistDirParams = DistDirParams {+    distParamUnitId         :: UnitId,+    distParamPackageId      :: PackageId,+    distParamComponentId    :: ComponentId,+    distParamComponentName  :: Maybe ComponentName,+    distParamCompilerId     :: CompilerId,+    distParamPlatform       :: Platform,+    distParamOptimization   :: OptimisationLevel+    -- TODO (see #3343):+    --  Flag assignments+    --  Optimization+    }   -- | The layout of the project state directory. Traditionally this has been@@ -31,11 +59,11 @@        -- | The directory under dist where we keep the build artifacts for a        -- package we're building from a local directory.        ---       -- This uses a 'PackageId' not just a 'PackageName' because technically+       -- This uses a 'UnitId' not just a 'PackageName' because technically        -- we can have multiple instances of the same package in a solution        -- (e.g. setup deps).        ---       distBuildDirectory           :: PackageId -> FilePath,+       distBuildDirectory           :: DistDirParams -> FilePath,        distBuildRootDirectory       :: FilePath,         -- | The directory under dist where we put the unpacked sources of@@ -55,8 +83,8 @@        -- | The location for package-specific cache files (e.g. state used in        -- incremental rebuilds).        ---       distPackageCacheFile         :: PackageId -> String -> FilePath,-       distPackageCacheDirectory    :: PackageId -> FilePath,+       distPackageCacheFile         :: DistDirParams -> String -> FilePath,+       distPackageCacheDirectory    :: DistDirParams -> FilePath,         distTempDirectory            :: FilePath,        distBinDirectory             :: FilePath,@@ -74,7 +102,6 @@        cabalStorePackageDBPath    :: CompilerId -> FilePath,        cabalStorePackageDB        :: CompilerId -> PackageDB, -       cabalPackageCacheDirectory :: FilePath,        cabalLogsDirectory         :: FilePath,        cabalWorldFile             :: FilePath      }@@ -88,7 +115,23 @@     --TODO: switch to just dist at some point, or some other new name      distBuildRootDirectory   = distDirectory </> "build"-    distBuildDirectory pkgid = distBuildRootDirectory </> display pkgid+    distBuildDirectory params =+        distBuildRootDirectory </>+        display (distParamPlatform params) </>+        display (distParamCompilerId params) </>+        display (distParamPackageId params) </>+        (case fmap componentNameString (distParamComponentName params) of+            Nothing          -> ""+            Just Nothing     -> ""+            Just (Just name) -> "c" </> display name) </>+        (case distParamOptimization params of+            NoOptimisation -> "noopt"+            NormalOptimisation -> ""+            MaximumOptimisation -> "opt") </>+        (let uid_str = display (distParamUnitId params)+         in if uid_str == display (distParamComponentId params)+                then ""+                else uid_str)      distUnpackedSrcRootDirectory   = distDirectory </> "src"     distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory@@ -97,8 +140,8 @@     distProjectCacheDirectory = distDirectory </> "cache"     distProjectCacheFile name = distProjectCacheDirectory </> name -    distPackageCacheDirectory pkgid = distBuildDirectory pkgid </> "cache"-    distPackageCacheFile pkgid name = distPackageCacheDirectory pkgid </> name+    distPackageCacheDirectory params = distBuildDirectory params </> "cache"+    distPackageCacheFile params name = distPackageCacheDirectory params </> name      distTempDirectory = distDirectory </> "tmp" @@ -125,8 +168,6 @@      cabalStorePackageDB =       SpecificPackageDB . cabalStorePackageDBPath--    cabalPackageCacheDirectory = cabalDir </> "packages"      cabalLogsDirectory = cabalDir </> "logs"
cabal/cabal-install/Distribution/Client/Exec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Exec@@ -12,7 +11,8 @@ module Distribution.Client.Exec ( exec                                 ) where -import Control.Monad (unless)+import Prelude ()+import Distribution.Client.Compat.Prelude  import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS@@ -34,10 +34,6 @@  import System.Directory ( doesDirectoryExist ) import System.FilePath (searchPathSeparator, (</>))-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Monoid (mempty)-#endif   -- | Execute the given command in the package's environment.
cabal/cabal-install/Distribution/Client/Fetch.hs view
@@ -21,19 +21,21 @@ import Distribution.Client.Dependency import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.PkgConfigDb-         ( PkgConfigDb, readPkgConfigDb )+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Setup          ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) +import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb )+import Distribution.Solver.Types.SolverPackage+import Distribution.Solver.Types.SourcePackage+ import Distribution.Package          ( packageId ) import Distribution.Simple.Compiler          ( Compiler, compilerInfo, PackageDBStack ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program-         ( ProgramConfiguration )+         ( ProgramDb ) import Distribution.Simple.Setup          ( fromFlag ) import Distribution.Simple.Utils@@ -69,7 +71,7 @@       -> RepoContext       -> Compiler       -> Platform-      -> ProgramConfiguration+      -> ProgramDb       -> GlobalFlags       -> FetchFlags       -> [UserTarget]@@ -77,14 +79,14 @@ fetch verbosity _ _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repoCtxt comp platform conf+fetch verbosity packageDBs repoCtxt comp platform progdb       globalFlags fetchFlags userTargets = do      mapM_ checkTarget userTargets -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity conf+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb      pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)@@ -138,9 +140,9 @@       -- The packages we want to fetch are those packages the 'InstallPlan'       -- that are in the 'InstallPlan.Configured' state.       return-        [ confPkgSource cpkg-        | (InstallPlan.Configured cpkg)-            <- InstallPlan.toList installPlan ]+        [ solverPkgSource cpkg+        | (SolverInstallPlan.Configured cpkg)+            <- SolverInstallPlan.toList installPlan ]    | otherwise =       either (die . unlines . map show) return $@@ -156,6 +158,8 @@        . setReorderGoals reorderGoals +      . setCountConflicts countConflicts+       . setShadowPkgs shadowPkgs        . setStrongFlags strongFlags@@ -172,6 +176,7 @@     logMsg message rest = debug verbosity message >> rest      reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)+    countConflicts   = fromFlag (fetchCountConflicts   fetchFlags)     independentGoals = fromFlag (fetchIndependentGoals fetchFlags)     shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)     strongFlags      = fromFlag (fetchStrongFlags      fetchFlags)
cabal/cabal-install/Distribution/Client/FetchUtils.hs view
@@ -20,8 +20,14 @@     checkFetched,      -- ** specifically for repo packages+    checkRepoTarballFetched,     fetchRepoTarball, +    -- ** fetching packages asynchronously+    asyncFetchPackages,+    waitAsyncFetchPackage,+    AsyncFetchMap,+     -- * fetching other things     downloadIndex,   ) where@@ -34,7 +40,7 @@ import Distribution.Package          ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils-         ( notice, info, setupMessage )+         ( notice, info, debug, setupMessage ) import Distribution.Text          ( display ) import Distribution.Verbosity@@ -43,6 +49,12 @@          ( RepoContext(..) )  import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad+import Control.Exception+import Control.Concurrent.Async+import Control.Concurrent.MVar import System.Directory          ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.IO@@ -70,7 +82,10 @@     RemoteTarballPackage _uri local -> return (isJust local)     RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) -+-- | Checks if the package has already been fetched (or does not need+-- fetching) and if so returns evidence in the form of a 'PackageLocation'+-- with a resolved local file location.+-- checkFetched :: UnresolvedPkgLoc              -> IO (Maybe ResolvedPkgLoc) checkFetched loc = case loc of@@ -84,14 +99,22 @@       return (Just $ RepoTarballPackage repo pkgid file)      RemoteTarballPackage _uri Nothing -> return Nothing-    RepoTarballPackage repo pkgid Nothing -> do-      let file = packageFile repo pkgid-      exists <- doesFileExist file-      if exists-        then return (Just $ RepoTarballPackage repo pkgid file)-        else return Nothing+    RepoTarballPackage repo pkgid Nothing ->+      fmap (fmap (RepoTarballPackage repo pkgid))+           (checkRepoTarballFetched repo pkgid)  +-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.+--+checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)+checkRepoTarballFetched repo pkgid = do+    let file = packageFile repo pkgid+    exists <- doesFileExist file+    if exists+      then return (Just file)+      else return Nothing++ -- | Fetch a package if we don't have it already. -- fetchPackage :: Verbosity@@ -159,7 +182,9 @@           Sec.downloadPackage' rep pkgid path         return path --- | Downloads an index file to [config-dir/packages/serv-id].+-- | Downloads an index file to [config-dir/packages/serv-id] without+-- hackage-security. You probably don't want to call this directly;+-- use 'updateRepo' instead. -- downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex transport verbosity remoteRepo cacheDir = do@@ -171,6 +196,61 @@       path = cacheDir </> "00-index" <.> "tar.gz"   createDirectoryIfMissing True cacheDir   downloadURI transport verbosity uri path+++-- ------------------------------------------------------------+-- * Async fetch wrapper utilities+-- ------------------------------------------------------------++type AsyncFetchMap = Map UnresolvedPkgLoc+                         (MVar (Either SomeException ResolvedPkgLoc))++-- | Fork off an async action to download the given packages (by location).+--+-- The downloads are initiated in order, so you can arrange for packages that+-- will likely be needed sooner to be earlier in the list.+--+-- The body action is passed a map from those packages (identified by their+-- location) to a completion var for that package. So the body action should+-- lookup the location and use 'asyncFetchPackage' to get the result.+--+asyncFetchPackages :: Verbosity+                   -> RepoContext+                   -> [UnresolvedPkgLoc]+                   -> (AsyncFetchMap -> IO a)+                   -> IO a+asyncFetchPackages verbosity repoCtxt pkglocs body = do+    --TODO: [nice to have] use parallel downloads?++    asyncDownloadVars <- sequence [ do v <- newEmptyMVar+                                       return (pkgloc, v)+                                  | pkgloc <- pkglocs ]++    let fetchPackages :: IO ()+        fetchPackages =+          forM_ asyncDownloadVars $ \(pkgloc, var) -> do+            result <- try $ fetchPackage verbosity repoCtxt pkgloc+            putMVar var result++    withAsync fetchPackages $ \_ ->+      body (Map.fromList asyncDownloadVars)+++-- | Expect to find a download in progress in the given 'AsyncFetchMap'+-- and wait on it to finish.+--+-- If the download failed with an exception then this will be thrown.+--+waitAsyncFetchPackage :: Verbosity+                      -> AsyncFetchMap+                      -> UnresolvedPkgLoc+                      -> IO ResolvedPkgLoc+waitAsyncFetchPackage verbosity downloadMap srcloc =+    case Map.lookup srcloc downloadMap of+      Just hnd -> do+        debug verbosity $ "Waiting for download of " ++ show srcloc+        either throwIO return =<< takeMVar hnd+      Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"   -- ------------------------------------------------------------
cabal/cabal-install/Distribution/Client/FileMonitor.hs view
@@ -15,10 +15,13 @@   monitorFile,   monitorFileHashed,   monitorNonExistentFile,+  monitorFileExistence,   monitorDirectory,+  monitorNonExistentDirectory,   monitorDirectoryExistence,   monitorFileOrDirectory,   monitorFileGlob,+  monitorFileGlobExistence,   monitorFileSearchPath,   monitorFileHashedSearchPath, @@ -33,23 +36,18 @@   beginUpdateFileMonitor,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude  #if MIN_VERSION_containers(0,5,0)-import           Data.Map.Strict (Map) import qualified Data.Map.Strict as Map #else-import           Data.Map        (Map) import qualified Data.Map        as Map #endif import qualified Data.ByteString.Lazy as BS-import           Distribution.Compat.Binary-import qualified Distribution.Compat.Binary as Binary+import qualified Distribution.Utils.BinaryWithFingerprint as Binary import qualified Data.Hashable as Hashable-import           Data.List (sort) -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif import           Control.Monad import           Control.Monad.Trans (MonadIO, liftIO) import           Control.Monad.State (StateT, mapStateT)@@ -58,7 +56,7 @@                                        throwError) import           Control.Exception -import           Distribution.Client.Compat.Time+import           Distribution.Compat.Time import           Distribution.Client.Glob import           Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import           Distribution.Client.Utils (mergeBy, MergeResult(..))@@ -66,9 +64,7 @@ import           System.FilePath import           System.Directory import           System.IO-import           GHC.Generics (Generic) - ------------------------------------------------------------------------------ -- Types for specifying files to monitor --@@ -128,6 +124,12 @@ monitorNonExistentFile :: FilePath -> MonitorFilePath monitorNonExistentFile = MonitorFile FileNotExists DirNotExists +-- | Monitor a single file for existence only. The monitored file is+-- considered to have changed if it no longer exists.+--+monitorFileExistence :: FilePath -> MonitorFilePath+monitorFileExistence = MonitorFile FileExists DirNotExists+ -- | Monitor a single directory for changes, based on its modification -- time. The monitored directory is considered to have changed if it no -- longer exists or if its modification time has changed.@@ -135,6 +137,15 @@ monitorDirectory :: FilePath -> MonitorFilePath monitorDirectory = MonitorFile FileNotExists DirModTime +-- | Monitor a single non-existent directory for changes.  The monitored+-- directory is considered to have changed if it exists.+--+monitorNonExistentDirectory :: FilePath -> MonitorFilePath+-- Just an alias for monitorNonExistentFile, since you can't+-- tell the difference between a non-existent directory and+-- a non-existent file :)+monitorNonExistentDirectory = monitorNonExistentFile+ -- | Monitor a single directory for existence. The monitored directory is -- considered to have changed only if it no longer exists. --@@ -156,6 +167,13 @@ monitorFileGlob :: FilePathGlob -> MonitorFilePath monitorFileGlob = MonitorFileGlob FileHashed DirExists +-- | Monitor a set of files (or directories) identified by a file glob for+-- existence only. The monitored glob is considered to have changed if the set+-- of files matching the glob changes (i.e. creations or deletions).+--+monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath+monitorFileGlobExistence = MonitorFileGlob FileExists DirExists+ -- | Creates a list of files to monitor when you search for a file which -- unsuccessfully looked in @notFoundAtPaths@ before finding it at -- @foundAtPath@.@@ -181,8 +199,13 @@ -- files to be monitored (index by their path), and a list of -- globs, which monitor may files at once. data MonitorStateFileSet-   = MonitorStateFileSet !(Map FilePath MonitorStateFile)+   = MonitorStateFileSet ![MonitorStateFile]                          ![MonitorStateGlob]+     -- Morally this is not actually a set but a bag (represented by lists).+     -- There is no principled reason to use a bag here rather than a set, but+     -- there is also no particular gain either. That said, we do preserve the+     -- order of the lists just to reduce confusion (and have predictable I/O+     -- patterns).   deriving Show  type Hash = Int@@ -198,7 +221,7 @@ -- no longer exists at all. -- data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir-                                         !MonitorStateFileStatus+                                         !FilePath !MonitorStateFileStatus   deriving (Show, Generic)  data MonitorStateFileStatus@@ -244,11 +267,10 @@ -- reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =-    Map.foldrWithKey (\k x r -> getSinglePath k x : r)-                     (map getGlobPath globPaths)-                     singlePaths+    map getSinglePath singlePaths+ ++ map getGlobPath globPaths   where-    getSinglePath filepath (MonitorStateFile kindfile kinddir _) =+    getSinglePath (MonitorStateFile kindfile kinddir filepath _) =       MonitorFile kindfile kinddir filepath      getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =@@ -381,7 +403,7 @@ -- See 'FileMonitor' for a full explanation. -- checkFileMonitorChanged-  :: (Binary a, Binary b)+  :: (Binary a, Binary b, Typeable a, Typeable b)   => FileMonitor a b            -- ^ cache file path   -> FilePath                   -- ^ root directory   -> a                          -- ^ guard or key value@@ -459,23 +481,23 @@ -- -- This determines the type and format of the binary cache file. ---readCacheFile :: (Binary a, Binary b)+readCacheFile :: (Binary a, Binary b, Typeable a, Typeable b)               => FileMonitor a b               -> IO (Either String (MonitorStateFileSet, a, b)) readCacheFile FileMonitor {fileMonitorCacheFile} =     withBinaryFile fileMonitorCacheFile ReadMode $ \hnd ->-      Binary.decodeOrFailIO =<< BS.hGetContents hnd+      Binary.decodeWithFingerprintOrFailIO =<< BS.hGetContents hnd  -- | Helper for writing the cache file. -- -- This determines the type and format of the binary cache file. ---rewriteCacheFile :: (Binary a, Binary b)+rewriteCacheFile :: (Binary a, Binary b, Typeable a, Typeable b)                  => FileMonitor a b                  -> MonitorStateFileSet -> a -> b -> IO () rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =     writeFileAtomic fileMonitorCacheFile $-      Binary.encode (fileset, key, result)+      Binary.encodeWithFingerprint (fileset, key, result)  -- | Probe the file system to see if any of the monitored files have changed. --@@ -498,7 +520,7 @@   runChangedM $ do     sequence_       [ probeMonitorStateFileStatus root file status-      | (file, MonitorStateFile _ _ status) <- Map.toList singlePaths ]+      | MonitorStateFile _ _ file status <- singlePaths ]     -- The glob monitors can require state changes     globPaths' <-       sequence@@ -736,7 +758,7 @@ -- any files then you can use @Nothing@ for the timestamp parameter. -- updateFileMonitor-  :: (Binary a, Binary b)+  :: (Binary a, Binary b, Typeable a, Typeable b)   => FileMonitor a b          -- ^ cache file path   -> FilePath                 -- ^ root directory   -> Maybe MonitorTimestamp   -- ^ timestamp when the update action started@@ -775,19 +797,19 @@                                               --   relative to root                          -> IO MonitorStateFileSet buildMonitorStateFileSet mstartTime hashcache root =-    go Map.empty []+    go [] []   where-    go :: Map FilePath MonitorStateFile -> [MonitorStateGlob]+    go :: [MonitorStateFile] -> [MonitorStateGlob]        -> [MonitorFilePath] -> IO MonitorStateFileSet     go !singlePaths !globPaths [] =-      return (MonitorStateFileSet singlePaths globPaths)+      return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths))      go !singlePaths !globPaths        (MonitorFile kindfile kinddir path : monitors) = do-      monitorState <- MonitorStateFile kindfile kinddir+      monitorState <- MonitorStateFile kindfile kinddir path                   <$> buildMonitorStateFile mstartTime hashcache                                             kindfile kinddir root path-      go (Map.insert path monitorState singlePaths) globPaths monitors+      go (monitorState : singlePaths) globPaths monitors      go !singlePaths !globPaths        (MonitorFileGlob kindfile kinddir globPath : monitors) = do@@ -943,7 +965,7 @@ -- that the set of files to monitor can change then it's simpler just to throw -- away the structure and use a finite map. ---readCacheFileHashes :: (Binary a, Binary b)+readCacheFileHashes :: (Binary a, Binary b, Typeable a, Typeable b)                     => FileMonitor a b -> IO FileHashCache readCacheFileHashes monitor =     handleDoesNotExist Map.empty $@@ -958,15 +980,15 @@                     collectAllFileHashes singlePaths         `Map.union` collectAllGlobHashes globPaths -    collectAllFileHashes =-      Map.mapMaybe $ \(MonitorStateFile _ _ fstate) -> case fstate of-        MonitorStateFileHashed mtime hash -> Just (mtime, hash)-        _                                 -> Nothing+    collectAllFileHashes singlePaths =+      Map.fromList [ (fpath, (mtime, hash))+                   | MonitorStateFile _ _ fpath+                       (MonitorStateFileHashed mtime hash) <- singlePaths ]      collectAllGlobHashes globPaths =-      Map.fromList [ (fpath, hash)+      Map.fromList [ (fpath, (mtime, hash))                    | MonitorStateGlob _ _ _ gstate <- globPaths-                   , (fpath, hash) <- collectGlobHashes "" gstate ]+                   , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ]      collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =       [ res
cabal/cabal-install/Distribution/Client/Freeze.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Freeze@@ -16,19 +15,18 @@     freeze, getFreezePkgs   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Config ( SavedConfig(..) ) import Distribution.Client.Types import Distribution.Client.Targets import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..), LabeledPackageConstraint(..) ) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )-import Distribution.Client.InstallPlan-         ( InstallPlan, PlanPackage )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.PkgConfigDb-         ( PkgConfigDb, readPkgConfigDb )+import Distribution.Client.SolverInstallPlan+         ( SolverInstallPlan, SolverPlanPackage )+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Setup          ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)          , RepoContext(..) )@@ -38,13 +36,19 @@ import Distribution.Client.Sandbox.Types          ( SandboxPackageInfo(..) ) +import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PkgConfigDb+import Distribution.Solver.Types.SolverId+ import Distribution.Package          ( Package, packageId, packageName, packageVersion ) import Distribution.Simple.Compiler          ( Compiler, compilerInfo, PackageDBStack ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program-         ( ProgramConfiguration )+         ( ProgramDb ) import Distribution.Simple.Setup          ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils@@ -56,15 +60,7 @@ import Distribution.Verbosity          ( Verbosity ) -import Control.Monad-         ( when ) import qualified Data.ByteString.Lazy.Char8 as BS.Char8-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( mempty )-#endif-import Data.Version-         ( showVersion ) import Distribution.Version          ( thisVersion ) @@ -80,16 +76,16 @@       -> RepoContext       -> Compiler       -> Platform-      -> ProgramConfiguration+      -> ProgramDb       -> Maybe SandboxPackageInfo       -> GlobalFlags       -> FreezeFlags       -> IO ()-freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo       globalFlags freezeFlags = do      pkgs  <- getFreezePkgs-               verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+               verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo                globalFlags freezeFlags      if null pkgs@@ -112,17 +108,17 @@               -> RepoContext               -> Compiler               -> Platform-              -> ProgramConfiguration+              -> ProgramDb               -> Maybe SandboxPackageInfo               -> GlobalFlags               -> FreezeFlags-              -> IO [PlanPackage]-getFreezePkgs verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+              -> IO [SolverPlanPackage]+getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo       globalFlags freezeFlags = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity conf+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb      pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)@@ -151,7 +147,7 @@              -> SourcePackageDb              -> PkgConfigDb              -> [PackageSpecifier UnresolvedSourcePackage]-             -> IO [PlanPackage]+             -> IO [SolverPlanPackage] planPackages verbosity comp platform mSandboxPkgInfo freezeFlags              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do @@ -177,6 +173,8 @@        . setReorderGoals reorderGoals +      . setCountConflicts countConflicts+       . setShadowPkgs shadowPkgs        . setStrongFlags strongFlags@@ -199,6 +197,7 @@     benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags      reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)+    countConflicts   = fromFlag (freezeCountConflicts   freezeFlags)     independentGoals = fromFlag (freezeIndependentGoals freezeFlags)     shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)     strongFlags      = fromFlag (freezeStrongFlags      freezeFlags)@@ -214,14 +213,17 @@ -- 2) not a dependency (directly or transitively) of the package we are --    freezing.  This is useful for removing previously installed packages --    which are no longer required from the install plan.-pruneInstallPlan :: InstallPlan+--+-- Invariant: @pkgSpecifiers@ must refer to packages which are not+-- 'PreExisting' in the 'SolverInstallPlan'.+pruneInstallPlan :: SolverInstallPlan                  -> [PackageSpecifier UnresolvedSourcePackage]-                 -> [PlanPackage]+                 -> [SolverPlanPackage] pruneInstallPlan installPlan pkgSpecifiers =     removeSelf pkgIds $-    InstallPlan.dependencyClosure installPlan (map fakeUnitId pkgIds)+    SolverInstallPlan.dependencyClosure installPlan pkgIds   where-    pkgIds = [ packageId pkg+    pkgIds = [ PlannedId (packageId pkg)              | SpecificSourcePackage pkg <- pkgSpecifiers ]     removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)     removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "@@ -256,4 +258,4 @@   where     showPkg pid = name pid ++ " == " ++ version pid     name = display . packageName-    version = showVersion . packageVersion+    version = display . packageVersion
cabal/cabal-install/Distribution/Client/GenBounds.hs view
@@ -14,8 +14,6 @@     genBounds   ) where -import Data.Version-         ( Version(..), showVersion ) import Distribution.Client.Init          ( incVersion ) import Distribution.Client.Freeze@@ -25,26 +23,31 @@ import Distribution.Client.Setup          ( GlobalFlags(..), FreezeFlags(..), RepoContext ) import Distribution.Package-         ( Package(..), Dependency(..), PackageName(..)+         ( Package(..), Dependency(..), unPackageName          , packageName, packageVersion ) import Distribution.PackageDescription          ( buildDepends ) import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )+         ( finalizePD ) import Distribution.PackageDescription.Parse          ( readPackageDescription )+import Distribution.Types.ComponentRequestedSpec+         ( defaultComponentRequestedSpec ) import Distribution.Simple.Compiler          ( Compiler, PackageDBStack, compilerInfo ) import Distribution.Simple.Program-         ( ProgramConfiguration )+         ( ProgramDb ) import Distribution.Simple.Utils          ( tryFindPackageDesc ) import Distribution.System          ( Platform )+import Distribution.Text+         ( display ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Version-         ( LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals+         ( Version, alterVersion+         , LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals          , orLaterVersion, earlierVersion, intersectVersionRanges ) import System.Directory          ( getCurrentDirectory )@@ -69,7 +72,7 @@            `intersectVersionRanges`            earlierVersion (incVersion 1 (vn 2))   where-    vn n = (v { versionBranch = take n (versionBranch v) })+    vn n = alterVersion (take n) v  -- | Show the PVP-mandated version range for this package. The @padTo@ parameter -- specifies the width of the package name column.@@ -85,7 +88,7 @@     showInterval (LowerBound _ _, NoUpperBound) =       error "Error: expected upper bound...this should never happen!"     showInterval (LowerBound l _, UpperBound u _) =-      unwords [">=", showVersion l, "&& <", showVersion u]+      unwords [">=", display l, "&& <", display u]  -- | Entry point for the @gen-bounds@ command. genBounds@@ -94,12 +97,12 @@     -> RepoContext     -> Compiler     -> Platform-    -> ProgramConfiguration+    -> ProgramDb     -> Maybe SandboxPackageInfo     -> GlobalFlags     -> FreezeFlags     -> IO ()-genBounds verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo       globalFlags freezeFlags = do      let cinfo = compilerInfo comp@@ -107,9 +110,12 @@     cwd <- getCurrentDirectory     path <- tryFindPackageDesc cwd     gpd <- readPackageDescription verbosity path-    let epd = finalizePackageDescription [] (const True) platform cinfo [] gpd+    -- NB: We don't enable tests or benchmarks, since often they+    -- don't really have useful bounds.+    let epd = finalizePD [] defaultComponentRequestedSpec+                    (const True) platform cinfo [] gpd     case epd of-      Left _ -> putStrLn "finalizePackageDescription failed"+      Left _ -> putStrLn "finalizePD failed"       Right (pd,_) -> do         let needBounds = filter (not . hasUpperBound . depVersion) $                          buildDepends pd@@ -121,7 +127,7 @@   where      go needBounds = do        pkgs  <- getFreezePkgs-                  verbosity packageDBs repoCtxt comp platform conf+                  verbosity packageDBs repoCtxt comp platform progdb                   mSandboxPkgInfo globalFlags freezeFlags         putStrLn boundsNeededMsg@@ -134,7 +140,7 @@        mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs       depName :: Dependency -> String-     depName (Dependency (PackageName nm) _) = nm+     depName (Dependency pn _) = unPackageName pn       depVersion :: Dependency -> VersionRange      depVersion (Dependency _ vr) = vr
cabal/cabal-install/Distribution/Client/Get.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Get@@ -18,12 +17,15 @@     get   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)+ import Distribution.Package          ( PackageId, packageId, packageName ) import Distribution.Simple.Setup          ( Flag(..), fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils-         ( notice, die, info, writeFileAtomic )+         ( notice, die, info, rawSystemExitCode, writeFileAtomic ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Text(display)@@ -43,19 +45,13 @@ import Distribution.Compat.Exception         ( catchIO ) +import Distribution.Solver.Types.SourcePackage+ import Control.Exception          ( finally ) import Control.Monad-         ( filterM, forM_, unless, when )-import Data.List-         ( sortBy )+         ( forM_, mapM_ ) import qualified Data.Map-import Data.Maybe-         ( listToMaybe, mapMaybe )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( mempty )-#endif import Data.Ord          ( comparing ) import System.Directory@@ -66,8 +62,6 @@          ( ExitCode(..) ) import System.FilePath          ( (</>), (<.>), addTrailingPathSeparator )-import System.Process-         ( rawSystem )   -- | Entry point for the 'cabal get' command.@@ -295,7 +289,7 @@          Nothing -> ["branch", src, dst]     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("bzr: branch " ++ show src)-        rawSystem "bzr" (args dst)+        rawSystemExitCode verbosity "bzr" (args dst)  -- | Branch driver for Darcs. branchDarcs :: Brancher@@ -306,29 +300,29 @@          Nothing -> ["get", src, dst]     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("darcs: get " ++ show src)-        rawSystem "darcs" (args dst)+        rawSystemExitCode verbosity "darcs" (args dst)  -- | Branch driver for Git. branchGit :: Brancher branchGit = Brancher "git" $ \repo -> do     src <- PD.repoLocation repo-    let branchArgs = case PD.repoBranch repo of-         Just b -> ["--branch", b]-         Nothing -> []-    let postClone dst = case PD.repoTag repo of+    let postClone verbosity dst = case PD.repoTag repo of          Just t -> do              cwd <- getCurrentDirectory              setCurrentDirectory dst              finally-                 (rawSystem "git" (["checkout", t] ++ branchArgs))+                 (rawSystemExitCode verbosity "git" ["checkout", t])                  (setCurrentDirectory cwd)          Nothing -> return ExitSuccess     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("git: clone " ++ show src)-        code <- rawSystem "git" (["clone", src, dst] ++ branchArgs)+        code <- rawSystemExitCode verbosity "git" (["clone", src, dst] +++                    case PD.repoBranch repo of+                        Nothing -> []+                        Just b -> ["--branch", b])         case code of             ExitFailure _ -> return code-            ExitSuccess -> postClone dst+            ExitSuccess -> postClone verbosity  dst  -- | Branch driver for Mercurial. branchHg :: Brancher@@ -343,7 +337,7 @@     let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("hg: clone " ++ show src)-        rawSystem "hg" (args dst)+        rawSystemExitCode verbosity "hg" (args dst)  -- | Branch driver for Subversion. branchSvn :: Brancher@@ -352,4 +346,4 @@     let args dst = ["checkout", src, dst]     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("svn: checkout " ++ show src)-        rawSystem "svn" (args dst)+        rawSystemExitCode verbosity "svn" (args dst)
cabal/cabal-install/Distribution/Client/Glob.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-}  --TODO: [code cleanup] plausibly much of this module should be merged with -- similar functionality in Cabal.@@ -15,14 +15,11 @@     , getFilePathRootDirectory     ) where -import           Data.Char (toUpper)+import Prelude ()+import Distribution.Client.Compat.Prelude+ import           Data.List (stripPrefix)-#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif-import           Control.Monad-import           Distribution.Compat.Binary-import           GHC.Generics (Generic)+import           Control.Monad (mapM)  import           Distribution.Text import           Distribution.Compat.ReadP (ReadP, (<++), (+++))@@ -55,8 +52,7 @@  data FilePathRoot    = FilePathRelative-   | FilePathUnixRoot-   | FilePathWinDrive Char+   | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'    | FilePathHomeDir   deriving (Eq, Show, Generic) @@ -76,9 +72,8 @@ isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath isTrivialFilePathGlob (FilePathGlob root pathglob) =     case root of-      FilePathRelative       -> go []          pathglob-      FilePathUnixRoot       -> go ["/"]       pathglob-      FilePathWinDrive drive -> go [drive:":"] pathglob+      FilePathRelative       -> go []      pathglob+      FilePathRoot root'     -> go [root'] pathglob       FilePathHomeDir        -> Nothing   where     go paths (GlobDir  [Literal path] globs) = go (path:paths) globs@@ -95,10 +90,9 @@ getFilePathRootDirectory :: FilePathRoot                          -> FilePath      -- ^ root for relative paths                          -> IO FilePath-getFilePathRootDirectory  FilePathRelative     root = return root-getFilePathRootDirectory  FilePathUnixRoot        _ = return "/"-getFilePathRootDirectory (FilePathWinDrive drive) _ = return (drive:":")-getFilePathRootDirectory  FilePathHomeDir         _ = getHomeDirectory+getFilePathRootDirectory  FilePathRelative   root = return root+getFilePathRootDirectory (FilePathRoot root) _    = return root+getFilePathRootDirectory  FilePathHomeDir    _    = getHomeDirectory   ------------------------------------------------------------------------------@@ -180,21 +174,17 @@  instance Text FilePathRoot where   disp  FilePathRelative    = Disp.empty-  disp  FilePathUnixRoot    = Disp.char '/'-  disp (FilePathWinDrive c) = Disp.char c-                      Disp.<> Disp.char ':'-                      Disp.<> Disp.char '\\'-  disp FilePathHomeDir      = Disp.char '~'-                      Disp.<> Disp.char '/'+  disp (FilePathRoot root)  = Disp.text root+  disp FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'    parse =-        (     (Parse.char '/' >> return FilePathUnixRoot)+        (     (Parse.char '/' >> return (FilePathRoot "/"))           +++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)           +++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')                                              || (c >= 'A' && c <= 'Z'))                   _ <- Parse.char ':'                   _ <- Parse.char '/' +++ Parse.char '\\'-                  return (FilePathWinDrive (toUpper drive)))+                  return (FilePathRoot (toUpper drive : ":\\")))         )     <++ return FilePathRelative
cabal/cabal-install/Distribution/Client/GlobalFlags.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}+ module Distribution.Client.GlobalFlags (     GlobalFlags(..)   , defaultGlobalFlags@@ -12,9 +13,11 @@   , withRepoContext'   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Types          ( Repo(..), RemoteRepo(..) )-import Distribution.Compat.Semigroup import Distribution.Simple.Setup          ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList@@ -26,22 +29,15 @@ import Distribution.Simple.Utils          ( info ) -import Data.Maybe-         ( fromMaybe ) import Control.Concurrent          ( MVar, newMVar, modifyMVar ) import Control.Exception          ( throwIO )-import Control.Monad-         ( when ) import System.FilePath          ( (</>) ) import Network.URI-         ( uriScheme, uriPath )-import Data.Map-         ( Map )+         ( URI, uriScheme, uriPath ) import qualified Data.Map as Map-import GHC.Generics ( Generic )  import qualified Hackage.Security.Client                    as Sec import qualified Hackage.Security.Util.Path                 as Sec@@ -50,6 +46,7 @@ import qualified Hackage.Security.Client.Repository.Local   as Sec.Local import qualified Hackage.Security.Client.Repository.Remote  as Sec.Remote import qualified Distribution.Client.Security.HTTP          as Sec.HTTP+import qualified Distribution.Client.Security.DNS           as Sec.DNS  -- ------------------------------------------------------------ -- * Global flags@@ -219,8 +216,19 @@                -> (SecureRepo -> IO a)  -- ^ Callback                -> IO a initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do-    withRepo $ \r -> do-      requiresBootstrap <- Sec.requiresBootstrap r+    requiresBootstrap <- withRepo [] Sec.requiresBootstrap++    mirrors <- if requiresBootstrap+               then do+                   info verbosity $ "Trying to locate mirrors via DNS for " +++                                    "initial bootstrap of secure " +++                                    "repository '" ++ show remoteRepoURI +++                                    "' ..."++                   Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI+               else pure []++    withRepo mirrors $ \r -> do       when requiresBootstrap $ Sec.uncheckClientErrors $         Sec.bootstrap r           (map Sec.KeyId    remoteRepoRootKeys)@@ -228,8 +236,8 @@       callback $ SecureRepo r   where     -- Initialize local or remote repo depending on the URI-    withRepo :: (forall down. Sec.Repository down -> IO a) -> IO a-    withRepo callback | uriScheme remoteRepoURI == "file:" = do+    withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a+    withRepo _ callback | uriScheme remoteRepoURI == "file:" = do       dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)       Sec.Local.withRepository dir                                cache@@ -237,9 +245,9 @@                                Sec.hackageIndexLayout                                logTUF                                callback-    withRepo callback =+    withRepo mirrors callback =       Sec.Remote.withRepository httpLib-                                [remoteRepoURI]+                                (remoteRepoURI:mirrors)                                 Sec.Remote.defaultRepoOpts                                 cache                                 Sec.hackageRepoLayout@@ -250,8 +258,15 @@     cache :: Sec.Cache     cache = Sec.Cache {         cacheRoot   = cachePath-      , cacheLayout = Sec.cabalCacheLayout+      , cacheLayout = Sec.cabalCacheLayout {+            Sec.cacheLayoutIndexTar   = cacheFn "01-index.tar"+          , Sec.cacheLayoutIndexIdx   = cacheFn "01-index.tar.idx"+          , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz"+          }       }++    cacheFn :: FilePath -> Sec.CachePath+    cacheFn = Sec.rootPath . Sec.fragment      -- We display any TUF progress only in verbose mode, including any transient     -- verification errors. If verification fails, then the final exception that
cabal/cabal-install/Distribution/Client/Haddock.hs view
@@ -23,9 +23,9 @@ import Distribution.Package          ( packageVersion ) import Distribution.Simple.Haddock (haddockPackagePaths)-import Distribution.Simple.Program (haddockProgram, ProgramConfiguration-                                   , rawSystemProgram, requireProgramVersion)-import Distribution.Version (Version(Version), orLaterVersion)+import Distribution.Simple.Program (haddockProgram, ProgramDb+                                   , runProgram, requireProgramVersion)+import Distribution.Version (mkVersion, orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PackageIndex          ( InstalledPackageIndex, allPackagesByName )@@ -35,17 +35,17 @@          ( InstalledPackageInfo(exposed) )  regenerateHaddockIndex :: Verbosity-                       -> InstalledPackageIndex -> ProgramConfiguration+                       -> InstalledPackageIndex -> ProgramDb                        -> FilePath                        -> IO ()-regenerateHaddockIndex verbosity pkgs conf index = do+regenerateHaddockIndex verbosity pkgs progdb index = do       (paths, warns) <- haddockPackagePaths pkgs' Nothing       let paths' = [ (interface, html) | (interface, Just html) <- paths]       forM_ warns (debug verbosity)        (confHaddock, _, _) <-           requireProgramVersion verbosity haddockProgram-                                    (orLaterVersion (Version [0,6] [])) conf+                                    (orLaterVersion (mkVersion [0,6])) progdb        createDirectoryIfMissing True destDir @@ -57,7 +57,7 @@                     , "--title=Haskell modules on this system" ]                  ++ [ "--read-interface=" ++ html ++ "," ++ interface                     | (interface, html) <- paths' ]-        rawSystemProgram verbosity confHaddock flags+        runProgram verbosity confHaddock flags         renameFile (tempDir </> "index.html") (tempDir </> destFile)         installDirectoryContents verbosity tempDir destDir
cabal/cabal-install/Distribution/Client/HttpUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | Separate module for HTTP actions, using a proxy server if one exists. -----------------------------------------------------------------------------@@ -14,6 +14,9 @@     isOldHackageURI   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Network.HTTP          ( Request (..), Response (..), RequestMethod (..)          , Header(..), HeaderName(..), lookupHeader )@@ -23,17 +26,14 @@ import Network.Browser          ( browse, setOutHandler, setErrHandler, setProxy          , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import qualified Control.Exception as Exception+import Control.Exception+         ( evaluate )+import Control.DeepSeq+         ( force ) import Control.Monad-         ( when, guard )+         ( guard ) import qualified Data.ByteString.Lazy.Char8 as BS-import Data.List-         ( isPrefixOf, find, intercalate )-import Data.Maybe-         ( listToMaybe, maybeToList, fromMaybe ) import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils@@ -41,21 +41,21 @@          , copyFileVerbose,  withTempFile          , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Client.Utils-         ( readMaybe, withTempFileName )+         ( withTempFileName ) import Distribution.Client.Types          ( RemoteRepo(..) ) import Distribution.System          ( buildOS, buildArch ) import Distribution.Text          ( display )-import Data.Char-         ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix          ( splitDirectories ) import System.FilePath          ( (<.>) ) import System.Directory          ( doesFileExist, renameFile )+import System.IO+         ( withFile, IOMode(ReadMode), hGetContents, hClose ) import System.IO.Error          ( isDoesNotExistError ) import Distribution.Simple.Program@@ -70,7 +70,6 @@         ( IOEncoding(..), getEffectiveEnvironment ) import Numeric (showHex) import System.Directory (canonicalizePath)-import System.IO (hClose) import System.FilePath (takeFileName, takeDirectory) import System.Random (randomRIO) import System.Exit (ExitCode(..))@@ -340,9 +339,10 @@            resp <- getProgramInvocationOutput verbosity                     (programInvocation prog args)-          headers <- readFile tmpFile-          (code, _err, etag') <- parseResponse uri resp headers-          return (code, etag')+          withFile tmpFile ReadMode $ \hnd -> do+            headers <- hGetContents hnd+            (code, _err, etag') <- parseResponse uri resp headers+            evaluate $ force (code, etag')      posthttp = noPostYet @@ -363,6 +363,7 @@                    , "--user-agent", userAgent                    , "--silent", "--show-error"                    , "--header", "Accept: text/plain"+                   , "--location"                    ]         resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth                   (programInvocation prog args)@@ -375,6 +376,7 @@                    , "--write-out", "\n%{http_code}"                    , "--user-agent", userAgent                    , "--silent", "--show-error"+                   , "--location"                    , "--header", "Accept: text/plain"                    ]                 ++ concat@@ -385,8 +387,9 @@         (code, err, _etag) <- parseResponse uri resp ""         return (code, err) -    -- on success these curl involcations produces an output like "200"+    -- on success these curl invocations produces an output like "200"     -- and on failure it has the server error response first+    parseResponse :: URI -> String -> String -> IO (Int, String, Maybe ETag)     parseResponse uri resp headers =       let codeerr =             case reverse (lines resp) of@@ -411,11 +414,24 @@  wgetTransport :: ConfiguredProgram -> HttpTransport wgetTransport prog =-    HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  HttpTransport gethttp posthttp posthttpfile puthttpfile True False   where-    gethttp verbosity uri etag destPath reqHeaders = do+    gethttp verbosity uri etag destPath reqHeaders =  do         resp <- runWGet verbosity uri args-        (code, _err, etag') <- parseResponse uri resp++        -- wget doesn't support range requests.+        -- so, we not only ignore range request headers,+        -- but we also dispay a warning message when we see them.+        let hasRangeHeader =  any (\hdr -> isRangeHeader hdr) reqHeaders+            warningMsg     =  "the 'wget' transport currently doesn't support"+                           ++ " range requests, which wastes network bandwidth."+                           ++ " To fix this, set 'http-transport' to 'curl' or"+                           ++ " 'plain-http' in '~/.cabal/config'."+                           ++ " Note that the 'plain-http' transport doesn't"+                           ++ " support HTTPS.\n"++        when (hasRangeHeader) $ warn verbosity warningMsg+        (code, etag') <- parseOutput uri resp         return (code, etag')       where         args = [ "--output-document=" ++ destPath@@ -427,37 +443,56 @@                [ ["--header", "If-None-Match: " ++ t]                | t <- maybeToList etag ]             ++ [ "--header=" ++ show name ++ ": " ++ value-               | Header name value <- reqHeaders ]+               | hdr@(Header name value) <- reqHeaders+               , (not (isRangeHeader hdr)) ] +        -- wget doesn't support range requests.+        -- so, we ignore range request headers, lest we get errors.+        isRangeHeader :: Header -> Bool+        isRangeHeader (Header HdrRange _) = True+        isRangeHeader _ = False+     posthttp = noPostYet      posthttpfile verbosity  uri path auth =         withTempFile (takeDirectory path)-                     (takeFileName path) $ \tmpFile tmpHandle -> do+                     (takeFileName path) $ \tmpFile tmpHandle ->+        withTempFile (takeDirectory path) "response" $+        \responseFile responseHandle -> do+          hClose responseHandle           (body, boundary) <- generateMultipartBody path           BS.hPut tmpHandle body-          BS.writeFile "wget.in" body           hClose tmpHandle           let args = [ "--post-file=" ++ tmpFile                      , "--user-agent=" ++ userAgent                      , "--server-response"+                     , "--output-document=" ++ responseFile+                     , "--header=Accept: text/plain"                      , "--header=Content-type: multipart/form-data; " ++                                               "boundary=" ++ boundary ]-          resp <- runWGet verbosity (addUriAuth auth uri) args-          (code, err, _etag) <- parseResponse uri resp-          return (code, err)+          out <- runWGet verbosity (addUriAuth auth uri) args+          (code, _etag) <- parseOutput uri out+          withFile responseFile ReadMode $ \hnd -> do+            resp <- hGetContents hnd+            evaluate $ force (code, resp) -    puthttpfile verbosity uri path auth headers = do-        let args = [ "--method=PUT", "--body-file="++path-                   , "--user-agent=" ++ userAgent-                   , "--server-response"-                   , "--header=Accept: text/plain" ]-                ++ [ "--header=" ++ show name ++ ": " ++ value-                   | Header name value <- headers ]+    puthttpfile verbosity uri path auth headers =+        withTempFile (takeDirectory path) "response" $+        \responseFile responseHandle -> do+            hClose responseHandle+            let args = [ "--method=PUT", "--body-file="++path+                       , "--user-agent=" ++ userAgent+                       , "--server-response"+                       , "--output-document=" ++ responseFile+                       , "--header=Accept: text/plain" ]+                    ++ [ "--header=" ++ show name ++ ": " ++ value+                       | Header name value <- headers ] -        resp <- runWGet verbosity (addUriAuth auth uri) args-        (code, err, _etag) <- parseResponse uri resp-        return (code, err)+            out <- runWGet verbosity (addUriAuth auth uri) args+            (code, _etag) <- parseOutput uri out+            withFile responseFile ReadMode $ \hnd -> do+              resp <- hGetContents hnd+              evaluate $ force (code, resp)      addUriAuth Nothing uri = uri     addUriAuth (Just (user, pass)) uri = uri@@ -487,23 +522,19 @@     -- http server response with all headers, we want to find a line like     -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple     -- requests due to redirects.-    ---    -- Unfortunately wget apparently cannot be persuaded to give us the body-    -- of error responses, so we just return the human readable status message-    -- like "Forbidden" etc.-    parseResponse uri resp =-      let codeerr = listToMaybe-                    [ (code, unwords err)-                    | (protocol:codestr:err) <- map words (reverse (lines resp))-                    , "HTTP/" `isPrefixOf` protocol-                    , code <- maybeToList (readMaybe codestr) ]+    parseOutput uri resp =+      let parsedCode = listToMaybe+                     [ code+                     | (protocol:codestr:_err) <- map words (reverse (lines resp))+                     , "HTTP/" `isPrefixOf` protocol+                     , code <- maybeToList (readMaybe codestr) ]           mb_etag :: Maybe ETag           mb_etag  = listToMaybe                     [ etag                     | ["ETag:", etag] <- map words (reverse (lines resp)) ]-       in case codeerr of-            Just (i, err) -> return (i, err, mb_etag)-            _             -> statusParseFail uri resp+       in case parsedCode of+            Just i -> return (i, mb_etag)+            _      -> statusParseFail uri resp   powershellTransport :: ConfiguredProgram -> HttpTransport@@ -635,7 +666,8 @@       (_, resp) <- cabalBrowse verbosity Nothing (request req)       let code  = convertRspCode (rspCode resp)           etag' = lookupHeader HdrETag (rspHeaders resp)-      when (code==200) $+      -- 206 Partial Content is a normal response to a range request; see #3385.+      when (code==200 || code==206) $         writeFileAtomic destPath $ rspBody resp       return (code, etag')
cabal/cabal-install/Distribution/Client/IndexUtils.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.IndexUtils@@ -21,28 +23,33 @@   getSourcePackages,   getSourcePackagesMonitorFiles, +  IndexState(..),+  getSourcePackagesAtIndexState,+   Index(..),   PackageEntry(..),   parsePackageIndex,   updateRepoIndexCache,   updatePackageIndexCacheFile,-  readCacheStrict,+  readCacheStrict, -- only used by soon-to-be-obsolete sandbox code    BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import qualified Codec.Archive.Tar       as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar+import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types  import Distribution.Package-         ( PackageId, PackageIdentifier(..), PackageName(..)+         ( PackageId, PackageIdentifier(..), mkPackageName          , Package(..), packageVersion, packageName          , Dependency(Dependency) )-import Distribution.Client.PackageIndex (PackageIndex)-import qualified Distribution.Client.PackageIndex      as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription@@ -52,13 +59,13 @@ import Distribution.Simple.Compiler          ( Compiler, PackageDBStack ) import Distribution.Simple.Program-         ( ProgramConfiguration )+         ( ProgramDb ) import qualified Distribution.Simple.Configure as Configure          ( getInstalledPackages, getInstalledPackagesMonitorFiles ) import Distribution.ParseUtils          ( ParseResult(..) ) import Distribution.Version-         ( Version(Version), intersectVersionRanges )+         ( mkVersion, intersectVersionRanges ) import Distribution.Text          ( display, simpleParse ) import Distribution.Verbosity@@ -68,15 +75,14 @@ import Distribution.Client.Setup          ( RepoContext(..) ) -import Data.Char   (isAlphaNum)-import Data.Maybe  (mapMaybe, catMaybes, maybeToList)-import Data.List   (isPrefixOf)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif+import           Distribution.Solver.Types.PackageIndex (PackageIndex)+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.SourcePackage+ import qualified Data.Map as Map-import Control.Monad (when, liftM)-import Control.Exception (evaluate)+import Control.DeepSeq+import Control.Monad+import Control.Exception import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS@@ -84,11 +90,12 @@ import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath                                  , tryFindAddSourcePackageDesc )+import Distribution.Compat.Binary import Distribution.Compat.Exception (catchIO)-import Distribution.Client.Compat.Time (getFileAge, getModTime)+import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath-         ( (</>), takeExtension, replaceExtension, splitDirectories, normalise )+         ( (</>), (<.>), takeExtension, replaceExtension, splitDirectories, normalise ) import System.FilePath.Posix as FilePath.Posix          ( takeFileName ) import System.IO@@ -100,17 +107,76 @@  -- | Reduced-verbosity version of 'Configure.getInstalledPackages' getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -> ProgramConfiguration+                     -> PackageDBStack -> ProgramDb                      -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packageDbs conf =-    Configure.getInstalledPackages verbosity' comp packageDbs conf+getInstalledPackages verbosity comp packageDbs progdb =+    Configure.getInstalledPackages verbosity' comp packageDbs progdb   where     verbosity'  = lessVerbose verbosity ++-- | Get filename base (i.e. without file extension) for index-related files+--+-- /Secure/ cabal repositories use a new extended & incremental+-- @01-index.tar@. In order to avoid issues resulting from clobbering+-- new/old-style index data, we save them locally to different names.+--+-- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the+-- @00-index.tar.gz@/@01-index.tar.gz@ file.+indexBaseName :: Repo -> FilePath+indexBaseName repo = repoLocalDir repo </> fn+  where+    fn = case repo of+           RepoSecure {} -> "01-index"+           RepoRemote {} -> "00-index"+           RepoLocal  {} -> "00-index"+ ------------------------------------------------------------------------ -- Reading the source package index -- +-- Note: 'data IndexState' is defined in+-- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles++-- | 'IndexStateInfo' contains meta-information about the resulting+-- filtered 'Cache' 'after applying 'filterCache' according to a+-- requested 'IndexState'.+data IndexStateInfo = IndexStateInfo+    { isiMaxTime  :: !Timestamp+    -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current+    -- filtered view of the cache.+    --+    -- The following property holds+    --+    -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)+    --++    , isiHeadTime :: !Timestamp+    -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest+    -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to+    -- 'isiMaxTime'.+    }++emptyStateInfo :: IndexStateInfo+emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp++-- | Filters a 'Cache' according to an 'IndexState'+-- specification. Also returns 'IndexStateInfo' describing the+-- resulting index cache.+--+-- Note: 'filterCache' is idempotent in the 'Cache' value+filterCache :: IndexState -> Cache -> (Cache, IndexStateInfo)+filterCache IndexStateHead cache = (cache, IndexStateInfo{..})+  where+    isiMaxTime  = cacheHeadTs cache+    isiHeadTime = cacheHeadTs cache+filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})+  where+    cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime }+    isiHeadTime = cacheHeadTs cache0+    isiMaxTime  = maximumTimestamp (map cacheEntryTimestamp ents)+    ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0)+ -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's. --@@ -119,16 +185,67 @@ -- -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb-getSourcePackages verbosity repoCtxt | null (repoContextRepos repoCtxt) = do-  warn verbosity $ "No remote package servers have been specified. Usually "-                ++ "you would have one specified in the config file."-  return SourcePackageDb {-    packageIndex       = mempty,-    packagePreferences = mempty-  }-getSourcePackages verbosity repoCtxt = do-  info verbosity "Reading available packages..."-  pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt)+getSourcePackages verbosity repoCtxt =+    getSourcePackagesAtIndexState verbosity repoCtxt IndexStateHead++-- | Variant of 'getSourcePackages' which allows getting the source+-- packages at a particular 'IndexState'.+--+-- Current choices are either the latest (aka HEAD), or the index as+-- it was at a particular time.+--+-- TODO: Enhance to allow specifying per-repo 'IndexState's and also+-- report back per-repo 'IndexStateInfo's (in order for @new-freeze@+-- to access it)+getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState+                           -> IO SourcePackageDb+getSourcePackagesAtIndexState verbosity repoCtxt _+  | null (repoContextRepos repoCtxt) = do+      warn verbosity $ "No remote package servers have been specified. Usually "+                       ++ "you would have one specified in the config file."+      return SourcePackageDb {+        packageIndex       = mempty,+        packagePreferences = mempty+      }+getSourcePackagesAtIndexState verbosity repoCtxt idxState = do+  case idxState of+      IndexStateHead      -> info verbosity "Reading available packages..."+      IndexStateTime time ->+          info verbosity ("Reading available packages (for index-state as of "+                          ++ display time ++ ")...")++  pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do+      let rname = maybe "" remoteRepoName $ maybeRepoRemote r+      unless (idxState == IndexStateHead) $+          case r of+            RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")+            RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')")+            RepoSecure {} -> pure ()+++      let idxState' = case r of+            RepoSecure {} -> idxState+            _             -> IndexStateHead++      (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState'++      case idxState' of+        IndexStateHead -> do+            info verbosity ("index-state("++rname++") = " +++                              display (isiHeadTime isi))+            return ()+        IndexStateTime ts0 -> do+            when (isiMaxTime isi /= ts0) $+                warn verbosity ("Requested index-state " ++ display ts0+                                ++ " does not exist in '"++rname++"'!"+                                ++ " Falling back to older state ("+                                ++ display (isiMaxTime isi) ++ ").")+            info verbosity ("index-state("++rname++") = " +++                              display (isiMaxTime isi) ++ " (HEAD = " +++                              display (isiHeadTime isi) ++ ")")++      pure (pis,deps)+   let (pkgs, prefs) = mconcat pkgss       prefs' = Map.fromListWith intersectVersionRanges                  [ (name, range) | Dependency name range <- prefs ]@@ -142,7 +259,7 @@ readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency]) readCacheStrict verbosity index mkPkg = do     updateRepoIndexCache verbosity index-    cache <- liftM readIndexCache $ BSS.readFile (cacheFile index)+    cache <- readIndexCache verbosity index     withFile (indexFile index) ReadMode $ \indexHnd ->       packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict @@ -153,13 +270,15 @@ -- -- This is a higher level wrapper used internally in cabal-install. ---readRepoIndex :: Verbosity -> RepoContext -> Repo-              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency])-readRepoIndex verbosity repoCtxt repo =+readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState+              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)+readRepoIndex verbosity repoCtxt repo idxState =   handleNotFound $ do     warnIfIndexIsOld =<< getIndexFileAge repo     updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)-    readPackageIndexCacheFile mkAvailablePackage (RepoIndex repoCtxt repo)+    readPackageIndexCacheFile verbosity mkAvailablePackage+                              (RepoIndex repoCtxt repo)+                              idxState    where     mkAvailablePackage pkgEntry =@@ -184,7 +303,7 @@           RepoLocal{..}  -> warn verbosity $                "The package list for the local repo '" ++ repoLocalDir             ++ "' is missing. The repo is invalid."-        return mempty+        return (mempty,mempty,emptyStateInfo)       else ioError e      isOldThreshold = 15 --days@@ -204,15 +323,14 @@  -- | Return the age of the index file in days (as a Double). getIndexFileAge :: Repo -> IO Double-getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar"+getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar"  -- | A set of files (or directories) that can be monitored to detect when -- there might have been a change in the source packages. -- getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] getSourcePackagesMonitorFiles repos =-    [ repoLocalDir repo </> "00-index.cache"-    | repo <- repos ]+    [ indexBaseName repo <.> "cache" | repo <- repos ]  -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like.@@ -244,8 +362,10 @@  -- | A build tree reference is either a link or a snapshot. data BuildTreeRefType = SnapshotRef | LinkRef-                      deriving Eq+                      deriving (Eq,Generic) +instance Binary BuildTreeRefType+ refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType refTypeFromTypeCode t   | t == Tar.buildTreeRefTypeCode      = LinkRef@@ -313,7 +433,7 @@         [pkgname,vers,_] -> case simpleParse vers of           Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)             where-              pkgid  = PackageIdentifier (PackageName pkgname) ver+              pkgid  = PackageIdentifier (mkPackageName pkgname) ver               parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack                                                $ content               descr  = case parsed of@@ -379,6 +499,19 @@                    xs' <- lazySequence xs                    return (x' : xs') +-- | A lazy unfolder for lookup operations which return the current+-- value and (possibly) the next key+lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)]+lazyUnfold step = goLazy . Just+  where+    goLazy s = unsafeInterleaveIO (go s)++    go Nothing  = return []+    go (Just k) = do+        (v, mk') <- step k+        vs' <- goLazy mk'+        return ((k,v):vs')+ -- | Which index do we mean? data Index =     -- | The main index for the specified repository@@ -389,19 +522,33 @@   | SandboxIndex FilePath  indexFile :: Index -> FilePath-indexFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.tar"+indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar" indexFile (SandboxIndex index)   = index  cacheFile :: Index -> FilePath-cacheFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.cache"+cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" cacheFile (SandboxIndex index)   = index `replaceExtension` "cache" +-- | Return 'True' if 'Index' uses 01-index format (aka secure repo)+is01Index :: Index -> Bool+is01Index (RepoIndex _ repo) = case repo of+                                 RepoSecure {} -> True+                                 RepoRemote {} -> False+                                 RepoLocal  {} -> False+is01Index (SandboxIndex _)   = False++ updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do-    info verbosity ("Updating index cache file " ++ cacheFile index)+    info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")     withIndexEntries index $ \entries -> do-      let cache = Cache { cacheEntries = entries }-      writeFile (cacheFile index) (showIndexCache cache)+      let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)+          cache = Cache { cacheHeadTs  = maxTs+                        , cacheEntries = entries+                        }+      writeIndexCache index cache+      info verbosity ("Index cache updated to index-state "+                      ++ display (cacheHeadTs cache))  -- | Read the index (for the purpose of building a cache) --@@ -427,43 +574,58 @@ withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =     repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->       Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do-        let mk :: (Sec.DirectoryEntry, fp, Maybe (Sec.Some Sec.IndexFile))-               -> IO [IndexCacheEntry]-            mk (_, _fp, Nothing) =-              return [] -- skip unrecognized file-            mk (_, _fp, Just (Sec.Some (Sec.IndexPkgMetadata _pkgId))) =-              return [] -- skip metadata-            mk (dirEntry, _fp, Just (Sec.Some (Sec.IndexPkgCabal pkgId))) = do-              let blockNo = fromIntegral (Sec.directoryEntryBlockNo dirEntry)-              return [CachePackageId pkgId blockNo]-            mk (dirEntry, _fp, Just (Sec.Some file@(Sec.IndexPkgPrefs _pkgName))) = do-              content <- Sec.indexEntryContent `fmap` indexLookupFileEntry dirEntry file-              return $ map CachePreference (parsePreferredVersions content)-        entriess <- lazySequence $ map mk (Sec.directoryEntries indexDirectory)-        callback $ concat entriess-withIndexEntries index callback = do+        -- Incrementally (lazily) read all the entries in the tar file in order,+        -- including all revisions, not just the last revision of each file+        indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)+        callback [ cacheEntry+                 | (dirEntry, indexEntry) <- indexEntries+                 , cacheEntry <- toCacheEntries dirEntry indexEntry ]+  where+    toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry+                   -> [IndexCacheEntry]+    toCacheEntries dirEntry (Sec.Some sie) =+        case Sec.indexEntryPathParsed sie of+          Nothing                            -> [] -- skip unrecognized file+          Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata+          Just (Sec.IndexPkgCabal pkgId)     -> force+              [CachePackageId pkgId blockNo timestamp]+          Just (Sec.IndexPkgPrefs _pkgName)  -> force+              [ CachePreference dep blockNo timestamp+              | dep <- parsePreferredVersions (Sec.indexEntryContent sie)+              ]+      where+        blockNo = Sec.directoryEntryBlockNo dirEntry+        timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $+                              epochTimeToTimestamp $ Sec.indexEntryTime sie++withIndexEntries index callback = do -- non-secure repositories     withFile (indexFile index) ReadMode $ \h -> do       bs          <- maybeDecompress `fmap` BS.hGetContents h       pkgsOrPrefs <- lazySequence $ parsePackageIndex bs       callback $ map toCache (catMaybes pkgsOrPrefs)   where     toCache :: PackageOrDep -> IndexCacheEntry-    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo+    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp     toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo-    toCache (Dep d) = CachePreference d+    toCache (Dep d) = CachePreference d 0 nullTimestamp  data ReadPackageIndexMode = ReadPackageIndexStrict                           | ReadPackageIndexLazyIO  readPackageIndexCacheFile :: Package pkg-                          => (PackageEntry -> pkg)+                          => Verbosity+                          -> (PackageEntry -> pkg)                           -> Index-                          -> IO (PackageIndex pkg, [Dependency])-readPackageIndexCacheFile mkPkg index = do-  cache    <- liftM readIndexCache $ BSS.readFile (cacheFile index)-  indexHnd <- openFile (indexFile index) ReadMode-  packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO+                          -> IndexState+                          -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)+readPackageIndexCacheFile verbosity mkPkg index idxState = do+    cache0    <- readIndexCache verbosity index+    indexHnd <- openFile (indexFile index) ReadMode+    let (cache,isi) = filterCache idxState cache0+    (pkgs,deps) <- packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO+    pure (pkgs,deps,isi) + packageIndexFromCache :: Package pkg                       => (PackageEntry -> pkg)                       -> Handle@@ -477,19 +639,23 @@  -- | Read package list ----- The result packages (though not the preferences) are guaranteed to be listed--- in the same order as they are in the tar file (because later entries in a tar--- file mask earlier ones).+-- The result package releases and preference entries are guaranteed+-- to be unique.+--+-- Note: 01-index.tar is an append-only index and therefore contains+-- all .cabal edits and preference-updates. The masking happens+-- here, i.e. the semantics that later entries in a tar file mask+-- earlier ones is resolved in this function. packageListFromCache :: (PackageEntry -> pkg)                      -> Handle                      -> Cache                      -> ReadPackageIndexMode                      -> IO ([pkg], [Dependency])-packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries+packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries   where-    accum srcpkgs prefs [] = return (reverse srcpkgs, prefs)+    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) -    accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do+    accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do       -- Given the cache entry, make a package index entry.       -- The magic here is that we use lazy IO to read the .cabal file       -- from the index tarball if it turns out that we need it.@@ -504,9 +670,9 @@             ReadPackageIndexStrict ->               pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg                                             pkgtxt blockno)-      accum (srcpkg:srcpkgs) prefs entries+      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries -    accum srcpkgs prefs (CacheBuildTreeRef refType blockno : entries) = do+    accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do       -- We have to read the .cabal file eagerly here because we can't cache the       -- package id for build tree references - the user might edit the .cabal       -- file after the reference was added to the index.@@ -515,10 +681,10 @@                  file <- tryFindAddSourcePackageDesc path err                  PackageDesc.Parse.readPackageDescription normal file       let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)-      accum (srcpkg:srcpkgs) prefs entries+      accum srcpkgs (srcpkg:btrs) prefs entries -    accum srcpkgs prefs (CachePreference pref : entries) =-      accum srcpkgs (pref:prefs) entries+    accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _) _ _ : entries) =+      accum srcpkgs btrs (Map.insert pn pref prefs) entries      getEntryContent :: BlockNo -> IO ByteString     getEntryContent blockno = do@@ -544,31 +710,156 @@ -- Index cache data structure -- +-- | Read the 'Index' cache from the filesystem+--+-- If a corrupted index cache is detected this function regenerates+-- the index cache and then reattempt to read the index once (and+-- 'die's if it fails again).+readIndexCache :: Verbosity -> Index -> IO Cache+readIndexCache verbosity index = do+    cacheOrFail <- readIndexCache' index+    case cacheOrFail of+      Left msg -> do+          warn verbosity $ concat+              [ "Parsing the index cache failed (", msg, "). "+              , "Trying to regenerate the index cache..."+              ]++          updatePackageIndexCacheFile verbosity index++          either die (return . hashConsCache) =<< readIndexCache' index++      Right res -> return (hashConsCache res)++-- | Read the 'Index' cache from the filesystem without attempting to+-- regenerate on parsing failures.+readIndexCache' :: Index -> IO (Either String Cache)+readIndexCache' index+  | is01Index index = decodeFileOrFail' (cacheFile index)+  | otherwise       = liftM (Right .read00IndexCache) $+                      BSS.readFile (cacheFile index)++-- | Write the 'Index' cache to the filesystem+writeIndexCache :: Index -> Cache -> IO ()+writeIndexCache index cache+  | is01Index index = encodeFile (cacheFile index) cache+  | otherwise       = writeFile (cacheFile index) (show00IndexCache cache)++-- | Optimise sharing of equal values inside 'Cache'+--+-- c.f. https://en.wikipedia.org/wiki/Hash_consing+hashConsCache :: Cache -> Cache+hashConsCache cache0+    = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) }+  where+    -- TODO/NOTE:+    --+    -- If/when we redo the binary serialisation via e.g. CBOR and we+    -- are able to use incremental decoding, we may want to move the+    -- hash-consing into the incremental deserialisation, or+    -- alterantively even do something like+    -- http://cbor.schmorp.de/value-sharing+    --+    go _ _ [] = []+    -- for now we only optimise only CachePackageIds since those+    -- represent the vast majority+    go !pns !pvs (CachePackageId pid bno ts : rest)+        = CachePackageId pid' bno ts : go pns' pvs' rest+      where+        !pid' = PackageIdentifier pn' pv'+        (!pn',!pns') = mapIntern pn pns+        (!pv',!pvs') = mapIntern pv pvs+        PackageIdentifier pn pv = pid++    go pns pvs (x:xs) = x : go pns pvs xs++    mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k)+    mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m)++-- | Cabal caches various information about the Hackage index+data Cache = Cache+    { cacheHeadTs  :: Timestamp+      -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the+      -- invariant of 'cacheEntries' being in chronological order is+      -- violated, this corresponds to the last (seen) 'Timestamp' in+      -- 'cacheEntries'+    , cacheEntries :: [IndexCacheEntry]+    }++instance NFData Cache where+    rnf = rnf . cacheEntries+ -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. ---type BlockNo = Tar.TarEntryOffset+type BlockNo = Word32 -- Tar.TarEntryOffset -data IndexCacheEntry = CachePackageId PackageId BlockNo-                     | CacheBuildTreeRef BuildTreeRefType BlockNo-                     | CachePreference Dependency-  deriving (Eq) -installedUnitId, blocknoKey, buildTreeRefKey, preferredVersionKey :: String-installedUnitId = "pkg:"+data IndexCacheEntry+    = CachePackageId PackageId !BlockNo !Timestamp+    | CachePreference Dependency !BlockNo !Timestamp+    | CacheBuildTreeRef !BuildTreeRefType !BlockNo+      -- NB: CacheBuildTreeRef is irrelevant for 01-index & new-build+  deriving (Eq,Generic)++instance NFData IndexCacheEntry where+    rnf (CachePackageId pkgid _ _) = rnf pkgid+    rnf (CachePreference dep _ _) = rnf dep+    rnf (CacheBuildTreeRef _ _) = ()++cacheEntryTimestamp :: IndexCacheEntry -> Timestamp+cacheEntryTimestamp (CacheBuildTreeRef _ _)  = nullTimestamp+cacheEntryTimestamp (CachePreference _ _ ts) = ts+cacheEntryTimestamp (CachePackageId _ _ ts)  = ts++----------------------------------------------------------------------------+-- new binary 01-index.cache format++instance Binary Cache where+    put (Cache headTs ents) = do+        -- magic / format version+        --+        -- NB: this currently encodes word-size implicitly; when we+        -- switch to CBOR encoding, we will have a platform+        -- independent binary encoding+        put (0xcaba1002::Word)+        put headTs+        put ents++    get = do+        magic <- get+        when (magic /= (0xcaba1002::Word)) $+            fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic)+        Cache <$> get <*> get++instance Binary IndexCacheEntry++----------------------------------------------------------------------------+-- legacy 00-index.cache format++packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String+packageKey = "pkg:" blocknoKey = "b#" buildTreeRefKey     = "build-tree-ref:" preferredVersionKey = "pref-ver:" -readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry-readIndexCacheEntry = \line ->+-- legacy 00-index.cache format+read00IndexCache :: BSS.ByteString -> Cache+read00IndexCache bs = Cache+  { cacheHeadTs  = nullTimestamp+  , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs+  }++read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry+read00IndexCacheEntry = \line ->   case BSS.words line of     [key, pkgnamestr, pkgverstr, sep, blocknostr]-      | key == BSS.pack installedUnitId && sep == BSS.pack blocknoKey ->+      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->       case (parseName pkgnamestr, parseVer pkgverstr [],             parseBlockNo blocknostr) of         (Just pkgname, Just pkgver, Just blockno)-          -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)+          -> Just (CachePackageId (PackageIdentifier pkgname pkgver)+                                  blockno nullTimestamp)         _ -> Nothing     [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->       case (parseRefType typecodestr, parseBlockNo blocknostr) of@@ -576,13 +867,15 @@           -> Just (CacheBuildTreeRef refType blockno)         _ -> Nothing -    (key: remainder) | key == BSS.pack preferredVersionKey ->-      fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))+    (key: remainder) | key == BSS.pack preferredVersionKey -> do+      pref <- simpleParse (BSS.unpack (BSS.unwords remainder))+      return $ CachePreference pref 0 nullTimestamp+     _  -> Nothing   where     parseName str       | BSS.all (\c -> isAlphaNum c || c == '-') str-                  = Just (PackageName (BSS.unpack str))+                  = Just (mkPackageName (BSS.unpack str))       | otherwise = Nothing      parseVer str vs =@@ -591,7 +884,7 @@         Just (v, str') -> case BSS.uncons str' of           Just ('.', str'') -> parseVer str'' (v:vs)           Just _            -> Nothing-          Nothing           -> Just (Version (reverse (v:vs)) [])+          Nothing           -> Just (mkVersion (reverse (v:vs)))      parseBlockNo str =       case BSS.readInt str of@@ -606,31 +899,22 @@             -> Just (refTypeFromTypeCode typeCode)         _   -> Nothing -showIndexCacheEntry :: IndexCacheEntry -> String-showIndexCacheEntry entry = unwords $ case entry of-   CachePackageId pkgid b -> [ installedUnitId-                             , display (packageName pkgid)-                             , display (packageVersion pkgid)-                             , blocknoKey-                             , show b-                             ]-   CacheBuildTreeRef t b  -> [ buildTreeRefKey-                             , [typeCodeFromRefType t]-                             , show b-                             ]-   CachePreference dep    -> [ preferredVersionKey-                             , display dep-                             ]---- | Cabal caches various information about the Hackage index-data Cache = Cache {-    cacheEntries :: [IndexCacheEntry]-  }--readIndexCache :: BSS.ByteString -> Cache-readIndexCache bs = Cache {-    cacheEntries = mapMaybe readIndexCacheEntry $ BSS.lines bs-  }+-- legacy 00-index.cache format+show00IndexCache :: Cache -> String+show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries -showIndexCache :: Cache -> String-showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries+show00IndexCacheEntry :: IndexCacheEntry -> String+show00IndexCacheEntry entry = unwords $ case entry of+   CachePackageId pkgid b _ -> [ packageKey+                               , display (packageName pkgid)+                               , display (packageVersion pkgid)+                               , blocknoKey+                               , show b+                               ]+   CacheBuildTreeRef tr b   -> [ buildTreeRefKey+                               , [typeCodeFromRefType tr]+                               , show b+                               ]+   CachePreference dep _ _  -> [ preferredVersionKey+                               , display dep+                               ]
+ cabal/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils.Timestamp+-- Copyright   :  (c) 2016 Herbert Valerio Riedel+-- License     :  BSD3+--+-- Timestamp type used in package indexes++module Distribution.Client.IndexUtils.Timestamp+    ( Timestamp+    , nullTimestamp+    , epochTimeToTimestamp+    , timestampToUTCTime+    , utcTimeToTimestamp+    , maximumTimestamp++    , IndexState(..)+    ) where++import qualified Codec.Archive.Tar.Entry    as Tar+import           Control.DeepSeq+import           Control.Monad+import           Data.Char                  (isDigit)+import           Data.Int                   (Int64)+import           Data.Time                  (UTCTime (..), fromGregorianValid,+                                             makeTimeOfDayValid, showGregorian,+                                             timeOfDayToTime, timeToTimeOfDay)+import           Data.Time.Clock.POSIX      (posixSecondsToUTCTime,+                                             utcTimeToPOSIXSeconds)+import           Distribution.Compat.Binary+import qualified Distribution.Compat.ReadP  as ReadP+import           Distribution.Text+import qualified Text.PrettyPrint           as Disp+import           GHC.Generics (Generic)++-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).+newtype Timestamp = TS Int64 -- Tar.EpochTime+                  deriving (Eq,Ord,Enum,NFData,Show)++epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp+epochTimeToTimestamp et+  | ts == nullTimestamp  = Nothing+  | otherwise            = Just ts+  where+    ts = TS et++timestampToUTCTime :: Timestamp -> Maybe UTCTime+timestampToUTCTime (TS t)+  | t == minBound  = Nothing+  | otherwise      = Just $ posixSecondsToUTCTime (fromIntegral t)++utcTimeToTimestamp :: UTCTime -> Maybe Timestamp+utcTimeToTimestamp utct+  | minTime <= t, t <= maxTime  = Just (TS (fromIntegral t))+  | otherwise                   = Nothing+  where+    maxTime = toInteger (maxBound :: Int64)+    minTime = toInteger (succ minBound :: Int64)+    t :: Integer+    t = round . utcTimeToPOSIXSeconds $ utct++-- | Compute the maximum 'Timestamp' value+--+-- Returns 'nullTimestamp' for the empty list.  Also note that+-- 'nullTimestamp' compares as smaller to all non-'nullTimestamp'+-- values.+maximumTimestamp :: [Timestamp] -> Timestamp+maximumTimestamp [] = nullTimestamp+maximumTimestamp xs@(_:_) = maximum xs++-- returns 'Nothing' if not representable as 'Timestamp'+posixSecondsToTimestamp :: Integer -> Maybe Timestamp+posixSecondsToTimestamp pt+  | minTs <= pt, pt <= maxTs  = Just (TS (fromInteger pt))+  | otherwise                 = Nothing+  where+    maxTs = toInteger (maxBound :: Int64)+    minTs = toInteger (succ minBound :: Int64)++-- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format+-- (e.g. @"2017-12-31T23:59:59Z"@)+--+-- Returns empty string for 'nullTimestamp' in order for+--+-- > null (display nullTimestamp) == True+--+-- to hold.+showTimestamp :: Timestamp -> String+showTimestamp ts = case timestampToUTCTime ts of+    Nothing          -> ""+    -- Note: we don't use 'formatTime' here to avoid incurring a+    -- dependency on 'old-locale' for older `time` libs+    Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z"+  where+    showTOD = show . timeToTimeOfDay++instance Binary Timestamp where+    put (TS t) = put t+    get = TS `fmap` get++instance Text Timestamp where+    disp = Disp.text . showTimestamp++    parse = parsePosix ReadP.+++ parseUTC+      where+        -- | Parses unix timestamps, e.g. @"\@1474626019"@+        parsePosix = do+            _ <- ReadP.char '@'+            t <- parseInteger+            maybe ReadP.pfail return $ posixSecondsToTimestamp t++        -- | Parses ISO8601/RFC3339-style UTC timestamps,+        -- e.g. @"2017-12-31T23:59:59Z"@+        --+        -- TODO: support numeric tz offsets; allow to leave off seconds+        parseUTC = do+            -- Note: we don't use 'Data.Time.Format.parseTime' here since+            -- we want more control over the accepted formats.++            ye <- parseYear+            _ <- ReadP.char '-'+            mo   <- parseTwoDigits+            _ <- ReadP.char '-'+            da   <- parseTwoDigits+            _ <- ReadP.char 'T'++            utctDay <- maybe ReadP.pfail return $+                       fromGregorianValid ye mo da++            ho   <- parseTwoDigits+            _ <- ReadP.char ':'+            mi   <- parseTwoDigits+            _ <- ReadP.char ':'+            se   <- parseTwoDigits+            _ <- ReadP.char 'Z'++            utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $+                           makeTimeOfDayValid ho mi (realToFrac (se::Int))++            maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..})++        parseTwoDigits = do+            d1 <- ReadP.satisfy isDigit+            d2 <- ReadP.satisfy isDigit+            return (read [d1,d2])++        -- A year must have at least 4 digits; e.g. "0097" is fine,+        -- while "97" is not c.f. RFC3339 which+        -- deprecates 2-digit years+        parseYear = do+            sign <- ReadP.option ' ' (ReadP.char '-')+            ds <- ReadP.munch1 isDigit+            when (length ds < 4) ReadP.pfail+            return (read (sign:ds))++        parseInteger = do+            sign <- ReadP.option ' ' (ReadP.char '-')+            ds <- ReadP.munch1 isDigit+            return (read (sign:ds) :: Integer)++-- | Special timestamp value to be used when 'timestamp' is+-- missing/unknown/invalid+nullTimestamp :: Timestamp+nullTimestamp = TS minBound++----------------------------------------------------------------------------+-- defined here for now to avoid import cycles++-- | Specification of the state of a specific repo package index+data IndexState = IndexStateHead -- ^ Use all available entries+                | IndexStateTime !Timestamp -- ^ Use all entries that existed at+                                            -- the specified time+                deriving (Eq,Generic,Show)++instance Binary IndexState+instance NFData IndexState++instance Text IndexState where+    disp IndexStateHead = Disp.text "HEAD"+    disp (IndexStateTime ts) = disp ts++    parse = parseHead ReadP.+++ parseTime+      where+        parseHead = do+            _ <- ReadP.string "HEAD"+            return IndexStateHead++        parseTime = IndexStateTime `fmap` parse
cabal/cabal-install/Distribution/Client/Init.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init@@ -23,42 +22,34 @@    ) where +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)+ import System.IO   ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory   ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile   , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath-  ( (</>), (<.>), takeBaseName )+  ( (</>), (<.>), takeBaseName, equalFilePath ) import Data.Time   ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) -import Data.Char-  ( toUpper ) import Data.List-  ( intercalate, nub, groupBy, (\\) )-import Data.Maybe-  ( fromMaybe, isJust, catMaybes, listToMaybe )+  ( groupBy, (\\) ) import Data.Function   ( on ) import qualified Data.Map as M-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-  ( (<$>) )-import Data.Traversable-  ( traverse )-#endif import Control.Monad-  ( when, unless, (>=>), join, forM_ )+  ( (>=>), join, forM_, mapM, mapM_ ) import Control.Arrow   ( (&&&), (***) )  import Text.PrettyPrint hiding (mode, cat) -import Data.Version-  ( Version(..) ) import Distribution.Version-  ( orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )+  ( Version, mkVersion, alterVersion+  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity   ( Verbosity ) import Distribution.ModuleName@@ -89,14 +80,15 @@ import Distribution.Simple.Compiler   ( PackageDBStack, Compiler ) import Distribution.Simple.Program-  ( ProgramConfiguration )+  ( ProgramDb ) import Distribution.Simple.PackageIndex   ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Text   ( display, Text(..) ) -import Distribution.Client.PackageIndex+import Distribution.Solver.Types.PackageIndex   ( elemByPackageName )+ import Distribution.Client.IndexUtils   ( getSourcePackages ) import Distribution.Client.Types@@ -108,12 +100,12 @@           -> PackageDBStack           -> RepoContext           -> Compiler-          -> ProgramConfiguration+          -> ProgramDb           -> InitFlags           -> IO ()-initCabal verbosity packageDBs repoCtxt comp conf initFlags = do+initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do -  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb   sourcePkgDb <- getSourcePackages verbosity repoCtxt    hSetBuffering stdout NoBuffering@@ -202,7 +194,7 @@ --  if possible. getVersion :: InitFlags -> IO InitFlags getVersion flags = do-  let v = Just $ Version [0,1,0,0] []+  let v = Just $ mkVersion [0,1,0,0]   v' <-     return (flagToMaybe $ version flags)         ?>> maybePrompt flags (prompt "Package version" v)         ?>> return v@@ -380,14 +372,21 @@              then Just "src"              else Nothing +-- | Check whether a potential source file is located in one of the+--   source directories.+isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool+isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf+isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs+ -- | Get the list of exposed modules and extra tools needed to build them. getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags getModulesBuildToolsAndDeps pkgIx flags = do   dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags -  -- TODO: really should use guessed source roots.-  sourceFiles <- scanForModules dir+  sourceFiles0 <- scanForModules dir +  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0+   Just mods <-      return (exposedModules flags)            ?>> (return . Just . map moduleName $ sourceFiles) @@ -477,11 +476,11 @@ pvpize v = orLaterVersion v'            `intersectVersionRanges`            earlierVersion (incVersion 1 v')-  where v' = (v { versionBranch = take 2 (versionBranch v) })+  where v' = alterVersion (take 2) v  -- | Increment the nth version component (counting from 0). incVersion :: Int -> Version -> Version-incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags+incVersion n = alterVersion (incVersion' n)   where     incVersion' 0 []     = [1]     incVersion' 0 (v:_)  = [v+1]@@ -603,11 +602,6 @@                                   = return . Right $ choices !! (n-1)                    | otherwise    = Left `fmap` promptStr "Please specify" Nothing -readMaybe :: (Read a) => String -> Maybe a-readMaybe s = case reads s of-                [(a,"")] -> Just a-                _        -> Nothing- --------------------------------------------------------------------------- --  File generation  ------------------------------------------------------ ---------------------------------------------------------------------------@@ -625,28 +619,28 @@           Flag BSD3             -> Just $ bsd3 authors year -          Flag (GPL (Just (Version {versionBranch = [2]})))+          Flag (GPL (Just v)) | v == mkVersion [2]             -> Just gplv2 -          Flag (GPL (Just (Version {versionBranch = [3]})))+          Flag (GPL (Just v)) | v == mkVersion [2]             -> Just gplv3 -          Flag (LGPL (Just (Version {versionBranch = [2, 1]})))+          Flag (LGPL (Just v)) | v == mkVersion [2,1]             -> Just lgpl21 -          Flag (LGPL (Just (Version {versionBranch = [3]})))+          Flag (LGPL (Just v)) | v == mkVersion [3]             -> Just lgpl3 -          Flag (AGPL (Just (Version {versionBranch = [3]})))+          Flag (AGPL (Just v)) | v == mkVersion [3]             -> Just agplv3 -          Flag (Apache (Just (Version {versionBranch = [2, 0]})))+          Flag (Apache (Just v)) | v == mkVersion [2,0]             -> Just apache20            Flag MIT             -> Just $ mit authors year -          Flag (MPL (Version {versionBranch = [2, 0]}))+          Flag (MPL v) | v == mkVersion [2,0]             -> Just mpl20            Flag ISC@@ -850,7 +844,7 @@                 (Just "Extra files to be distributed with the package, such as examples or a README.")                 True -       , field  "cabal-version" (Flag $ orLaterVersion (Version [1,10] []))+       , field  "cabal-version" (Flag $ orLaterVersion (mkVersion [1,10]))                 (Just "Constraint on the version of Cabal needed to build this package.")                 False @@ -924,9 +918,9 @@                         (True, _, _)      -> (showComment com $$) . ($$ text "")                         (False, _, _)     -> ($$ text "")                       $-                      comment f <> text s <> colon-                                <> text (replicate (20 - length s) ' ')-                                <> text (fromMaybe "" . flagToMaybe $ f)+                      comment f <<>> text s <<>> colon+                                <<>> text (replicate (20 - length s) ' ')+                                <<>> text (fromMaybe "" . flagToMaybe $ f)    comment NoFlag    = text "-- "    comment (Flag "") = text "-- "    comment _         = text ""
cabal/cabal-install/Distribution/Client/Init/Heuristics.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Heuristics@@ -20,32 +19,31 @@     guessAuthorNameMail,     knownCategories, ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Text         (simpleParse) import Distribution.Simple.Setup (Flag(..), flagToMaybe) import Distribution.ModuleName     ( ModuleName, toFilePath )-import Distribution.Client.PackageIndex-    ( allPackagesByName ) import qualified Distribution.Package as P import qualified Distribution.PackageDescription as PD     ( category, packageDescription )-import Distribution.Simple.Utils-         ( intercalate ) import Distribution.Client.Utils          ( tryCanonicalizePath ) import Language.Haskell.Extension ( Extension ) -import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ( pure, (<$>), (<*>) )-import Data.Monoid         ( mempty, mappend, mconcat )-#endif-import Control.Arrow ( first )-import Control.Monad ( liftM )-import Data.Char   ( isAlphaNum, isNumber, isUpper, isLower, isSpace )+import Distribution.Solver.Types.PackageIndex+    ( allPackagesByName )+import Distribution.Solver.Types.SourcePackage+    ( packageDescription )++import Distribution.Client.Types ( SourcePackageDb(..) )+import Control.Monad ( mapM )+import Data.Char   ( isNumber, isLower ) import Data.Either ( partitionEithers )-import Data.List   ( isInfixOf, isPrefixOf, isSuffixOf, sortBy )-import Data.Maybe  ( mapMaybe, catMaybes, maybeToList )+import Data.List   ( isInfixOf ) import Data.Ord    ( comparing ) import qualified Data.Set as Set ( fromList, toList ) import System.Directory ( getCurrentDirectory, getDirectoryContents,@@ -88,7 +86,7 @@  -- | Guess the package name based on the given root directory. guessPackageName :: FilePath -> IO P.PackageName-guessPackageName = liftM (P.PackageName . repair . last . splitDirectories)+guessPackageName = liftM (P.mkPackageName . repair . last . splitDirectories)                  . tryCanonicalizePath   where     -- Treat each span of non-alphanumeric characters as a hyphen. Each@@ -251,7 +249,11 @@ -- Ordered in increasing preference, since Flag-as-monoid is identical to -- Last. authorGuessPure :: AuthorGuessIO -> AuthorGuess-authorGuessPure (AuthorGuessIO env darcsLocalF darcsGlobalF gitLocal gitGlobal)+authorGuessPure (AuthorGuessIO { authorGuessEnv = env+                               , authorGuessLocalDarcs = darcsLocalF+                               , authorGuessGlobalDarcs = darcsGlobalF+                               , authorGuessLocalGit = gitLocal+                               , authorGuessGlobalGit = gitGlobal })     = mconcat         [ emailEnv env         , gitGlobal@@ -275,12 +277,13 @@ type AuthorGuess   = (Flag String, Flag String) type Enviro        = [(String, String)] data GitLoc        = Local | Global-data AuthorGuessIO = AuthorGuessIO-    Enviro         -- ^ Environment lookup table-    (Maybe String) -- ^ Contents of local darcs author info-    (Maybe String) -- ^ Contents of global darcs author info-    AuthorGuess    -- ^ Git config --local-    AuthorGuess    -- ^ Git config --global+data AuthorGuessIO = AuthorGuessIO {+    authorGuessEnv         :: Enviro,         -- ^ Environment lookup table+    authorGuessLocalDarcs  :: (Maybe String), -- ^ Contents of local darcs author info+    authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info+    authorGuessLocalGit    :: AuthorGuess,   -- ^ Git config --local+    authorGuessGlobalGit   :: AuthorGuess    -- ^ Git config --global+  }  darcsEnv :: Enviro -> AuthorGuess darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"
cabal/cabal-install/Distribution/Client/Init/Types.hs view
@@ -82,7 +82,7 @@  instance Text PackageType where   disp = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] -- TODO: eradicateNoParse  instance Monoid InitFlags where   mempty = gmempty@@ -114,5 +114,5 @@  instance Text Category where   disp  = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ]+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -- TODO: eradicateNoParse
cabal/cabal-install/Distribution/Client/Install.hs view
@@ -29,14 +29,13 @@     pruneInstallPlan   ) where -import Data.Foldable-         ( traverse_ )+import Prelude ()+import Distribution.Client.Compat.Prelude+ import Data.List-         ( isPrefixOf, unfoldr, nub, sort, (\\) )+         ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as S-import Data.Maybe-         ( catMaybes, isJust, isNothing, fromMaybe, mapMaybe ) import Control.Exception as Exception          ( Exception(toException), bracket, catches          , Handler(Handler), handleJust, IOException, SomeException )@@ -48,17 +47,13 @@          ( ExitCode(..) ) import Distribution.Compat.Exception          ( catchIO, catchExit )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-         ( (<$>) )-import Data.Traversable-         ( traverse )-#endif+import Control.Exception ( assert ) import Control.Monad-         ( filterM, forM_, when, unless )+         ( forM_, mapM ) import System.Directory          ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,-           createDirectoryIfMissing, removeFile, renameDirectory )+           createDirectoryIfMissing, removeFile, renameDirectory,+           getDirectoryContents ) import System.FilePath          ( (</>), (<.>), equalFilePath, takeDirectory ) import System.IO@@ -71,15 +66,18 @@          ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types-         ( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) )+         ( Solver(..) ) import Distribution.Client.FetchUtils import Distribution.Client.HttpUtils          ( HttpTransport (..) )+import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils-         ( getSourcePackages, getInstalledPackages )+         ( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import Distribution.Client.Setup          ( GlobalFlags(..), RepoContext(..)          , ConfigFlags(..), configureCommand, filterConfigureFlags@@ -102,29 +100,33 @@          ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) import qualified Distribution.Client.InstallSymlink as InstallSymlink          ( symlinkBinaries )-import qualified Distribution.Client.PackageIndex as SourcePackageIndex import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl-import qualified Distribution.Client.ComponentDeps as CD +import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex+import           Distribution.Solver.Types.PkgConfigDb+                   ( PkgConfigDb, readPkgConfigDb )+import           Distribution.Solver.Types.SourcePackage as SourcePackage+ import Distribution.Utils.NubList import Distribution.Simple.Compiler          ( CompilerId(..), Compiler(compilerId), compilerFlavor          , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration,-                                    defaultProgramConfiguration)+import Distribution.Simple.Program (ProgramDb) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.Simple.LocalBuildInfo (ComponentName(CLibName))-import qualified Distribution.Simple.Configure as Configure import Distribution.Simple.Setup          ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags-         , AllowNewer(..)+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal          ( Flag(..)@@ -132,41 +134,41 @@          , registerCommand, RegisterFlags(..), emptyRegisterFlags          , testCommand, TestFlags(..), emptyTestFlags ) import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, rawSystemExit, comparing-         , writeFileAtomic, withTempFile , withUTF8FileContents )+         ( createDirectoryIfMissingVerbose, comparing+         , writeFileAtomic, withUTF8FileContents ) import Distribution.Simple.InstallDirs as InstallDirs          ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate          , initialPathTemplateEnv, installDirsTemplateEnv )+import Distribution.Simple.Configure (interpretPackageDbFlags)+import Distribution.Simple.Register (registerPackage)+import Distribution.Simple.Program.HcPkg (MultiInstance(..)) import Distribution.Package          ( PackageIdentifier(..), PackageId, packageName, packageVersion-         , Package(..)+         , Package(..), HasUnitId(..)          , Dependency(..), thisPackageVersion-         , UnitId(..), mkUnitId-         , HasUnitId(..) )+         , UnitId ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription          ( PackageDescription, GenericPackageDescription(..), Flag(..)-         , FlagName(..), FlagAssignment )+         , unFlagName, FlagAssignment ) import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Client.PkgConfigDb-         ( PkgConfigDb, readPkgConfigDb )+         ( finalizePD ) import Distribution.ParseUtils          ( showPWarning ) import Distribution.Version          ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils          ( notice, info, warn, debug, debugNoWrap, die-         , intercalate, withTempDirectory )+         , withTempDirectory ) import Distribution.Client.Utils-         ( determineNumJobs, inDir, logDirChange, mergeBy, MergeResult(..)+         ( determineNumJobs, logDirChange, mergeBy, MergeResult(..)          , tryCanonicalizePath ) import Distribution.System          ( Platform, OS(Windows), buildOS ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-         ( Verbosity, showForCabal, normal, verbose )+         ( Verbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension )  --TODO:@@ -193,7 +195,7 @@   -> RepoContext   -> Compiler   -> Platform-  -> ProgramConfiguration+  -> ProgramDb   -> UseSandbox   -> Maybe SandboxPackageInfo   -> GlobalFlags@@ -203,10 +205,18 @@   -> HaddockFlags   -> [UserTarget]   -> IO ()-install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo+install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo   globalFlags configFlags configExFlags installFlags haddockFlags   userTargets0 = do +    unless (installRootCmd installFlags == Cabal.NoFlag) $+        die $ "--root-cmd is no longer supported, "+        ++ "see https://github.com/haskell/cabal/issues/3353"+    unless (fromFlag (configUserInstall configFlags)) $+        warn verbosity $ "the --global flag is deprecated -- "+        ++ "it is generally considered a bad idea to install packages "+        ++ "into the global store"+     installContext <- makeInstallContext verbosity args (Just userTargets0)     planResult     <- foldProgress logMsg (return . Left) (return . Right) =<<                       makeInstallPlan verbosity args installContext@@ -219,9 +229,9 @@             processInstallPlan verbosity args installContext installPlan   where     args :: InstallArgs-    args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,-            globalFlags, configFlags, configExFlags, installFlags,-            haddockFlags)+    args = (packageDBs, repos, comp, platform, progdb, useSandbox,+            mSandboxPkgInfo, globalFlags, configFlags, configExFlags,+            installFlags, haddockFlags)      die' message = die (message ++ if isUseSandbox useSandbox                                    then installFailedInSandbox else [])@@ -247,7 +257,7 @@                    , RepoContext                    , Compiler                    , Platform-                   , ProgramConfiguration+                   , ProgramDb                    , UseSandbox                    , Maybe SandboxPackageInfo                    , GlobalFlags@@ -260,13 +270,16 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]                       -> IO InstallContext makeInstallContext verbosity-  (packageDBs, repoCtxt, comp, _, conf,_,_,-   globalFlags, _, configExFlags, _, _) mUserTargets = do+  (packageDBs, repoCtxt, comp, _, progdb,_,_,+   globalFlags, _, configExFlags, installFlags, _) mUserTargets = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity conf+    let idxState = fromFlagOrDefault IndexStateHead $+                       installIndexState installFlags +    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+    sourcePkgDb       <- getSourcePackagesAtIndexState verbosity repoCtxt idxState+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb+     checkConfigExFlags verbosity installedPkgIndex                        (packageIndex sourcePkgDb) configExFlags     transport <- repoContextGetTransport repoCtxt@@ -294,7 +307,7 @@  -- | Make an install plan given install context and install arguments. makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext-                -> IO (Progress String String InstallPlan)+                -> IO (Progress String String SolverInstallPlan) makeInstallPlan verbosity   (_, _, comp, platform, _, _, mSandboxPkgInfo,    _, configFlags, configExFlags, installFlags,@@ -306,27 +319,29 @@               (compilerInfo comp)     notice verbosity "Resolving dependencies..."     return $ planPackages comp platform mSandboxPkgInfo solver-      configFlags configExFlags installFlags-      installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers+          configFlags configExFlags installFlags+          installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers  -- | Given an install plan, perform the actual installations. processInstallPlan :: Verbosity -> InstallArgs -> InstallContext-                   -> InstallPlan+                   -> SolverInstallPlan                    -> IO () processInstallPlan verbosity   args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)   (installedPkgIndex, sourcePkgDb, _,-   userTargets, pkgSpecifiers, _) installPlan = do+   userTargets, pkgSpecifiers, _) installPlan0 = do+     checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb       installFlags pkgSpecifiers      unless (dryRun || nothingToInstall) $ do-      installPlan' <- performInstallations verbosity-                      args installedPkgIndex installPlan-      postInstallActions verbosity args userTargets installPlan'+      buildOutcomes <- performInstallations verbosity+                         args installedPkgIndex installPlan+      postInstallActions verbosity args userTargets installPlan buildOutcomes   where+    installPlan = InstallPlan.configureInstallPlan installPlan0     dryRun = fromFlag (installDryRun installFlags)-    nothingToInstall = null (InstallPlan.ready installPlan)+    nothingToInstall = null (fst (InstallPlan.ready installPlan))  -- ------------------------------------------------------------ -- * Installation planning@@ -343,7 +358,7 @@              -> SourcePackageDb              -> PkgConfigDb              -> [PackageSpecifier UnresolvedSourcePackage]-             -> Progress String String InstallPlan+             -> Progress String String SolverInstallPlan planPackages comp platform mSandboxPkgInfo solver              configFlags configExFlags installFlags              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers =@@ -365,6 +380,8 @@        . setReorderGoals reorderGoals +      . setCountConflicts countConflicts+       . setAvoidReinstalls avoidReinstalls        . setShadowPkgs shadowPkgs@@ -374,6 +391,7 @@       . setPreferenceDefault (if upgradeDeps then PreferAllLatest                                              else PreferLatestForSelected) +      . removeLowerBounds allowOlder       . removeUpperBounds allowNewer        . addPreferences@@ -406,6 +424,10 @@        . (if reinstall then reinstallTargets else id) +        -- Don't solve for executables, the legacy install codepath+        -- doesn't understand how to install them+      . setSolveExecutables (SolveExecutables False)+       $ standardInstallPolicy         installedPkgIndex sourcePkgDb pkgSpecifiers @@ -417,6 +439,7 @@     reinstall        = fromFlag (installOverrideReinstall installFlags) ||                        fromFlag (installReinstall         installFlags)     reorderGoals     = fromFlag (installReorderGoals      installFlags)+    countConflicts   = fromFlag (installCountConflicts    installFlags)     independentGoals = fromFlag (installIndependentGoals  installFlags)     avoidReinstalls  = fromFlag (installAvoidReinstalls   installFlags)     shadowPkgs       = fromFlag (installShadowPkgs        installFlags)@@ -424,21 +447,24 @@     maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)     upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)     onlyDeps         = fromFlag (installOnlyDeps          installFlags)-    allowNewer       = fromMaybe AllowNewerNone (configAllowNewer configFlags)+    allowOlder       = fromMaybe (AllowOlder RelaxDepsNone)+                                 (configAllowOlder configFlags)+    allowNewer       = fromMaybe (AllowNewer RelaxDepsNone)+                                 (configAllowNewer configFlags)  -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package targetpkg                  => [PackageSpecifier targetpkg]-                 -> InstallPlan-                 -> Progress String String InstallPlan+                 -> SolverInstallPlan+                 -> Progress String String SolverInstallPlan pruneInstallPlan pkgSpecifiers =   -- TODO: this is a general feature and should be moved to D.C.Dependency   -- Also, the InstallPlan.remove should return info more precise to the   -- problem, rather than the very general PlanProblem type.   either (Fail . explain) Done-  . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)+  . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)   where-    explain :: [InstallPlan.PlanProblem ipkg srcpkg iresult ifailure] -> String+    explain :: [SolverInstallPlan.SolverPlanProblem] -> String     explain problems =       "Cannot select only the dependencies (as requested by the "       ++ "'--only-dependencies' flag), "@@ -450,7 +476,7 @@       where         pkgids =           nub [ depid-              | InstallPlan.PackageMissingDeps _ depids <- problems+              | SolverInstallPlan.PackageMissingDeps _ depids <- problems               , depid <- depids               , packageName depid `elem` targetnames ] @@ -486,9 +512,15 @@        : map (display . packageId) preExistingTargets       ++ ["Use --reinstall if you want to reinstall anyway."] -  let lPlan = linearizeInstallPlan installed installPlan+  let lPlan =+        [ (pkg, status)+        | pkg <- InstallPlan.executionOrder installPlan+        , let status = packageStatus installed pkg ]   -- Are any packages classified as reinstalls?-  let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan+  let reinstalledPkgs =+        [ ipkg+        | (_pkg, status) <- lPlan+        , ipkg <- extractReinstalls status ]   -- Packages that are already broken.   let oldBrokenPkgs =           map Installed.installedUnitId@@ -549,44 +581,11 @@       ++ "\nTry using 'cabal fetch'."    where-    nothingToInstall = null (InstallPlan.ready installPlan)+    nothingToInstall = null (fst (InstallPlan.ready installPlan))      dryRun            = fromFlag (installDryRun            installFlags)     overrideReinstall = fromFlag (installOverrideReinstall installFlags) --- | Given an 'InstallPlan', perform a dry run, producing the sequence--- of 'ReadyPackage's which would be compiled in order to carry--- out this plan.  This function is not actually used to execute a plan;--- presently, it is used only to (1) determine if the installation--- plan would cause reinstalls and (2) to print out what would be--- installed.------ TODO: this type is too specific-linearizeInstallPlan :: InstalledPackageIndex-                     -> InstallPlan-                     -> [(ReadyPackage, PackageStatus)]-linearizeInstallPlan installedPkgIndex plan =-    unfoldr next plan-  where-    next plan' = case InstallPlan.ready plan' of-      []      -> Nothing-      (pkg:_) -> Just ((pkg, status), plan'')-        where-          pkgid  = installedUnitId pkg-          status = packageStatus installedPkgIndex pkg-          ipkg   = Installed.emptyInstalledPackageInfo {-                     Installed.sourcePackageId = packageId pkg,-                     Installed.installedUnitId = pkgid-                   }-          plan'' = InstallPlan.completed pkgid (Just ipkg)-                     (BuildOk DocsNotTried TestsNotTried (Just ipkg))-                     (InstallPlan.processing [pkg] plan')-          --FIXME: This is a bit of a hack,-          -- pretending that each package is installed-          -- It's doubly a hack because the installed package ID-          -- didn't get updated.  But it doesn't really matter-          -- because we're not going to use this for anything real.- data PackageStatus = NewPackage                    | NewVersion [Version]                    | Reinstall  [UnitId] [PackageChange]@@ -615,7 +614,7 @@     changes :: Installed.InstalledPackageInfo             -> ReadyPackage             -> [MergeResult PackageIdentifier PackageIdentifier]-    changes pkg pkg' = filter changed $+    changes pkg (ReadyPackage pkg') = filter changed $       mergeBy (comparing packageName)         -- deps of installed pkg         (resolveInstalledIds $ Installed.depends pkg)@@ -691,7 +690,8 @@     nonDefaultFlags cpkg =       let defaultAssignment =             toFlagAssignment-             (genPackageFlags (Source.packageDescription (confPkgSource cpkg)))+             (genPackageFlags (SourcePackage.packageDescription $+                               confPkgSource cpkg))       in  confPkgFlags cpkg \\ defaultAssignment      showStanzas :: [OptionalStanza] -> String@@ -703,7 +703,7 @@     showFlagAssignment = concatMap ((' ' :) . showFlagValue)     showFlagValue (f, True)   = '+' : showFlagName f     showFlagValue (f, False)  = '-' : showFlagName f-    showFlagName (FlagName f) = f+    showFlagName = unFlagName      change (OnlyInLeft pkgid)        = display pkgid ++ " removed"     change (InBoth     pkgid pkgid') = display pkgid ++ " -> "@@ -808,11 +808,12 @@                    -> InstallArgs                    -> [UserTarget]                    -> InstallPlan+                   -> BuildOutcomes                    -> IO () postInstallActions verbosity-  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo+  (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo   ,globalFlags, configFlags, _, installFlags, _)-  targets installPlan = do+  targets installPlan buildOutcomes = do    unless oneShot $     World.insert verbosity worldFile@@ -821,7 +822,7 @@       | UserTargetNamed dep <- targets ]    let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)-                                                  installPlan+                                                  installPlan buildOutcomes   BuildReports.storeLocal (compilerInfo comp)                           (fromNubList $ installSummaryFile installFlags)                           buildReports@@ -831,15 +832,16 @@   when (reportingLevel == DetailedReports) $     storeDetailedBuildReports verbosity logsDir buildReports -  regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox-                         configFlags installFlags installPlan+  regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox+                         configFlags installFlags buildOutcomes -  symlinkBinaries verbosity platform comp configFlags installFlags installPlan+  symlinkBinaries verbosity platform comp configFlags installFlags+                  installPlan buildOutcomes -  printBuildFailures installPlan+  printBuildFailures buildOutcomes    updateSandboxTimestampsFile useSandbox mSandboxPkgInfo-                              comp platform installPlan+                              comp platform installPlan buildOutcomes    where     reportingLevel = fromFlag (installBuildReports installFlags)@@ -885,14 +887,14 @@                        -> [PackageDB]                        -> Compiler                        -> Platform-                       -> ProgramConfiguration+                       -> ProgramDb                        -> UseSandbox                        -> ConfigFlags                        -> InstallFlags-                       -> InstallPlan+                       -> BuildOutcomes                        -> IO ()-regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox-                       configFlags installFlags installPlan+regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox+                       configFlags installFlags buildOutcomes   | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do    defaultDirs <- InstallDirs.defaultInstallDirs@@ -906,8 +908,8 @@      "Updating documentation index " ++ indexFile    --TODO: might be nice if the install plan gave us the new InstalledPackageInfo-  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+  Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile    | otherwise = return ()   where@@ -920,14 +922,14 @@     -- #1337), we don't do it for global installs or special cases where we're     -- installing into a specific db.     shouldRegenerateHaddockIndex = (isUseSandbox useSandbox || normalUserInstall)-                                && someDocsWereInstalled installPlan+                                && someDocsWereInstalled buildOutcomes       where-        someDocsWereInstalled = any installedDocs . InstallPlan.toList+        someDocsWereInstalled = any installedDocs . Map.elems+        installedDocs (Right (BuildResult DocsOk _ _)) = True+        installedDocs _                                = False+         normalUserInstall     = (UserPackageDB `elem` packageDBs)                              && all (not . isSpecificPackageDB) packageDBs--        installedDocs (InstallPlan.Installed _ _ (BuildOk DocsOk _ _)) = True-        installedDocs _                                                = False         isSpecificPackageDB (SpecificPackageDB _) = True         isSpecificPackageDB _                     = False @@ -949,24 +951,26 @@                 -> ConfigFlags                 -> InstallFlags                 -> InstallPlan+                -> BuildOutcomes                 -> IO ()-symlinkBinaries verbosity platform comp configFlags installFlags plan = do+symlinkBinaries verbosity platform comp configFlags installFlags+                plan buildOutcomes = do   failed <- InstallSymlink.symlinkBinaries platform comp                                            configFlags installFlags-                                           plan+                                           plan buildOutcomes   case failed of     [] -> return ()     [(_, exe, path)] ->       warn verbosity $            "could not create a symlink in " ++ bindir ++ " for "-        ++ exe ++ " because the file exists there already but is not "+        ++ display exe ++ " because the file exists there already but is not "         ++ "managed by cabal. You can create a symlink for this executable "         ++ "manually if you wish. The executable file has been installed at "         ++ path     exes ->       warn verbosity $            "could not create symlinks in " ++ bindir ++ " for "-        ++ intercalate ", " [ exe | (_, exe, _) <- exes ]+        ++ intercalate ", " [ display exe | (_, exe, _) <- exes ]         ++ " because the files exist there already and are not "         ++ "managed by cabal. You can create symlinks for these executables "         ++ "manually if you wish. The executable files have been installed at "@@ -975,16 +979,15 @@     bindir = fromFlag (installSymlinkBinDir installFlags)  -printBuildFailures :: InstallPlan-                   -> IO ()-printBuildFailures plan =-  case [ (pkg, reason)-       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of+printBuildFailures :: BuildOutcomes -> IO ()+printBuildFailures buildOutcomes =+  case [ (pkgid, failure)+       | (pkgid, Left failure) <- Map.toList buildOutcomes ] of     []     -> return ()     failed -> die . unlines             $ "Error: some packages failed to install:"-            : [ display (packageId pkg) ++ printFailureReason reason-              | (pkg, reason) <- failed ]+            : [ display pkgid ++ printFailureReason reason+              | (pkgid, reason) <- failed ]   where     printFailureReason reason = case reason of       DependentFailed pkgid -> " depends on " ++ display pkgid@@ -1022,28 +1025,32 @@ updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo                             -> Compiler -> Platform                             -> InstallPlan+                            -> BuildOutcomes                             -> IO () updateSandboxTimestampsFile (UseSandbox sandboxDir)                             (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))-                            comp platform installPlan =+                            comp platform installPlan buildOutcomes =   withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do-    let allInstalled = [ pkg | InstallPlan.Installed pkg _ _-                            <- InstallPlan.toList installPlan ]-        allSrcPkgs   = [ confPkgSource cpkg | ReadyPackage cpkg-                            <- allInstalled ]+    let allInstalled = [ pkg+                       | InstallPlan.Configured pkg+                            <- InstallPlan.toList installPlan+                       , case InstallPlan.lookupBuildOutcome pkg buildOutcomes of+                           Just (Right _success) -> True+                           _                     -> False+                       ]+        allSrcPkgs   = [ confPkgSource cpkg | cpkg <- allInstalled ]         allPaths     = [ pth | LocalUnpackedPackage pth                             <- map packageSource allSrcPkgs]     allPathsCanonical <- mapM tryCanonicalizePath allPaths     return $! filter (`S.member` allAddSourceDeps) allPathsCanonical -updateSandboxTimestampsFile _ _ _ _ _ = return ()+updateSandboxTimestampsFile _ _ _ _ _ _ = return ()  -- ------------------------------------------------------------ -- * Actually do the installations -- ------------------------------------------------------------  data InstallMisc = InstallMisc {-    rootCmd    :: Maybe FilePath,     libVersion :: Maybe Version   } @@ -1055,9 +1062,9 @@                      -> InstallArgs                      -> InstalledPackageIndex                      -> InstallPlan-                     -> IO InstallPlan+                     -> IO BuildOutcomes performInstallations verbosity-  (packageDBs, repoCtxt, comp, platform, conf, useSandbox, _,+  (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _,    globalFlags, configFlags, configExFlags, installFlags, haddockFlags)   installedPkgIndex installPlan = do @@ -1066,26 +1073,26 @@     when parallelInstall $       notice verbosity $ "Notice: installing into a sandbox located at "                          ++ sandboxDir+  info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." -  jobControl   <- if parallelInstall then newParallelJobControl+  jobControl   <- if parallelInstall then newParallelJobControl numJobs                                      else newSerialJobControl-  buildLimit   <- newJobLimit numJobs   fetchLimit   <- newJobLimit (min numJobs numFetchJobs)   installLock  <- newLock -- serialise installation   cacheLock    <- newLock -- serialise access to setup exe cache -  executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg ->+  executeInstallPlan verbosity jobControl keepGoing useLogFile+                     installPlan $ \rpkg ->     installReadyPackage platform cinfo configFlags                         rpkg $ \configFlags' src pkg pkgoverride ->       fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->-        installLocalPackage verbosity buildLimit-                            (packageId pkg) src' distPref $ \mpath ->-          installUnpackedPackage verbosity buildLimit installLock numJobs+        installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath ->+          installUnpackedPackage verbosity installLock numJobs                                  (setupScriptOptions installedPkgIndex                                   cacheLock rpkg)-                                 miscOptions configFlags'-                                 installFlags haddockFlags-                                 cinfo platform pkg rpkg pkgoverride mpath useLogFile+                                 configFlags'+                                 installFlags haddockFlags comp progdb+                                 platform pkg rpkg pkgoverride mpath useLogFile    where     cinfo = compilerInfo comp@@ -1093,6 +1100,7 @@     numJobs         = determineNumJobs (installNumJobs installFlags)     numFetchJobs    = 2     parallelInstall = numJobs >= 2+    keepGoing       = fromFlag (installKeepGoing installFlags)     distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)                       (configDistPref configFlags) @@ -1101,7 +1109,7 @@         packageDBs         comp         platform-        conf+        progdb         distPref         (chooseCabalVersion configFlags (libVersion miscOptions))         (Just lock)@@ -1118,7 +1126,8 @@                  logFileTemplate       where         installLogFile' = flagToMaybe $ installLogFile installFlags-        defaultTemplate = toPathTemplate $ logsDir </> "$pkgid" <.> "log"+        defaultTemplate = toPathTemplate $+                            logsDir </> "$compiler" </> "$libname" <.> "log"          -- If the user has specified --remote-build-reporting=detailed, use the         -- default log file location. If the --build-log option is set, use the@@ -1150,82 +1159,38 @@           | otherwise                         = False      substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath-    substLogFileName template pkg ipid = fromPathTemplate+    substLogFileName template pkg uid = fromPathTemplate                                   . substPathTemplate env                                   $ template-      where env = initialPathTemplateEnv (packageId pkg)-                  ipid-                  (compilerInfo comp) platform+      where env = initialPathTemplateEnv (packageId pkg) uid+                    (compilerInfo comp) platform      miscOptions  = InstallMisc {-      rootCmd    = if fromFlag (configUserInstall configFlags)-                      || (isUseSandbox useSandbox)-                     then Nothing      -- ignore --root-cmd if --user-                                       -- or working inside a sandbox.-                     else flagToMaybe (installRootCmd installFlags),       libVersion = flagToMaybe (configCabalVersion configExFlags)     }   executeInstallPlan :: Verbosity-                   -> Compiler-                   -> JobControl IO (PackageId, UnitId, BuildResult)+                   -> JobControl IO (UnitId, BuildOutcome)+                   -> Bool                    -> UseLogFile                    -> InstallPlan-                   -> (ReadyPackage -> IO BuildResult)-                   -> IO InstallPlan-executeInstallPlan verbosity _comp jobCtl useLogFile plan0 installPkg =-    tryNewTasks 0 plan0-  where-    tryNewTasks taskCount plan = do-      case InstallPlan.ready plan of-        [] | taskCount == 0 -> return plan-           | otherwise      -> waitForTasks taskCount plan-        pkgs                -> do-          sequence_-            [ do info verbosity $ "Ready to install " ++ display pkgid-                 spawnJob jobCtl $ do-                   buildResult <- installPkg pkg-                   let ipid = case buildResult of-                                Right (BuildOk _ _ (Just ipi)) ->-                                     Installed.installedUnitId ipi-                                _ -> mkUnitId (display (packageId pkg))-                   return (packageId pkg, ipid, buildResult)-            | pkg <- pkgs-            , let pkgid = packageId pkg ]--          let taskCount' = taskCount + length pkgs-              plan'      = InstallPlan.processing pkgs plan-          waitForTasks taskCount' plan'--    waitForTasks taskCount plan = do-      info verbosity $ "Waiting for install task to finish..."-      (pkgid, ipid, buildResult) <- collectJob jobCtl-      printBuildResult pkgid ipid buildResult-      let taskCount' = taskCount-1-          plan'      = updatePlan pkgid buildResult plan-      tryNewTasks taskCount' plan'--    updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan-               -> InstallPlan-    updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) =-        InstallPlan.completed (Source.fakeUnitId pkgid)-                              mipkg buildSuccess+                   -> (ReadyPackage -> IO BuildOutcome)+                   -> IO BuildOutcomes+executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =+    InstallPlan.execute+      jobCtl keepGoing depsFailure plan0 $ \pkg -> do+        buildOutcome <- installPkg pkg+        printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome+        return buildOutcome -    updatePlan pkgid (Left buildFailure) =-        InstallPlan.failed (Source.fakeUnitId pkgid)-                           buildFailure depsFailure-      where-        depsFailure = DependentFailed pkgid-        -- So this first pkgid failed for whatever reason (buildFailure).-        -- All the other packages that depended on this pkgid, which we-        -- now cannot build, we mark as failing due to 'DependentFailed'-        -- which kind of means it was not their fault.+  where+    depsFailure = DependentFailed . packageId      -- Print build log if something went wrong, and 'Installed $PKGID'     -- otherwise.-    printBuildResult :: PackageId -> UnitId -> BuildResult -> IO ()-    printBuildResult pkgid ipid buildResult = case buildResult of+    printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()+    printBuildResult pkgid uid buildOutcome = case buildOutcome of         (Right _) -> notice verbosity $ "Installed " ++ display pkgid         (Left _)  -> do           notice verbosity $ "Failed to install " ++ display pkgid@@ -1233,7 +1198,7 @@             case useLogFile of               Nothing                 -> return ()               Just (mkLogFileName, _) -> do-                let logName = mkLogFileName pkgid ipid+                let logName = mkLogFileName pkgid uid                 putStr $ "Build log ( " ++ logName ++ " ):\n"                 printFile logName @@ -1257,29 +1222,30 @@                                     -> a)                     -> a installReadyPackage platform cinfo configFlags-                    (ReadyPackage (ConfiguredPackage+                    (ReadyPackage (ConfiguredPackage ipid                                     (SourcePackage _ gpkg source pkgoverride)                                     flags stanzas deps))                     installPkg =   installPkg configFlags {+    configIPID = toFlag (display ipid),     configConfigurationsFlags = flags,     -- We generate the legacy constraints as well as the new style precise deps.     -- In the end only one set gets passed to Setup.hs configure, depending on     -- the Cabal version we are talking to.     configConstraints  = [ thisPackageVersion srcid-                         | ConfiguredId srcid _uid <- CD.nonSetupDeps deps ],-    configDependencies = [ (packageName srcid, uid)-                         | ConfiguredId srcid uid <- CD.nonSetupDeps deps ],+                         | ConfiguredId srcid _ipid <- CD.nonSetupDeps deps ],+    configDependencies = [ (packageName srcid, dep_ipid)+                         | ConfiguredId srcid dep_ipid <- CD.nonSetupDeps deps ],     -- Use '--exact-configuration' if supported.     configExactConfiguration = toFlag True,     configBenchmarks         = toFlag False,     configTests              = toFlag (TestStanzas `elem` stanzas)   } source pkg pkgoverride   where-    pkg = case finalizePackageDescription flags+    pkg = case finalizePD flags (enableStanzas stanzas)            (const True)-           platform cinfo [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ReadyPackage failed"+           platform cinfo [] gpkg of+      Left _ -> error "finalizePD ReadyPackage failed"       Right (desc, _) -> desc  fetchSourcePackage@@ -1287,8 +1253,8 @@   -> RepoContext   -> JobLimit   -> UnresolvedPkgLoc-  -> (ResolvedPkgLoc -> IO BuildResult)-  -> IO BuildResult+  -> (ResolvedPkgLoc -> IO BuildOutcome)+  -> IO BuildOutcome fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do   fetched <- checkFetched src   case fetched of@@ -1301,11 +1267,10 @@  installLocalPackage   :: Verbosity-  -> JobLimit   -> PackageIdentifier -> ResolvedPkgLoc -> FilePath-  -> (Maybe FilePath -> IO BuildResult)-  -> IO BuildResult-installLocalPackage verbosity jobLimit pkgid location distPref installPkg =+  -> (Maybe FilePath -> IO BuildOutcome)+  -> IO BuildOutcome+installLocalPackage verbosity pkgid location distPref installPkg =    case location of @@ -1313,25 +1278,24 @@       installPkg (Just dir)      LocalTarballPackage tarballPath ->-      installLocalTarballPackage verbosity jobLimit+      installLocalTarballPackage verbosity         pkgid tarballPath distPref installPkg      RemoteTarballPackage _ tarballPath ->-      installLocalTarballPackage verbosity jobLimit+      installLocalTarballPackage verbosity         pkgid tarballPath distPref installPkg      RepoTarballPackage _ _ tarballPath ->-      installLocalTarballPackage verbosity jobLimit+      installLocalTarballPackage verbosity         pkgid tarballPath distPref installPkg   installLocalTarballPackage   :: Verbosity-  -> JobLimit   -> PackageIdentifier -> FilePath -> FilePath-  -> (Maybe FilePath -> IO BuildResult)-  -> IO BuildResult-installLocalTarballPackage verbosity jobLimit pkgid+  -> (Maybe FilePath -> IO BuildOutcome)+  -> IO BuildOutcome+installLocalTarballPackage verbosity pkgid                            tarballPath distPref installPkg = do   tmp <- getTemporaryDirectory   withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->@@ -1340,15 +1304,13 @@           absUnpackedPath = tmpDirPath </> relUnpackedPath           descFilePath = absUnpackedPath                      </> display (packageName pkgid) <.> "cabal"-      withJobLimit jobLimit $ do-        info verbosity $ "Extracting " ++ tarballPath-                      ++ " to " ++ tmpDirPath ++ "..."-        extractTarGzFile tmpDirPath relUnpackedPath tarballPath-        exists <- doesFileExist descFilePath-        when (not exists) $-          die $ "Package .cabal file not found: " ++ show descFilePath-        maybeRenameDistDir absUnpackedPath-+      info verbosity $ "Extracting " ++ tarballPath+                    ++ " to " ++ tmpDirPath ++ "..."+      extractTarGzFile tmpDirPath relUnpackedPath tarballPath+      exists <- doesFileExist descFilePath+      when (not exists) $+        die $ "Package .cabal file not found: " ++ show descFilePath+      maybeRenameDistDir absUnpackedPath       installPkg (Just absUnpackedPath)    where@@ -1381,27 +1343,25 @@  installUnpackedPackage   :: Verbosity-  -> JobLimit   -> Lock   -> Int   -> SetupScriptOptions-  -> InstallMisc   -> ConfigFlags   -> InstallFlags   -> HaddockFlags-  -> CompilerInfo+  -> Compiler+  -> ProgramDb   -> Platform   -> PackageDescription   -> ReadyPackage   -> PackageDescriptionOverride   -> Maybe FilePath -- ^ Directory to change to before starting the installation.   -> UseLogFile -- ^ File to log output to (if any)-  -> IO BuildResult-installUnpackedPackage verbosity buildLimit installLock numJobs-                       scriptOptions miscOptions-                       configFlags installFlags haddockFlags-                       cinfo platform pkg rpkg pkgoverride workingDir useLogFile = do-+  -> IO BuildOutcome+installUnpackedPackage verbosity installLock numJobs+                       scriptOptions+                       configFlags installFlags haddockFlags comp progdb+                       platform pkg rpkg pkgoverride workingDir useLogFile = do   -- Override the .cabal file if necessary   case pkgoverride of     Nothing     -> return ()@@ -1413,20 +1373,9 @@                     ++ " with the latest revision from the index."       writeFileAtomic descFilePath pkgtxt -  -- Compute the IPID of the *library*-  let flags (ReadyPackage cpkg) = confPkgFlags cpkg-      pkg_name = pkgName (PackageDescription.package pkg)-      cid = Configure.computeComponentId-                Cabal.NoFlag -- This would let us override the computation-                (PackageDescription.package pkg)-                (CLibName (display pkg_name))-                (map (\(SimpleUnitId cid0) -> cid0) (CD.libraryDeps (depends rpkg)))-                (flags rpkg)-      ipid = SimpleUnitId cid-   -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if   -- the setup script was compiled against an old version of the Cabal lib).-  configFlags' <- addDefaultInstallDirs ipid configFlags+  configFlags' <- addDefaultInstallDirs configFlags   -- Filter out flags not supported by the old versions of the Cabal lib.   let configureFlags :: Version -> ConfigFlags       configureFlags  = filterConfigureFlags configFlags' {@@ -1434,11 +1383,11 @@       }    -- Path to the optional log file.-  mLogPath <- maybeLogPath ipid+  mLogPath <- maybeLogPath    logDirChange (maybe putStr appendFile mLogPath) workingDir $ do     -- Configure phase-    onFailure ConfigureFailed $ withJobLimit buildLimit $ do+    onFailure ConfigureFailed $ do       when (numJobs > 1) $ notice verbosity $         "Configuring " ++ display pkgid ++ "..."       setup configureCommand configureFlags mLogPath@@ -1468,24 +1417,33 @@         -- Install phase           onFailure InstallFailed $ criticalSection installLock $ do             -- Actual installation-            withWin32SelfUpgrade verbosity ipid configFlags+            withWin32SelfUpgrade verbosity uid configFlags                                  cinfo platform pkg $ do-              case rootCmd miscOptions of-                (Just cmd) -> reexec cmd-                Nothing    -> do-                  setup Cabal.copyCommand copyFlags mLogPath-                  when shouldRegister $ do-                    setup Cabal.registerCommand registerFlags mLogPath+              setup Cabal.copyCommand copyFlags mLogPath -            -- Capture installed package configuration file-            -- TODO: Why do we need this?-            maybePkgConf <- maybeGenPkgConf mLogPath+            -- Capture installed package configuration file, so that+            -- it can be incorporated into the final InstallPlan+            ipkgs <- genPkgConfs mLogPath+            let ipkgs' = case ipkgs of+                            [ipkg] -> [ipkg { Installed.installedUnitId = uid }]+                            _ -> assert (any ((== uid)+                                              . Installed.installedUnitId)+                                             ipkgs) ipkgs+            let packageDBs = interpretPackageDbFlags+                                (fromFlag (configUserInstall configFlags))+                                (configPackageDBs configFlags)+            forM_ ipkgs' $ \ipkg' ->+                registerPackage verbosity comp progdb+                                      NoMultiInstance+                                      packageDBs ipkg' -            return (Right (BuildOk docsResult testsResult maybePkgConf))+            return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs')))    where     pkgid            = packageId pkg-    buildCommand'    = buildCommand defaultProgramConfiguration+    uid              = installedUnitId rpkg+    cinfo            = compilerInfo comp+    buildCommand'    = buildCommand progdb     buildFlags   _   = emptyBuildFlags {       buildDistPref  = configDistPref configFlags,       buildVerbosity = toFlag verbosity'@@ -1513,8 +1471,8 @@     verbosity' = maybe verbosity snd useLogFile     tempTemplate name = name ++ "-" ++ display pkgid -    addDefaultInstallDirs :: UnitId -> ConfigFlags -> IO ConfigFlags-    addDefaultInstallDirs ipid configFlags' = do+    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags+    addDefaultInstallDirs configFlags' = do       defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False       return $ configFlags' {           configInstallDirs = fmap Cabal.Flag .@@ -1524,41 +1482,54 @@           }         where           CompilerId flavor _ = compilerInfoId cinfo-          env         = initialPathTemplateEnv pkgid ipid cinfo platform+          env         = initialPathTemplateEnv pkgid uid cinfo platform           userInstall = fromFlagOrDefault defaultUserInstall                         (configUserInstall configFlags') -    maybeGenPkgConf :: Maybe FilePath-                    -> IO (Maybe Installed.InstalledPackageInfo)-    maybeGenPkgConf mLogPath =+    genPkgConfs :: Maybe FilePath+                     -> IO [Installed.InstalledPackageInfo]+    genPkgConfs mLogPath =       if shouldRegister then do         tmp <- getTemporaryDirectory-        withTempFile tmp (tempTemplate "pkgConf") $ \pkgConfFile handle -> do-          hClose handle-          let registerFlags' version = (registerFlags version) {-                Cabal.regGenPkgConf = toFlag (Just pkgConfFile)+        withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do+          let pkgConfDest = dir </> "pkgConf"+              registerFlags' version = (registerFlags version) {+                Cabal.regGenPkgConf = toFlag (Just pkgConfDest)               }           setup Cabal.registerCommand registerFlags' mLogPath-          withUTF8FileContents pkgConfFile $ \pkgConfText ->-            case Installed.parseInstalledPackageInfo pkgConfText of-              Installed.ParseFailed perror    -> pkgConfParseFailed perror-              Installed.ParseOk warns pkgConf -> do-                unless (null warns) $-                  warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)-                return (Just pkgConf)-      else return Nothing+          is_dir <- doesDirectoryExist pkgConfDest+          let notHidden = not . isHidden+              isHidden name = "." `isPrefixOf` name+          if is_dir+            -- Sort so that each prefix of the package+            -- configurations is well formed+            then mapM (readPkgConf pkgConfDest) . sort . filter notHidden+                    =<< getDirectoryContents pkgConfDest+            else fmap (:[]) $ readPkgConf "." pkgConfDest+      else return [] +    readPkgConf :: FilePath -> FilePath+                -> IO Installed.InstalledPackageInfo+    readPkgConf pkgConfDir pkgConfFile =+      (withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfText ->+        case Installed.parseInstalledPackageInfo pkgConfText of+          Installed.ParseFailed perror    -> pkgConfParseFailed perror+          Installed.ParseOk warns pkgConf -> do+            unless (null warns) $+              warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)+            return pkgConf)+     pkgConfParseFailed :: Installed.PError -> IO a     pkgConfParseFailed perror =       die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"             ++ show perror -    maybeLogPath :: UnitId -> IO (Maybe FilePath)-    maybeLogPath ipid =+    maybeLogPath :: IO (Maybe FilePath)+    maybeLogPath =       case useLogFile of          Nothing                 -> return Nothing          Just (mkLogFileName, _) -> do-           let logFileName = mkLogFileName (packageId pkg) ipid+           let logFileName = mkLogFileName (packageId pkg) uid                logDir      = takeDirectory logFileName            unless (null logDir) $ createDirectoryIfMissing True logDir            logFileExists <- doesFileExist logFileName@@ -1576,28 +1547,16 @@           (Just pkg)           cmd flags []) -    reexec cmd = do-      -- look for our own executable file and re-exec ourselves using a helper-      -- program like sudo to elevate privileges:-      self <- getExecutablePath-      weExist <- doesFileExist self-      if weExist-        then inDir workingDir $-               rawSystemExit verbosity cmd-                 [self, "install", "--only"-                 ,"--verbose=" ++ showForCabal verbosity]-        else die $ "Unable to find cabal executable at: " ++ self - -- helper-onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult+onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome onFailure result action =   action `catches`     [ Handler $ \ioe  -> handler (ioe  :: IOException)     , Handler $ \exit -> handler (exit :: ExitCode)     ]   where-    handler :: Exception e => e -> IO BuildResult+    handler :: Exception e => e -> IO BuildOutcome     handler = return . Left . result . toException  @@ -1613,7 +1572,7 @@                      -> PackageDescription                      -> IO a -> IO a withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity ipid configFlags cinfo platform pkg action = do+withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do    defaultDirs <- InstallDirs.defaultInstallDirs                    compFlavor@@ -1631,7 +1590,7 @@       [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension       | exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe)-      , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix+      , let exeName = prefix ++ display (PackageDescription.exeName exe) ++ suffix             prefix  = substTemplate prefixTemplate             suffix  = substTemplate suffixTemplate ]       where@@ -1641,10 +1600,10 @@         templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid ipid+                           pkgid uid                            cinfo InstallDirs.NoCopyDest                            platform templateDirs         substTemplate  = InstallDirs.fromPathTemplate                        . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid ipid+          where env = InstallDirs.initialPathTemplateEnv pkgid uid                       cinfo platform
cabal/cabal-install/Distribution/Client/InstallPlan.hs view
@@ -1,789 +1,922 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.InstallPlan--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org--- Stability   :  provisional--- Portability :  portable------ Package installation plan----------------------------------------------------------------------------------module Distribution.Client.InstallPlan (-  InstallPlan,-  GenericInstallPlan,-  PlanPackage,-  GenericPlanPackage(..),--  -- * Operations on 'InstallPlan's-  new,-  toList,-  mapPreservingGraph,--  ready,-  processing,-  completed,-  failed,-  remove,-  preexisting,-  preinstalled,--  showPlanIndex,-  showInstallPlan,--  -- * Checking validity of plans-  valid,-  closed,-  consistent,-  acyclic,--  -- ** Details on invalid plans-  PlanProblem(..),-  showPlanProblem,-  problems,--  -- ** Querying the install plan-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  ) where--import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..)-         , HasUnitId(..), UnitId(..) )-import Distribution.Client.Types-         ( BuildSuccess, BuildFailure-         , PackageFixedDeps(..), ConfiguredPackage-         , UnresolvedPkgLoc-         , GenericReadyPackage(..), fakeUnitId )-import Distribution.Version-         ( Version )-import Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.ComponentDeps as CD-import Distribution.Simple.PackageIndex-         ( PackageIndex )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Client.PlanIndex-         ( FakeMap )-import qualified Distribution.Client.PlanIndex as PlanIndex-import Distribution.Text-         ( display )--import Data.List-         ( foldl', intercalate )-import Data.Maybe-         ( fromMaybe, catMaybes )-import qualified Data.Graph as Graph-import Data.Graph (Graph)-import qualified Data.Tree as Tree-import Distribution.Compat.Binary (Binary(..))-import GHC.Generics-import Control.Exception-         ( assert )-import qualified Data.Map as Map-import qualified Data.Traversable as T----- When cabal tries to install a number of packages, including all their--- dependencies it has a non-trivial problem to solve.------ The Problem:------ In general we start with a set of installed packages and a set of source--- packages.------ Installed packages have fixed dependencies. They have already been built and--- we know exactly what packages they were built against, including their exact--- versions.------ Source package have somewhat flexible dependencies. They are specified as--- version ranges, though really they're predicates. To make matters worse they--- have conditional flexible dependencies. Configuration flags can affect which--- packages are required and can place additional constraints on their--- versions.------ These two sets of package can and usually do overlap. There can be installed--- packages that are also available as source packages which means they could--- be re-installed if required, though there will also be packages which are--- not available as source and cannot be re-installed. Very often there will be--- extra versions available than are installed. Sometimes we may like to prefer--- installed packages over source ones or perhaps always prefer the latest--- available version whether installed or not.------ The goal is to calculate an installation plan that is closed, acyclic and--- consistent and where every configured package is valid.------ An installation plan is a set of packages that are going to be used--- together. It will consist of a mixture of installed packages and source--- packages along with their exact version dependencies. An installation plan--- is closed if for every package in the set, all of its dependencies are--- also in the set. It is consistent if for every package in the set, all--- dependencies which target that package have the same version.---- Note that plans do not necessarily compose. You might have a valid plan for--- package A and a valid plan for package B. That does not mean the composition--- is simultaneously valid for A and B. In particular you're most likely to--- have problems with inconsistent dependencies.--- On the other hand it is true that every closed sub plan is valid.---- | Packages in an install plan------ NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'--- intentionally have no 'PackageInstalled' instance. `This is important:--- PackageInstalled returns only library dependencies, but for package that--- aren't yet installed we know many more kinds of dependencies (setup--- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on--- dependencies in cabal-install should consider what to do with these--- dependencies; if we give a 'PackageInstalled' instance it would be too easy--- to get this wrong (and, for instance, call graph traversal functions from--- Cabal rather than from cabal-install). Instead, see 'PackageFixedDeps'.-data GenericPlanPackage ipkg srcpkg iresult ifailure-   = PreExisting ipkg-   | Configured  srcpkg-   | Processing  (GenericReadyPackage srcpkg)-   | Installed   (GenericReadyPackage srcpkg) (Maybe ipkg) iresult-   | Failed      srcpkg ifailure-  deriving (Eq, Show, Generic)--instance (Binary ipkg, Binary srcpkg, Binary  iresult, Binary  ifailure)-      => Binary (GenericPlanPackage ipkg srcpkg iresult ifailure)--type PlanPackage = GenericPlanPackage-                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)-                   BuildSuccess BuildFailure--instance (Package ipkg, Package srcpkg) =>-         Package (GenericPlanPackage ipkg srcpkg iresult ifailure) where-  packageId (PreExisting ipkg)     = packageId ipkg-  packageId (Configured  spkg)     = packageId spkg-  packageId (Processing  rpkg)     = packageId rpkg-  packageId (Installed   rpkg _ _) = packageId rpkg-  packageId (Failed      spkg   _) = packageId spkg--instance (PackageFixedDeps srcpkg,-          PackageFixedDeps ipkg) =>-         PackageFixedDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) where-  depends (PreExisting pkg)     = depends pkg-  depends (Configured  pkg)     = depends pkg-  depends (Processing  pkg)     = depends pkg-  depends (Installed   pkg _ _) = depends pkg-  depends (Failed      pkg   _) = depends pkg--instance (HasUnitId ipkg, HasUnitId srcpkg) =>-         HasUnitId-         (GenericPlanPackage ipkg srcpkg iresult ifailure) where-  installedUnitId (PreExisting ipkg ) = installedUnitId ipkg-  installedUnitId (Configured  spkg)  = installedUnitId spkg-  installedUnitId (Processing  rpkg)  = installedUnitId rpkg-  -- NB: defer to the actual installed package info in this case-  installedUnitId (Installed _ (Just ipkg) _) = installedUnitId ipkg-  installedUnitId (Installed rpkg _        _) = installedUnitId rpkg-  installedUnitId (Failed      spkg        _) = installedUnitId spkg---data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan {-    planIndex      :: !(PlanIndex ipkg srcpkg iresult ifailure),-    planFakeMap    :: !FakeMap,-    planIndepGoals :: !Bool,--    -- | Cached (lazily) graph-    ---    -- The 'Graph' representation works in terms of integer node ids, so we-    -- have to keep mapping to and from our meaningful nodes, which of course-    -- are package ids.-    ---    planGraph      :: Graph,-    planGraphRev   :: Graph,  -- ^ Reverse deps, transposed-    planPkgIdOf    :: Graph.Vertex -> UnitId, -- ^ mapping back to package ids-    planVertexOf   :: UnitId -> Graph.Vertex  -- ^ mapping into node ids-  }---- | Much like 'planPkgIdOf', but mapping back to full packages.-planPkgOf :: GenericInstallPlan ipkg srcpkg iresult ifailure-          -> Graph.Vertex-          -> GenericPlanPackage ipkg srcpkg iresult ifailure-planPkgOf plan v =-    case PackageIndex.lookupUnitId (planIndex plan)-                                   (planPkgIdOf plan v) of-      Just pkg -> pkg-      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"----- | 'GenericInstallPlan' specialised to most commonly used types.-type InstallPlan = GenericInstallPlan-                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)-                   BuildSuccess BuildFailure--type PlanIndex ipkg srcpkg iresult ifailure =-     PackageIndex (GenericPlanPackage ipkg srcpkg iresult ifailure)--invariant :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-              HasUnitId srcpkg, PackageFixedDeps srcpkg)-          => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool-invariant plan =-    valid (planFakeMap plan)-          (planIndepGoals plan)-          (planIndex plan)---- | Smart constructor that deals with caching the 'Graph' representation.----mkInstallPlan :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-                  HasUnitId srcpkg, PackageFixedDeps srcpkg)-              => PlanIndex ipkg srcpkg iresult ifailure-              -> FakeMap-              -> Bool-              -> GenericInstallPlan ipkg srcpkg iresult ifailure-mkInstallPlan index fakeMap indepGoals =-    GenericInstallPlan {-      planIndex      = index,-      planFakeMap    = fakeMap,-      planIndepGoals = indepGoals,--      -- lazily cache the graph stuff:-      planGraph      = graph,-      planGraphRev   = Graph.transposeG graph,-      planPkgIdOf    = vertexToPkgId,-      planVertexOf   = fromMaybe noSuchPkgId . pkgIdToVertex-    }-  where-    (graph, vertexToPkgId, pkgIdToVertex) =-      PlanIndex.dependencyGraph fakeMap index-    noSuchPkgId = internalError "package is not in the graph"--internalError :: String -> a-internalError msg = error $ "InstallPlan: internal error: " ++ msg--instance (HasUnitId ipkg,   PackageFixedDeps ipkg,-          HasUnitId srcpkg, PackageFixedDeps srcpkg,-          Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure)-       => Binary (GenericInstallPlan ipkg srcpkg iresult ifailure) where-    put GenericInstallPlan {-              planIndex      = index,-              planFakeMap    = fakeMap,-              planIndepGoals = indepGoals-        } = put (index, fakeMap, indepGoals)--    get = do-      (index, fakeMap, indepGoals) <- get-      return $! mkInstallPlan index fakeMap indepGoals--showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg)-              => PlanIndex ipkg srcpkg iresult ifailure -> String-showPlanIndex index =-    intercalate "\n" (map showPlanPackage (PackageIndex.allPackages index))-  where showPlanPackage p =-            showPlanPackageTag p ++ " "-                ++ display (packageId p) ++ " ("-                ++ display (installedUnitId p) ++ ")"--showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg)-                => GenericInstallPlan ipkg srcpkg iresult ifailure -> String-showInstallPlan plan =-    showPlanIndex (planIndex plan) ++ "\n" ++-    "fake map:\n  " ++-    intercalate "\n  " (map showKV (Map.toList (planFakeMap plan)))-  where showKV (k,v) = display k ++ " -> " ++ display v--showPlanPackageTag :: GenericPlanPackage ipkg srcpkg iresult ifailure -> String-showPlanPackageTag (PreExisting _)   = "PreExisting"-showPlanPackageTag (Configured  _)   = "Configured"-showPlanPackageTag (Processing  _)   = "Processing"-showPlanPackageTag (Installed _ _ _) = "Installed"-showPlanPackageTag (Failed    _   _) = "Failed"---- | Build an installation plan from a valid set of resolved packages.----new :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-        HasUnitId srcpkg, PackageFixedDeps srcpkg)-    => Bool-    -> PlanIndex ipkg srcpkg iresult ifailure-    -> Either [PlanProblem ipkg srcpkg iresult ifailure]-              (GenericInstallPlan ipkg srcpkg iresult ifailure)-new indepGoals index =-  -- NB: Need to pre-initialize the fake-map with pre-existing-  -- packages-  let isPreExisting (PreExisting _) = True-      isPreExisting _ = False-      fakeMap = Map.fromList-              . map (\p -> (fakeUnitId (packageId p)-                           ,installedUnitId p))-              . filter isPreExisting-              $ PackageIndex.allPackages index in-  case problems fakeMap indepGoals index of-    []    -> Right (mkInstallPlan index fakeMap indepGoals)-    probs -> Left probs--toList :: GenericInstallPlan ipkg srcpkg iresult ifailure-       -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-toList = PackageIndex.allPackages . planIndex---- | Remove packages from the install plan. This will result in an--- error if there are remaining packages that depend on any matching--- package. This is primarily useful for obtaining an install plan for--- the dependencies of a package or set of packages without actually--- installing the package itself, as when doing development.----remove :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-           HasUnitId srcpkg, PackageFixedDeps srcpkg)-       => (GenericPlanPackage ipkg srcpkg iresult ifailure -> Bool)-       -> GenericInstallPlan ipkg srcpkg iresult ifailure-       -> Either [PlanProblem ipkg srcpkg iresult ifailure]-                 (GenericInstallPlan ipkg srcpkg iresult ifailure)-remove shouldRemove plan =-    new (planIndepGoals plan) newIndex-  where-    newIndex = PackageIndex.fromList $-                 filter (not . shouldRemove) (toList plan)---- | The packages that are ready to be installed. That is they are in the--- configured state and have all their dependencies installed already.--- The plan is complete if the result is @[]@.----ready :: forall ipkg srcpkg iresult ifailure. PackageFixedDeps srcpkg-      => GenericInstallPlan ipkg srcpkg iresult ifailure-      -> [GenericReadyPackage srcpkg]-ready plan = assert check readyPackages-  where-    check = if null readyPackages && null processingPackages-              then null configuredPackages-              else True-    configuredPackages = [ pkg | Configured pkg <- toList plan ]-    processingPackages = [ pkg | Processing pkg <- toList plan]--    readyPackages :: [GenericReadyPackage srcpkg]-    readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages)--lookupReadyPackage :: forall ipkg srcpkg iresult ifailure.-                      PackageFixedDeps srcpkg-                   => GenericInstallPlan ipkg srcpkg iresult ifailure-                   -> srcpkg-                   -> Maybe (GenericReadyPackage srcpkg)-lookupReadyPackage plan pkg = do-    _ <- hasAllInstalledDeps pkg-    return (ReadyPackage pkg)-  where--    hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg])-    hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends--    isInstalledDep :: UnitId -> Maybe ipkg-    isInstalledDep pkgid =-      -- NB: Need to check if the ID has been updated in planFakeMap, in which-      -- case we might be dealing with an old pointer-      case PlanIndex.fakeLookupUnitId-           (planFakeMap plan) (planIndex plan) pkgid-      of-        Just (PreExisting ipkg)            -> Just ipkg-        Just (Configured  _)               -> Nothing-        Just (Processing  _)               -> Nothing-        Just (Installed   _ (Just ipkg) _) -> Just ipkg-        Just (Installed   _ Nothing     _) -> internalError depOnNonLib-        Just (Failed      _             _) -> internalError depOnFailed-        Nothing                            -> internalError incomplete-    incomplete  = "install plan is not closed"-    depOnFailed = "configured package depends on failed package"-    depOnNonLib = "configured package depends on a non-library package"---- | Marks packages in the graph as currently processing (e.g. building).------ * The package must exist in the graph and be in the configured state.----processing :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-               HasUnitId srcpkg, PackageFixedDeps srcpkg)-           => [GenericReadyPackage srcpkg]-           -> GenericInstallPlan ipkg srcpkg iresult ifailure-           -> GenericInstallPlan ipkg srcpkg iresult ifailure-processing pkgs plan = assert (invariant plan') plan'-  where-    plan' = plan {-              planIndex = PackageIndex.merge (planIndex plan) processingPkgs-            }-    processingPkgs = PackageIndex.fromList [Processing pkg | pkg <- pkgs]---- | Marks a package in the graph as completed. Also saves the build result for--- the completed package in the plan.------ * The package must exist in the graph and be in the processing state.--- * The package must have had no uninstalled dependent packages.----completed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-              HasUnitId srcpkg, PackageFixedDeps srcpkg)-          => UnitId-          -> Maybe ipkg -> iresult-          -> GenericInstallPlan ipkg srcpkg iresult ifailure-          -> GenericInstallPlan ipkg srcpkg iresult ifailure-completed pkgid mipkg buildResult plan = assert (invariant plan') plan'-  where-    plan'     = plan {-                  -- NB: installation can change the IPID, so better-                  -- record it in the fake mapping...-                  planFakeMap = insert_fake_mapping mipkg-                              $ planFakeMap plan,-                  planIndex = PackageIndex.insert installed-                            . PackageIndex.deleteUnitId pkgid-                            $ planIndex plan-                }-    -- ...but be sure to use the *old* IPID for the lookup for the-    -- preexisting record-    installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult-    insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedUnitId ipkg)-    insert_fake_mapping  _          = id---- | Marks a package in the graph as having failed. It also marks all the--- packages that depended on it as having failed.------ * The package must exist in the graph and be in the processing--- state.----failed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-           HasUnitId srcpkg, PackageFixedDeps srcpkg)-       => UnitId         -- ^ The id of the package that failed to install-       -> ifailure           -- ^ The build result to use for the failed package-       -> ifailure           -- ^ The build result to use for its dependencies-       -> GenericInstallPlan ipkg srcpkg iresult ifailure-       -> GenericInstallPlan ipkg srcpkg iresult ifailure-failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'-  where-    -- NB: failures don't update IPIDs-    plan'    = plan {-                 planIndex = PackageIndex.merge (planIndex plan) failures-               }-    ReadyPackage srcpkg = lookupProcessingPackage plan pkgid-    failures = PackageIndex.fromList-             $ Failed srcpkg buildResult-             : [ Failed pkg' buildResult'-               | Just pkg' <- map checkConfiguredPackage-                            $ packagesThatDependOn plan pkgid ]---- | Lookup the reachable packages in the reverse dependency graph.----packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure-                     -> UnitId-                     -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-packagesThatDependOn plan pkgid = map (planPkgOf plan)-                          . tail-                          . Graph.reachable (planGraphRev plan)-                          . planVertexOf plan-                          $ Map.findWithDefault pkgid pkgid (planFakeMap plan)---- | Lookup a package that we expect to be in the processing state.----lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure-                        -> UnitId-                        -> GenericReadyPackage srcpkg-lookupProcessingPackage plan pkgid =-  -- NB: processing packages are guaranteed to not indirect through-  -- planFakeMap-  case PackageIndex.lookupUnitId (planIndex plan) pkgid of-    Just (Processing pkg) -> pkg-    _  -> internalError $ "not in processing state or no such pkg " ++-                          display pkgid---- | Check a package that we expect to be in the configured or failed state.----checkConfiguredPackage :: (Package srcpkg, Package ipkg)-                       => GenericPlanPackage ipkg srcpkg iresult ifailure-                       -> Maybe srcpkg-checkConfiguredPackage (Configured pkg) = Just pkg-checkConfiguredPackage (Failed     _ _) = Nothing-checkConfiguredPackage pkg                =-  internalError $ "not configured or no such pkg " ++ display (packageId pkg)---- | Replace a ready package with a pre-existing one. The pre-existing one--- must have exactly the same dependencies as the source one was configured--- with.----preexisting :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-                HasUnitId srcpkg, PackageFixedDeps srcpkg)-            => UnitId-            -> ipkg-            -> GenericInstallPlan ipkg srcpkg iresult ifailure-            -> GenericInstallPlan ipkg srcpkg iresult ifailure-preexisting pkgid ipkg plan = assert (invariant plan') plan'-  where-    plan' = plan {-                    -- NB: installation can change the IPID, so better-                    -- record it in the fake mapping...-      planFakeMap = Map.insert pkgid-                               (installedUnitId ipkg)-                               (planFakeMap plan),-      planIndex   = PackageIndex.insert (PreExisting ipkg)-                    -- ...but be sure to use the *old* IPID for the lookup for-                    -- the preexisting record-                  . PackageIndex.deleteUnitId pkgid-                  $ planIndex plan-    }---- | Replace a ready package with an installed one. The installed one--- must have exactly the same dependencies as the source one was configured--- with.----preinstalled :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-                 HasUnitId srcpkg, PackageFixedDeps srcpkg)-             => UnitId-             -> Maybe ipkg -> iresult-             -> GenericInstallPlan ipkg srcpkg iresult ifailure-             -> GenericInstallPlan ipkg srcpkg iresult ifailure-preinstalled pkgid mipkg buildResult plan = assert (invariant plan') plan'-  where-    plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) }-    Just installed = do-      Configured pkg <- PackageIndex.lookupUnitId (planIndex plan) pkgid-      rpkg <- lookupReadyPackage plan pkg-      return (Installed rpkg mipkg buildResult)---- | Transform an install plan by mapping a function over all the packages in--- the plan. It can consistently change the 'UnitId' of all the packages,--- while preserving the same overall graph structure.------ The mapping function has a few constraints on it for correct operation.--- The mapping function /may/ change the 'UnitId' of the package, but it--- /must/ also remap the 'UnitId's of its dependencies using ths supplied--- remapping function. Apart from this consistent remapping it /may not/--- change the structure of the dependencies.----mapPreservingGraph :: (HasUnitId ipkg,-                       HasUnitId srcpkg,-                       HasUnitId ipkg',   PackageFixedDeps ipkg',-                       HasUnitId srcpkg', PackageFixedDeps srcpkg')-                   => (  (UnitId -> UnitId)-                      -> GenericPlanPackage ipkg  srcpkg  iresult  ifailure-                      -> GenericPlanPackage ipkg' srcpkg' iresult' ifailure')-                   -> GenericInstallPlan ipkg  srcpkg  iresult  ifailure-                   -> GenericInstallPlan ipkg' srcpkg' iresult' ifailure'-mapPreservingGraph f plan =-    mkInstallPlan (PackageIndex.fromList pkgs')-                  Map.empty -- empty fakeMap-                  (planIndepGoals plan)-  where-    -- The package mapping function may change the UnitId. So we-    -- walk over the packages in dependency order keeping track of these-    -- package id changes and use it to supply the correct set of package-    -- dependencies as an extra input to the package mapping function.-    ---    -- Having fully remapped all the deps this also means we can use an empty-    -- FakeMap for the resulting install plan.--    (_, pkgs') = foldl' f' (Map.empty, []) (reverseTopologicalOrder plan)--    f' (ipkgidMap, pkgs) pkg = (ipkgidMap', pkg' : pkgs)-      where-       pkg' = f (mapDep ipkgidMap) pkg--       ipkgidMap'-         | ipkgid /= ipkgid' = Map.insert ipkgid ipkgid' ipkgidMap-         | otherwise         =                           ipkgidMap-         where-           ipkgid  = installedUnitId pkg-           ipkgid' = installedUnitId pkg'--    mapDep ipkgidMap ipkgid = Map.findWithDefault ipkgid ipkgid ipkgidMap----- --------------------------------------------------------------- * Checking validity of plans--- ---------------------------------------------------------------- | A valid installation plan is a set of packages that is 'acyclic',--- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the--- plan has to have a valid configuration (see 'configuredPackageValid').------ * if the result is @False@ use 'problems' to get a detailed list.----valid :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-          HasUnitId srcpkg, PackageFixedDeps srcpkg)-      => FakeMap -> Bool-      -> PlanIndex ipkg srcpkg iresult ifailure-      -> Bool-valid fakeMap indepGoals index =-    null $ problems fakeMap indepGoals index--data PlanProblem ipkg srcpkg iresult ifailure =-     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg iresult ifailure)-                          [PackageIdentifier]-   | PackageCycle         [GenericPlanPackage ipkg srcpkg iresult ifailure]-   | PackageInconsistency PackageName [(PackageIdentifier, Version)]-   | PackageStateInvalid  (GenericPlanPackage ipkg srcpkg iresult ifailure)-                          (GenericPlanPackage ipkg srcpkg iresult ifailure)--showPlanProblem :: (Package ipkg, Package srcpkg)-                => PlanProblem ipkg srcpkg iresult ifailure -> String-showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ display (packageId pkg)-  ++ " depends on the following packages which are missing from the plan: "-  ++ intercalate ", " (map display missingDeps)--showPlanProblem (PackageCycle cycleGroup) =-     "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (display.packageId) cycleGroup)--showPlanProblem (PackageInconsistency name inconsistencies) =-     "Package " ++ display name-  ++ " is required by several packages,"-  ++ " but they require inconsistent versions:\n"-  ++ unlines [ "  package " ++ display pkg ++ " requires "-                            ++ display (PackageIdentifier name ver)-             | (pkg, ver) <- inconsistencies ]--showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ display (packageId pkg)-  ++ " is in the " ++ showPlanState pkg-  ++ " state but it depends on package " ++ display (packageId pkg')-  ++ " which is in the " ++ showPlanState pkg'-  ++ " state"-  where-    showPlanState (PreExisting _)   = "pre-existing"-    showPlanState (Configured  _)   = "configured"-    showPlanState (Processing  _)   = "processing"-    showPlanState (Installed _ _ _) = "installed"-    showPlanState (Failed    _   _) = "failed"---- | For an invalid plan, produce a detailed list of problems as human readable--- error messages. This is mainly intended for debugging purposes.--- Use 'showPlanProblem' for a human readable explanation.----problems :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-             HasUnitId srcpkg, PackageFixedDeps srcpkg)-         => FakeMap -> Bool-         -> PlanIndex ipkg srcpkg iresult ifailure-         -> [PlanProblem ipkg srcpkg iresult ifailure]-problems fakeMap indepGoals index =--     [ PackageMissingDeps pkg-       (catMaybes-        (map-         (fmap packageId . PlanIndex.fakeLookupUnitId fakeMap index)-         missingDeps))-     | (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]--  ++ [ PackageCycle cycleGroup-     | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]--  ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <--       PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]--  ++ [ PackageStateInvalid pkg pkg'-     | pkg <- PackageIndex.allPackages index-     , Just pkg' <- map (PlanIndex.fakeLookupUnitId fakeMap index)-                    (CD.flatDeps (depends pkg))-     , not (stateDependencyRelation pkg pkg') ]---- | The graph of packages (nodes) and dependencies (edges) must be acyclic.------ * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out---   which packages are involved in dependency cycles.----acyclic :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-            HasUnitId srcpkg, PackageFixedDeps srcpkg)-        => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool-acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap---- | An installation plan is closed if for every package in the set, all of--- its dependencies are also in the set. That is, the set is closed under the--- dependency relation.------ * if the result is @False@ use 'PackageIndex.brokenPackages' to find out---   which packages depend on packages not in the index.----closed :: (PackageFixedDeps ipkg,-           PackageFixedDeps srcpkg)-       => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool-closed fakeMap = null . PlanIndex.brokenPackages fakeMap---- | An installation plan is consistent if all dependencies that target a--- single package name, target the same version.------ This is slightly subtle. It is not the same as requiring that there be at--- most one version of any package in the set. It only requires that of--- packages which have more than one other package depending on them. We could--- actually make the condition even more precise and say that different--- versions are OK so long as they are not both in the transitive closure of--- any other package (or equivalently that their inverse closures do not--- intersect). The point is we do not want to have any packages depending--- directly or indirectly on two different versions of the same package. The--- current definition is just a safe approximation of that.------ * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to---   find out which packages are.----consistent :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-               HasUnitId srcpkg, PackageFixedDeps srcpkg)-           => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool-consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False---- | The states of packages have that depend on each other must respect--- this relation. That is for very case where package @a@ depends on--- package @b@ we require that @dependencyStatesOk a b = True@.----stateDependencyRelation :: GenericPlanPackage ipkg srcpkg iresult ifailure-                        -> GenericPlanPackage ipkg srcpkg iresult ifailure-                        -> Bool-stateDependencyRelation (PreExisting _) (PreExisting _)   = True--stateDependencyRelation (Configured  _) (PreExisting _)   = True-stateDependencyRelation (Configured  _) (Configured  _)   = True-stateDependencyRelation (Configured  _) (Processing  _)   = True-stateDependencyRelation (Configured  _) (Installed _ _ _) = True--stateDependencyRelation (Processing  _) (PreExisting _)   = True-stateDependencyRelation (Processing  _) (Installed _ _ _) = True--stateDependencyRelation (Installed _ _ _) (PreExisting _)   = True-stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True--stateDependencyRelation (Failed    _ _) (PreExisting _)   = True--- failed can depends on configured because a package can depend on--- several other packages and if one of the deps fail then we fail--- but we still depend on the other ones that did not fail:-stateDependencyRelation (Failed    _ _) (Configured  _)   = True-stateDependencyRelation (Failed    _ _) (Processing  _)   = True-stateDependencyRelation (Failed    _ _) (Installed _ _ _) = True-stateDependencyRelation (Failed    _ _) (Failed    _   _) = True--stateDependencyRelation _               _                 = False----- | Compute the dependency closure of a package in a install plan----dependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure-                  -> [UnitId]-                  -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-dependencyClosure plan =-    map (planPkgOf plan)-  . concatMap Tree.flatten-  . Graph.dfs (planGraph plan)-  . map (planVertexOf plan)---reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure-                         -> [UnitId]-                         -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-reverseDependencyClosure plan =-    map (planPkgOf plan)-  . concatMap Tree.flatten-  . Graph.dfs (planGraphRev plan)-  . map (planVertexOf plan)---topologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure-                 -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-topologicalOrder plan =-    map (planPkgOf plan)-  . Graph.topSort-  $ planGraph plan---reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure-                        -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-reverseTopologicalOrder plan =-    map (planPkgOf plan)-  . Graph.topSort-  $ planGraphRev plan+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallPlan+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Package installation plan+--+-----------------------------------------------------------------------------+module Distribution.Client.InstallPlan (+  InstallPlan,+  GenericInstallPlan,+  PlanPackage,+  GenericPlanPackage(..),+  IsUnit,++  -- * Operations on 'InstallPlan's+  new,+  toGraph,+  toList,+  toMap,+  keys,+  keysSet,+  planIndepGoals,+  depends,++  fromSolverInstallPlan,+  fromSolverInstallPlanWithProgress,+  configureInstallPlan,+  remove,+  installed,+  lookup,+  directDeps,+  revDirectDeps,++  -- * Traversal+  executionOrder,+  execute,+  BuildOutcomes,+  lookupBuildOutcome,+  -- ** Traversal helpers+  -- $traversal+  Processing,+  ready,+  completed,+  failed,++  -- * Display+  showPlanGraph,+  showInstallPlan,++  -- * Graph-like operations+  reverseTopologicalOrder,+  reverseDependencyClosure,+  ) where++import Distribution.Client.Types hiding (BuildOutcomes)+import qualified Distribution.PackageDescription as PD+import qualified Distribution.Simple.Configure as Configure+import qualified Distribution.Simple.Setup as Cabal++import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.Package+         ( Package(..)+         , HasUnitId(..), UnitId )+import Distribution.Solver.Types.SolverPackage+import Distribution.Client.JobControl+import Distribution.Text+import Text.PrettyPrint+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.InstSolverPackage++import           Distribution.Utils.LogProgress++-- TODO: Need this when we compute final UnitIds+-- import qualified Distribution.Simple.Configure as Configure++import Data.List+         ( foldl', intercalate )+import qualified Data.Foldable as Foldable (all)+import Data.Maybe+         ( fromMaybe, catMaybes )+import qualified Distribution.Compat.Graph as Graph+import Distribution.Compat.Graph (Graph, IsNode(..))+import Distribution.Compat.Binary (Binary(..))+import GHC.Generics+import Data.Typeable+import Control.Monad+import Control.Exception+         ( assert )+import qualified Data.Map as Map+import           Data.Map (Map)+import qualified Data.Set as Set+import           Data.Set (Set)++import Prelude hiding (lookup)+++-- When cabal tries to install a number of packages, including all their+-- dependencies it has a non-trivial problem to solve.+--+-- The Problem:+--+-- In general we start with a set of installed packages and a set of source+-- packages.+--+-- Installed packages have fixed dependencies. They have already been built and+-- we know exactly what packages they were built against, including their exact+-- versions.+--+-- Source package have somewhat flexible dependencies. They are specified as+-- version ranges, though really they're predicates. To make matters worse they+-- have conditional flexible dependencies. Configuration flags can affect which+-- packages are required and can place additional constraints on their+-- versions.+--+-- These two sets of package can and usually do overlap. There can be installed+-- packages that are also available as source packages which means they could+-- be re-installed if required, though there will also be packages which are+-- not available as source and cannot be re-installed. Very often there will be+-- extra versions available than are installed. Sometimes we may like to prefer+-- installed packages over source ones or perhaps always prefer the latest+-- available version whether installed or not.+--+-- The goal is to calculate an installation plan that is closed, acyclic and+-- consistent and where every configured package is valid.+--+-- An installation plan is a set of packages that are going to be used+-- together. It will consist of a mixture of installed packages and source+-- packages along with their exact version dependencies. An installation plan+-- is closed if for every package in the set, all of its dependencies are+-- also in the set. It is consistent if for every package in the set, all+-- dependencies which target that package have the same version.++-- Note that plans do not necessarily compose. You might have a valid plan for+-- package A and a valid plan for package B. That does not mean the composition+-- is simultaneously valid for A and B. In particular you're most likely to+-- have problems with inconsistent dependencies.+-- On the other hand it is true that every closed sub plan is valid.++-- | Packages in an install plan+--+-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'+-- intentionally have no 'PackageInstalled' instance. `This is important:+-- PackageInstalled returns only library dependencies, but for package that+-- aren't yet installed we know many more kinds of dependencies (setup+-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on+-- dependencies in cabal-install should consider what to do with these+-- dependencies; if we give a 'PackageInstalled' instance it would be too easy+-- to get this wrong (and, for instance, call graph traversal functions from+-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.+data GenericPlanPackage ipkg srcpkg+   = PreExisting ipkg+   | Configured  srcpkg+   | Installed   srcpkg+  deriving (Eq, Show, Generic)++type IsUnit a = (IsNode a, Key a ~ UnitId)++depends :: IsUnit a => a -> [UnitId]+depends = nodeNeighbors++-- NB: Expanded constraint synonym here to avoid undecidable+-- instance errors in GHC 7.8 and earlier.+instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)+         => IsNode (GenericPlanPackage ipkg srcpkg) where+    type Key (GenericPlanPackage ipkg srcpkg) = UnitId+    nodeKey (PreExisting ipkg) = nodeKey ipkg+    nodeKey (Configured  spkg) = nodeKey spkg+    nodeKey (Installed   spkg) = nodeKey spkg+    nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg+    nodeNeighbors (Configured  spkg) = nodeNeighbors spkg+    nodeNeighbors (Installed   spkg) = nodeNeighbors spkg++instance (Binary ipkg, Binary srcpkg)+      => Binary (GenericPlanPackage ipkg srcpkg)++type PlanPackage = GenericPlanPackage+                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)++instance (Package ipkg, Package srcpkg) =>+         Package (GenericPlanPackage ipkg srcpkg) where+  packageId (PreExisting ipkg)     = packageId ipkg+  packageId (Configured  spkg)     = packageId spkg+  packageId (Installed   spkg)     = packageId spkg++instance (HasUnitId ipkg, HasUnitId srcpkg) =>+         HasUnitId+         (GenericPlanPackage ipkg srcpkg) where+  installedUnitId (PreExisting ipkg) = installedUnitId ipkg+  installedUnitId (Configured  spkg) = installedUnitId spkg+  installedUnitId (Installed   spkg) = installedUnitId spkg++instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>+          HasConfiguredId (GenericPlanPackage ipkg srcpkg) where+    configuredId (PreExisting ipkg) = configuredId ipkg+    configuredId (Configured  spkg) = configuredId spkg+    configuredId (Installed   spkg) = configuredId spkg++data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {+    planGraph      :: !(Graph (GenericPlanPackage ipkg srcpkg)),+    planIndepGoals :: !IndependentGoals+  }+  deriving (Typeable)++-- | 'GenericInstallPlan' specialised to most commonly used types.+type InstallPlan = GenericInstallPlan+                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)++-- | Smart constructor that deals with caching the 'Graph' representation.+--+mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)+              => String+              -> Graph (GenericPlanPackage ipkg srcpkg)+              -> IndependentGoals+              -> GenericInstallPlan ipkg srcpkg+mkInstallPlan loc graph indepGoals =+    assert (valid loc graph)+    GenericInstallPlan {+      planGraph      = graph,+      planIndepGoals = indepGoals+    }++internalError :: String -> String -> a+internalError loc msg = error $ "internal error in InstallPlan." ++ loc+                             ++ if null msg then "" else ": " ++ msg++instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,+          Binary ipkg, Binary srcpkg)+       => Binary (GenericInstallPlan ipkg srcpkg) where+    put GenericInstallPlan {+              planGraph      = graph,+              planIndepGoals = indepGoals+        } = put (graph, indepGoals)++    get = do+      (graph, indepGoals) <- get+      return $! mkInstallPlan "(instance Binary)" graph indepGoals++showPlanGraph :: (Package ipkg, Package srcpkg,+                  IsUnit ipkg, IsUnit srcpkg)+              => Graph (GenericPlanPackage ipkg srcpkg) -> String+showPlanGraph graph = renderStyle defaultStyle $+    vcat (map dispPlanPackage (Graph.toList graph))+  where dispPlanPackage p =+            hang (hsep [ text (showPlanPackageTag p)+                       , disp (packageId p)+                       , parens (disp (nodeKey p))]) 2+                 (vcat (map disp (nodeNeighbors p)))++showInstallPlan :: (Package ipkg, Package srcpkg,+                    IsUnit ipkg, IsUnit srcpkg)+                => GenericInstallPlan ipkg srcpkg -> String+showInstallPlan = showPlanGraph . planGraph++showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String+showPlanPackageTag (PreExisting _)   = "PreExisting"+showPlanPackageTag (Configured  _)   = "Configured"+showPlanPackageTag (Installed   _)   = "Installed"++-- | Build an installation plan from a valid set of resolved packages.+--+new :: (IsUnit ipkg, IsUnit srcpkg)+    => IndependentGoals+    -> Graph (GenericPlanPackage ipkg srcpkg)+    -> GenericInstallPlan ipkg srcpkg+new indepGoals graph = mkInstallPlan "new" graph indepGoals++toGraph :: GenericInstallPlan ipkg srcpkg+        -> Graph (GenericPlanPackage ipkg srcpkg)+toGraph = planGraph++toList :: GenericInstallPlan ipkg srcpkg+       -> [GenericPlanPackage ipkg srcpkg]+toList = Graph.toList . planGraph++toMap :: GenericInstallPlan ipkg srcpkg+      -> Map UnitId (GenericPlanPackage ipkg srcpkg)+toMap = Graph.toMap . planGraph++keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]+keys = Graph.keys . planGraph++keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId+keysSet = Graph.keysSet . planGraph++-- | Remove packages from the install plan. This will result in an+-- error if there are remaining packages that depend on any matching+-- package. This is primarily useful for obtaining an install plan for+-- the dependencies of a package or set of packages without actually+-- installing the package itself, as when doing development.+--+remove :: (IsUnit ipkg, IsUnit srcpkg)+       => (GenericPlanPackage ipkg srcpkg -> Bool)+       -> GenericInstallPlan ipkg srcpkg+       -> GenericInstallPlan ipkg srcpkg+remove shouldRemove plan =+    mkInstallPlan "remove" newGraph (planIndepGoals plan)+  where+    newGraph = Graph.fromList $+                 filter (not . shouldRemove) (toList plan)++-- | Change a number of packages in the 'Configured' state to the 'Installed'+-- state.+--+-- To preserve invariants, the package must have all of its dependencies+-- already installed too (that is 'PreExisting' or 'Installed').+--+installed :: (IsUnit ipkg, IsUnit srcpkg)+          => (srcpkg -> Bool)+          -> GenericInstallPlan ipkg srcpkg+          -> GenericInstallPlan ipkg srcpkg+installed shouldBeInstalled installPlan =+    foldl' markInstalled installPlan+      [ pkg+      | Configured pkg <- reverseTopologicalOrder installPlan+      , shouldBeInstalled pkg ]+  where+    markInstalled plan pkg =+      assert (all isInstalled (directDeps plan (nodeKey pkg))) $+      plan {+        planGraph = Graph.insert (Installed pkg) (planGraph plan)+      }++-- | Lookup a package in the plan.+--+lookup :: (IsUnit ipkg, IsUnit srcpkg)+       => GenericInstallPlan ipkg srcpkg+       -> UnitId+       -> Maybe (GenericPlanPackage ipkg srcpkg)+lookup plan pkgid = Graph.lookup pkgid (planGraph plan)++-- | Find all the direct dependencies of the given package.+--+-- Note that the package must exist in the plan or it is an error.+--+directDeps :: GenericInstallPlan ipkg srcpkg+           -> UnitId+           -> [GenericPlanPackage ipkg srcpkg]+directDeps plan pkgid =+  case Graph.neighbors (planGraph plan) pkgid of+    Just deps -> deps+    Nothing   -> internalError "directDeps" "package not in graph"++-- | Find all the direct reverse dependencies of the given package.+--+-- Note that the package must exist in the plan or it is an error.+--+revDirectDeps :: GenericInstallPlan ipkg srcpkg+              -> UnitId+              -> [GenericPlanPackage ipkg srcpkg]+revDirectDeps plan pkgid =+  case Graph.revNeighbors (planGraph plan) pkgid of+    Just deps -> deps+    Nothing   -> internalError "revDirectDeps" "package not in graph"++-- | Return all the packages in the 'InstallPlan' in reverse topological order.+-- That is, for each package, all dependencies of the package appear first.+--+-- Compared to 'executionOrder', this function returns all the installed and+-- source packages rather than just the source ones. Also, while both this+-- and 'executionOrder' produce reverse topological orderings of the package+-- dependency graph, it is not necessarily exactly the same order.+--+reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg+                        -> [GenericPlanPackage ipkg srcpkg]+reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)+++-- | Return the packages in the plan that depend directly or indirectly on the+-- given packages.+--+reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg+                         -> [UnitId]+                         -> [GenericPlanPackage ipkg srcpkg]+reverseDependencyClosure plan = fromMaybe []+                              . Graph.revClosure (planGraph plan)+++-- Alert alert!   Why does SolverId map to a LIST of plan packages?+-- The sordid story has to do with 'build-depends' on a package+-- with libraries and executables.  In an ideal world, we would+-- ONLY depend on the library in this situation.  But c.f. #3661+-- some people rely on the build-depends to ALSO implicitly+-- depend on an executable.+--+-- I don't want to commit to a strategy yet, so the only possible+-- thing you can do in this case is return EVERYTHING and let+-- the client filter out what they want (executables? libraries?+-- etc).  This similarly implies we can't return a 'ConfiguredId'+-- because that's not enough information.++fromSolverInstallPlan ::+      (IsUnit ipkg, IsUnit srcpkg)+    => (   (SolverId -> [GenericPlanPackage ipkg srcpkg])+        -> SolverInstallPlan.SolverPlanPackage+        -> [GenericPlanPackage ipkg srcpkg]         )+    -> SolverInstallPlan+    -> GenericInstallPlan ipkg srcpkg+fromSolverInstallPlan f plan =+    mkInstallPlan "fromSolverInstallPlan"+      (Graph.fromList pkgs'')+      (SolverInstallPlan.planIndepGoals plan)+  where+    (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])+                        (SolverInstallPlan.reverseTopologicalOrder plan)++    f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)+      where+       pkgs' = f (mapDep pidMap ipiMap) pkg++       (pidMap', ipiMap')+         = case nodeKey pkg of+            PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)+            PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)++    mapDep _ ipiMap (PreExistingId _pid uid)+        | Just pkgs <- Map.lookup uid ipiMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)+    mapDep pidMap _ (PlannedId pid)+        | Just pkgs <- Map.lookup pid pidMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)+    -- This shouldn't happen, since mapDep should only be called+    -- on neighbor SolverId, which must have all been done already+    -- by the reverse top-sort (we assume the graph is not broken).+++fromSolverInstallPlanWithProgress ::+      (IsUnit ipkg, IsUnit srcpkg)+    => (   (SolverId -> [GenericPlanPackage ipkg srcpkg])+        -> SolverInstallPlan.SolverPlanPackage+        -> LogProgress [GenericPlanPackage ipkg srcpkg]         )+    -> SolverInstallPlan+    -> LogProgress (GenericInstallPlan ipkg srcpkg)+fromSolverInstallPlanWithProgress f plan = do+    (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])+                        (SolverInstallPlan.reverseTopologicalOrder plan)+    return $ mkInstallPlan "fromSolverInstallPlanWithProgress"+               (Graph.fromList pkgs'')+               (SolverInstallPlan.planIndepGoals plan)+  where+    f' (pidMap, ipiMap, pkgs) pkg = do+        pkgs' <- f (mapDep pidMap ipiMap) pkg+        let (pidMap', ipiMap')+                 = case nodeKey pkg of+                    PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)+                    PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)+        return (pidMap', ipiMap', pkgs' ++ pkgs)++    mapDep _ ipiMap (PreExistingId _pid uid)+        | Just pkgs <- Map.lookup uid ipiMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)+    mapDep pidMap _ (PlannedId pid)+        | Just pkgs <- Map.lookup pid pidMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)+    -- This shouldn't happen, since mapDep should only be called+    -- on neighbor SolverId, which must have all been done already+    -- by the reverse top-sort (we assume the graph is not broken).++-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.+-- Similar to 'elaboratedInstallPlan'+configureInstallPlan :: SolverInstallPlan -> InstallPlan+configureInstallPlan solverPlan =+    flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->+      [case planpkg of+        SolverInstallPlan.PreExisting pkg ->+          PreExisting (instSolverPkgIPI pkg)++        SolverInstallPlan.Configured  pkg ->+          Configured (configureSolverPackage mapDep pkg)+      ]+  where+    configureSolverPackage :: (SolverId -> [PlanPackage])+                           -> SolverPackage UnresolvedPkgLoc+                           -> ConfiguredPackage UnresolvedPkgLoc+    configureSolverPackage mapDep spkg =+      ConfiguredPackage {+        confPkgId = Configure.computeComponentId+                        Cabal.NoFlag+                        Cabal.NoFlag+                        (packageId spkg)+                        PD.CLibName+                        (Just (map confInstId (CD.libraryDeps deps),+                               solverPkgFlags spkg)),+        confPkgSource = solverPkgSource spkg,+        confPkgFlags  = solverPkgFlags spkg,+        confPkgStanzas = solverPkgStanzas spkg,+        confPkgDeps   = deps+        -- NB: no support for executable dependencies+      }+      where+        deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg)+++-- ------------------------------------------------------------+-- * Primitives for traversing plans+-- ------------------------------------------------------------++-- $traversal+--+-- Algorithms to traverse or execute an 'InstallPlan', especially in parallel,+-- may make use of the 'Processing' type and the associated operations+-- 'ready', 'completed' and 'failed'.+--+-- The 'Processing' type is used to keep track of the state of a traversal and+-- includes the set of packages that are in the processing state, e.g. in the+-- process of being installed, plus those that have been completed and those+-- where processing failed.+--+-- Traversal algorithms start with an 'InstallPlan':+--+-- * Initially there will be certain packages that can be processed immediately+--   (since they are configured source packages and have all their dependencies+--   installed already). The function 'ready' returns these packages plus a+--   'Processing' state that marks these same packages as being in the+--   processing state.+--+-- * The algorithm must now arrange for these packages to be processed+--   (possibly in parallel). When a package has completed processing, the+--   algorithm needs to know which other packages (if any) are now ready to+--   process as a result. The 'completed' function marks a package as completed+--   and returns any packages that are newly in the processing state (ie ready+--   to process), along with the updated 'Processing' state.+--+-- * If failure is possible then when processing a package fails, the algorithm+--   needs to know which other packages have also failed as a result. The+--   'failed' function marks the given package as failed as well as all the+--   other packages that depend on the failed package. In addition it returns+--   the other failed packages.+++-- | The 'Processing' type is used to keep track of the state of a traversal+-- and includes the set of packages that are in the processing state, e.g. in+-- the process of being installed, plus those that have been completed and+-- those where processing failed.+--+data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)+                            -- processing,   completed,    failed++-- | The packages in the plan that are initially ready to be installed.+-- That is they are in the configured state and have all their dependencies+-- installed already.+--+-- The result is both the packages that are now ready to be installed and also+-- a 'Processing' state containing those same packages. The assumption is that+-- all the packages that are ready will now be processed and so we can consider+-- them to be in the processing state.+--+ready :: (IsUnit ipkg, IsUnit srcpkg)+      => GenericInstallPlan ipkg srcpkg+      -> ([GenericReadyPackage srcpkg], Processing)+ready plan =+    assert (processingInvariant plan processing) $+    (readyPackages, processing)+  where+    !processing =+      Processing+        (Set.fromList [ nodeKey pkg | pkg <- readyPackages ])+        (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])+        Set.empty+    readyPackages =+      [ ReadyPackage pkg+      | Configured pkg <- toList plan+      , all isInstalled (directDeps plan (nodeKey pkg))+      ]++isInstalled :: GenericPlanPackage a b -> Bool+isInstalled (PreExisting {}) = True+isInstalled (Installed   {}) = True+isInstalled _                = False++-- | Given a package in the processing state, mark the package as completed+-- and return any packages that are newly in the processing state (ie ready to+-- process), along with the updated 'Processing' state.+--+completed :: (IsUnit ipkg, IsUnit srcpkg)+          => GenericInstallPlan ipkg srcpkg+          -> Processing -> UnitId+          -> ([GenericReadyPackage srcpkg], Processing)+completed plan (Processing processingSet completedSet failedSet) pkgid =+    assert (pkgid `Set.member` processingSet) $+    assert (processingInvariant plan processing') $++    ( map asReadyPackage newlyReady+    , processing' )+  where+    completedSet'  = Set.insert pkgid completedSet++    -- each direct reverse dep where all direct deps are completed+    newlyReady     = [ dep+                     | dep <- revDirectDeps plan pkgid+                     , all ((`Set.member` completedSet') . nodeKey)+                           (directDeps plan (nodeKey dep))+                     ]++    processingSet' = foldl' (flip Set.insert)+                            (Set.delete pkgid processingSet)+                            (map nodeKey newlyReady)+    processing'    = Processing processingSet' completedSet' failedSet++    asReadyPackage (Configured pkg) = ReadyPackage pkg+    asReadyPackage _ = internalError "completed" ""++failed :: (IsUnit ipkg, IsUnit srcpkg)+       => GenericInstallPlan ipkg srcpkg+       -> Processing -> UnitId+       -> ([srcpkg], Processing)+failed plan (Processing processingSet completedSet failedSet) pkgid =+    assert (pkgid `Set.member` processingSet) $+    assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $+    assert (all (`Set.notMember` completedSet)  (tail newlyFailedIds)) $+    -- but note that some newlyFailed may already be in the failed set+    -- since one package can depend on two packages that both fail and+    -- so would be in the rev-dep closure for both.+    assert (processingInvariant plan processing') $++    ( map asConfiguredPackage (tail newlyFailed)+    , processing' )+  where+    processingSet' = Set.delete pkgid processingSet+    failedSet'     = failedSet `Set.union` Set.fromList newlyFailedIds+    newlyFailedIds = map nodeKey newlyFailed+    newlyFailed    = fromMaybe (internalError "failed" "package not in graph")+                   $ Graph.revClosure (planGraph plan) [pkgid]+    processing'    = Processing processingSet' completedSet failedSet'++    asConfiguredPackage (Configured pkg) = pkg+    asConfiguredPackage _ = internalError "failed" "not in configured state"++processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)+                    => GenericInstallPlan ipkg srcpkg+                    -> Processing -> Bool+processingInvariant plan (Processing processingSet completedSet failedSet) =++    -- All the packages in the three sets are actually in the graph+    assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $+    assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $+    assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $++    -- The processing, completed and failed sets are disjoint from each other+    assert (noIntersection processingSet completedSet) $+    assert (noIntersection processingSet failedSet) $+    assert (noIntersection failedSet     completedSet) $++    -- Packages that depend on a package that's still processing cannot be+    -- completed+    assert (noIntersection (reverseClosure processingSet) completedSet) $++    -- On the other hand, packages that depend on a package that's still+    -- processing /can/ have failed (since they may have depended on multiple+    -- packages that were processing, but it only takes one to fail to cause+    -- knock-on failures) so it is quite possible to have an+    -- intersection (reverseClosure processingSet) failedSet++    -- The failed set is upwards closed, i.e. equal to its own rev dep closure+    assert (failedSet == reverseClosure failedSet) $++    -- All immediate reverse deps of packges that are currently processing+    -- are not currently being processed (ie not in the processing set).+    assert (and [ rdeppkgid `Set.notMember` processingSet+                | pkgid     <- Set.toList processingSet+                , rdeppkgid <- maybe (internalError "processingInvariant" "")+                                     (map nodeKey)+                                     (Graph.revNeighbors (planGraph plan) pkgid)+                ]) $++    -- Packages from the processing or failed sets are only ever in the+    -- configured state.+    assert (and [ case Graph.lookup pkgid (planGraph plan) of+                    Just (Configured  _) -> True+                    Just (PreExisting _) -> False+                    Just (Installed   _) -> False+                    Nothing              -> False+                | pkgid <- Set.toList processingSet ++ Set.toList failedSet ])++    -- We use asserts rather than returning False so that on failure we get+    -- better details on which bit of the invariant was violated.+    True+  where+    reverseClosure    = Set.fromList+                      . map nodeKey+                      . fromMaybe (internalError "processingInvariant" "")+                      . Graph.revClosure (planGraph plan)+                      . Set.toList+    noIntersection a b = Set.null (Set.intersection a b)+++-- ------------------------------------------------------------+-- * Traversing plans+-- ------------------------------------------------------------++-- | Flatten an 'InstallPlan', producing the sequence of source packages in+-- the order in which they would be processed when the plan is executed. This+-- can be used for simultations or presenting execution dry-runs.+--+-- It is guaranteed to give the same order as using 'execute' (with a serial+-- in-order 'JobControl'), which is a reverse topological orderings of the+-- source packages in the dependency graph, albeit not necessarily exactly the+-- same ordering as that produced by 'reverseTopologicalOrder'.+--+executionOrder :: (IsUnit ipkg, IsUnit srcpkg)+               => GenericInstallPlan ipkg srcpkg+               -> [GenericReadyPackage srcpkg]+executionOrder plan =+    let (newpkgs, processing) = ready plan+     in tryNewTasks processing newpkgs+  where+    tryNewTasks _processing []       = []+    tryNewTasks  processing (p:todo) = waitForTasks processing p todo++    waitForTasks processing p todo =+        p : tryNewTasks processing' (todo++nextpkgs)+      where+        (nextpkgs, processing') = completed plan processing (nodeKey p)+++-- ------------------------------------------------------------+-- * Executing plans+-- ------------------------------------------------------------++-- | The set of results we get from executing an install plan.+--+type BuildOutcomes failure result = Map UnitId (Either failure result)++-- | Lookup the build result for a single package.+--+lookupBuildOutcome :: HasUnitId pkg+                   => pkg -> BuildOutcomes failure result+                   -> Maybe (Either failure result)+lookupBuildOutcome = Map.lookup . installedUnitId++-- | Execute an install plan. This traverses the plan in dependency order.+--+-- Executing each individual package can fail and if so all dependents fail+-- too. The result for each package is collected as a 'BuildOutcomes' map.+--+-- Visiting each package happens with optional parallelism, as determined by+-- the 'JobControl'. By default, after any failure we stop as soon as possible+-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour+-- can be reversed to keep going and build as many packages as possible.+--+-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages+-- in the plan. In particular in the default mode where we stop as soon as+-- possible after a failure then there may be packages which are skipped and+-- these will have no 'BuildOutcome'.+--+execute :: forall m ipkg srcpkg result failure.+           (IsUnit ipkg, IsUnit srcpkg,+            Monad m)+        => JobControl m (UnitId, Either failure result)+        -> Bool                -- ^ Keep going after failure+        -> (srcpkg -> failure) -- ^ Value for dependents of failed packages+        -> GenericInstallPlan ipkg srcpkg+        -> (GenericReadyPackage srcpkg -> m (Either failure result))+        -> m (BuildOutcomes failure result)+execute jobCtl keepGoing depFailure plan installPkg =+    let (newpkgs, processing) = ready plan+     in tryNewTasks Map.empty False False processing newpkgs+  where+    tryNewTasks :: BuildOutcomes failure result+                -> Bool -> Bool -> Processing+                -> [GenericReadyPackage srcpkg]+                -> m (BuildOutcomes failure result)++    tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs+      -- we were in the process of cancelling and now we're finished+      | tasksFailed && not keepGoing && not tasksRemaining+      = return results++      -- we are still in the process of cancelling, wait for remaining tasks+      | tasksFailed && not keepGoing && tasksRemaining+      = waitForTasks results tasksFailed processing++      -- no new tasks to do and all tasks are done so we're finished+      | null newpkgs && not tasksRemaining+      = return results++      -- no new tasks to do, remaining tasks to wait for+      | null newpkgs+      = waitForTasks results tasksFailed processing++      -- new tasks to do, spawn them, then wait for tasks to complete+      | otherwise+      = do sequence_ [ spawnJob jobCtl $ do+                         result <- installPkg pkg+                         return (nodeKey pkg, result)+                     | pkg <- newpkgs ]+           waitForTasks results tasksFailed processing++    waitForTasks :: BuildOutcomes failure result+                 -> Bool -> Processing+                 -> m (BuildOutcomes failure result)+    waitForTasks !results tasksFailed !processing = do+      (pkgid, result) <- collectJob jobCtl++      case result of++        Right _success -> do+            tasksRemaining <- remainingJobs jobCtl+            tryNewTasks results' tasksFailed tasksRemaining+                        processing' nextpkgs+          where+            results' = Map.insert pkgid result results+            (nextpkgs, processing') = completed plan processing pkgid++        Left _failure -> do+            -- if this is the first failure and we're not trying to keep going+            -- then try to cancel as many of the remaining jobs as possible+            when (not tasksFailed && not keepGoing) $+              cancelJobs jobCtl++            tasksRemaining <- remainingJobs jobCtl+            tryNewTasks results' True tasksRemaining processing' []+          where+            (depsfailed, processing') = failed plan processing pkgid+            results'   = Map.insert pkgid result results `Map.union` depResults+            depResults = Map.fromList+                           [ (nodeKey deppkg, Left (depFailure deppkg))+                           | deppkg <- depsfailed ]++-- ------------------------------------------------------------+-- * Checking validity of plans+-- ------------------------------------------------------------++-- | A valid installation plan is a set of packages that is closed, acyclic+-- and respects the package state relation.+--+-- * if the result is @False@ use 'problems' to get a detailed list.+--+valid :: (IsUnit ipkg, IsUnit srcpkg)+      => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool+valid loc graph =+    case problems graph of+      [] -> True+      ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))++data PlanProblem ipkg srcpkg =+     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg) [UnitId]+   | PackageCycle         [GenericPlanPackage ipkg srcpkg]+   | PackageStateInvalid  (GenericPlanPackage ipkg srcpkg)+                          (GenericPlanPackage ipkg srcpkg)++showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)+                => PlanProblem ipkg srcpkg -> String+showPlanProblem (PackageMissingDeps pkg missingDeps) =+     "Package " ++ display (nodeKey pkg)+  ++ " depends on the following packages which are missing from the plan: "+  ++ intercalate ", " (map display missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (display . nodeKey) cycleGroup)+showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ display (nodeKey pkg)+  ++ " is in the " ++ showPlanPackageTag pkg+  ++ " state but it depends on package " ++ display (nodeKey pkg')+  ++ " which is in the " ++ showPlanPackageTag pkg'+  ++ " state"++-- | For an invalid plan, produce a detailed list of problems as human readable+-- error messages. This is mainly intended for debugging purposes.+-- Use 'showPlanProblem' for a human readable explanation.+--+problems :: (IsUnit ipkg, IsUnit srcpkg)+         => Graph (GenericPlanPackage ipkg srcpkg)+         -> [PlanProblem ipkg srcpkg]+problems graph =++     [ PackageMissingDeps pkg+       (catMaybes+        (map+         (fmap nodeKey . flip Graph.lookup graph)+         missingDeps))+     | (pkg, missingDeps) <- Graph.broken graph ]++  ++ [ PackageCycle cycleGroup+     | cycleGroup <- Graph.cycles graph ]+{-+  ++ [ PackageInconsistency name inconsistencies+     | (name, inconsistencies) <-+       dependencyInconsistencies indepGoals graph ]+     --TODO: consider re-enabling this one, see SolverInstallPlan+-}+  ++ [ PackageStateInvalid pkg pkg'+     | pkg <- Graph.toList graph+     , Just pkg' <- map (flip Graph.lookup graph)+                    (nodeNeighbors pkg)+     , not (stateDependencyRelation pkg pkg') ]++-- | The states of packages have that depend on each other must respect+-- this relation. That is for very case where package @a@ depends on+-- package @b@ we require that @stateDependencyRelation a b = True@.+--+stateDependencyRelation :: GenericPlanPackage ipkg srcpkg+                        -> GenericPlanPackage ipkg srcpkg -> Bool+stateDependencyRelation PreExisting{} PreExisting{} = True++stateDependencyRelation Installed{}   PreExisting{} = True+stateDependencyRelation Installed{}   Installed{}   = True++stateDependencyRelation Configured{}  PreExisting{} = True+stateDependencyRelation Configured{}  Installed{}   = True+stateDependencyRelation Configured{}  Configured{}  = True++stateDependencyRelation _             _             = False
cabal/cabal-install/Distribution/Client/InstallSymlink.hs view
@@ -16,10 +16,11 @@     symlinkBinary,   ) where -#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS -import Distribution.Package (PackageIdentifier)+import Distribution.Package (PackageIdentifier, UnqualComponentName) import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Types (BuildOutcomes) import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler@@ -28,33 +29,36 @@ symlinkBinaries :: Platform -> Compiler                 -> ConfigFlags                 -> InstallFlags-                -> InstallPlan -                -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries _ _ _ _ _ = return []+                -> InstallPlan+                -> BuildOutcomes+                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]+symlinkBinaries _ _ _ _ _ _ = return [] -symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool+symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"  #else  import Distribution.Client.Types-         ( SourcePackage(..)-         , GenericReadyPackage(..), ReadyPackage, enableStanzas-         , ConfiguredPackage(..) , fakeUnitId)+         ( ConfiguredPackage(..), BuildOutcomes ) import Distribution.Client.Setup          ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Solver.Types.SourcePackage+import Distribution.Solver.Types.OptionalStanza+ import Distribution.Package-         ( PackageIdentifier, Package(packageId), UnitId(..) )+         ( PackageIdentifier, UnqualComponentName, unUnqualComponentName+         , Package(packageId), UnitId, installedUnitId ) import Distribution.Compiler          ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription          ( PackageDescription ) import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )+         ( finalizePD ) import Distribution.Simple.Setup          ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs@@ -62,6 +66,8 @@          ( Compiler, compilerInfo, CompilerInfo(..) ) import Distribution.System          ( Platform )+import Distribution.Text+         ( display )  import System.Posix.Files          ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink@@ -104,8 +110,9 @@                 -> ConfigFlags                 -> InstallFlags                 -> InstallPlan-                -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries platform comp configFlags installFlags plan =+                -> BuildOutcomes+                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]+symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =   case flagToMaybe (installSymlinkBinDir installFlags) of     Nothing            -> return []     Just symlinkBinDir@@ -123,30 +130,32 @@                then return Nothing                else return (Just (pkgid, publicExeName,                                   privateBinDir </> privateExeName))-        | (ReadyPackage _cpkg, pkg, exe) <- exes+        | (rpkg, pkg, exe) <- exes         , let pkgid  = packageId pkg               -- This is a bit dodgy; probably won't work for Backpack packages-              ipid = fakeUnitId pkgid+              ipid = installedUnitId rpkg               publicExeName  = PackageDescription.exeName exe-              privateExeName = prefix ++ publicExeName ++ suffix+              privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix               prefix = substTemplate pkgid ipid prefixTemplate               suffix = substTemplate pkgid ipid suffixTemplate ]   where     exes =       [ (cpkg, pkg, exe)-      | InstallPlan.Installed cpkg _ _ <- InstallPlan.toList plan-      , let pkg   = pkgDescription cpkg+      | InstallPlan.Configured cpkg <- InstallPlan.toList plan+      , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of+          Just (Right _success) -> True+          _                     -> False+      , let pkg :: PackageDescription+            pkg = pkgDescription cpkg       , exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe) ] -    pkgDescription :: ReadyPackage -> PackageDescription-    pkgDescription (ReadyPackage (ConfiguredPackage-                                    (SourcePackage _ pkg _ _)-                                    flags stanzas _)) =-      case finalizePackageDescription flags+    pkgDescription (ConfiguredPackage _ (SourcePackage _ pkg _ _)+                                      flags stanzas _) =+      case finalizePD flags (enableStanzas stanzas)              (const True)-             platform cinfo [] (enableStanzas stanzas pkg) of-        Left _ -> error "finalizePackageDescription ReadyPackage failed"+             platform cinfo [] pkg of+        Left _ -> error "finalizePD ReadyPackage failed"         Right (desc, _) -> desc      -- This is sadly rather complicated. We're kind of re-doing part of the@@ -176,30 +185,32 @@     cinfo            = compilerInfo comp     (CompilerId compilerFlavor _) = compilerInfoId cinfo -symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir-                          --   eg @/home/user/bin@-              -> FilePath -- ^ The canonical path of the private bin dir-                          --   eg @/home/user/.cabal/bin@-              -> String   -- ^ The name of the executable to go in the public-                          --   bin dir, eg @foo@-              -> String   -- ^ The name of the executable to in the private bin-                          --   dir, eg @foo-1.0@-              -> IO Bool  -- ^ If creating the symlink was successful. @False@-                          --   if there was another file there already that we-                          --   did not own. Other errors like permission errors-                          --   just propagate as exceptions.+symlinkBinary ::+  FilePath               -- ^ The canonical path of the public bin dir eg+                         --   @/home/user/bin@+  -> FilePath            -- ^ The canonical path of the private bin dir eg+                         --   @/home/user/.cabal/bin@+  -> UnqualComponentName -- ^ The name of the executable to go in the public bin+                         --   dir, eg @foo@+  -> String              -- ^ The name of the executable to in the private bin+                         --   dir, eg @foo-1.0@+  -> IO Bool             -- ^ If creating the symlink was successful. @False@ if+                         --   there was another file there already that we did+                         --   not own. Other errors like permission errors just+                         --   propagate as exceptions. symlinkBinary publicBindir privateBindir publicName privateName = do-  ok <- targetOkToOverwrite (publicBindir </> publicName)+  ok <- targetOkToOverwrite (publicBindir </> publicName')                             (privateBindir </> privateName)   case ok of     NotOurFile    ->                     return False     NotExists     ->           mkLink >> return True     OkToOverwrite -> rmLink >> mkLink >> return True   where+    publicName' = display publicName     relativeBindir = makeRelative publicBindir privateBindir     mkLink = createSymbolicLink (relativeBindir </> privateName)-                                (publicBindir   </> publicName)-    rmLink = removeLink (publicBindir </> publicName)+                                (publicBindir   </> publicName')+    rmLink = removeLink (publicBindir </> publicName')  -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or
cabal/cabal-install/Distribution/Client/JobControl.hs view
@@ -16,6 +16,8 @@     newParallelJobControl,     spawnJob,     collectJob,+    remainingJobs,+    cancelJobs,      JobLimit,     newJobLimit,@@ -27,48 +29,131 @@   ) where  import Control.Monad-import Control.Concurrent hiding (QSem, newQSem, waitQSem, signalQSem)-import Control.Exception (SomeException, bracket_, mask, throw, try)+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+import Control.Concurrent.STM (STM, atomically)+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Exception (SomeException, bracket_, throwIO, try) import Distribution.Client.Compat.Semaphore ++-- | A simple concurrency abstraction. Jobs can be spawned and can complete+-- in any order. This allows both serial and parallel implementations.+-- data JobControl m a = JobControl {+       -- | Add a new job to the pool of jobs        spawnJob    :: m a -> m (),-       collectJob  :: m a++       -- | Wait until one job is complete+       collectJob  :: m a,++       -- | Returns True if there are any outstanding jobs+       -- (ie spawned but yet to be collected)+       remainingJobs :: m Bool,++       -- | Try to cancel any outstanding but not-yet-started jobs.+       -- Call 'remainingJobs' after this to find out if any jobs are left+       -- (ie could not be cancelled).+       cancelJobs  :: m ()      }  +-- | Make a 'JobControl' that executes all jobs serially and in order.+-- It only executes jobs on demand when they are collected, not eagerly.+--+-- Cancelling will cancel /all/ jobs that have not been collected yet.+-- newSerialJobControl :: IO (JobControl IO a) newSerialJobControl = do-    queue <- newChan+    qVar <- newTChanIO     return JobControl {-      spawnJob   = spawn queue,-      collectJob = collect queue+      spawnJob      = spawn     qVar,+      collectJob    = collect   qVar,+      remainingJobs = remaining qVar,+      cancelJobs    = cancel    qVar     }   where-    spawn :: Chan (IO a) -> IO a -> IO ()-    spawn = writeChan+    spawn :: TChan (IO a) -> IO a -> IO ()+    spawn qVar job = atomically $ writeTChan qVar job -    collect :: Chan (IO a) -> IO a-    collect = join . readChan+    collect :: TChan (IO a) -> IO a+    collect qVar =+      join $ atomically $ readTChan qVar -newParallelJobControl :: IO (JobControl IO a)-newParallelJobControl = do-    resultVar <- newEmptyMVar+    remaining :: TChan (IO a) -> IO Bool+    remaining qVar  = fmap not $ atomically $ isEmptyTChan qVar++    cancel :: TChan (IO a) -> IO ()+    cancel qVar = do+      _ <- atomically $ readAllTChan qVar+      return ()++-- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given+-- maximum degree of parallelism.+--+-- Cancelling will cancel jobs that have not yet begun executing, but jobs+-- that have already been executed or are currently executing cannot be+-- cancelled.+--+newParallelJobControl :: Int -> IO (JobControl IO a)+newParallelJobControl n | n < 1 || n > 1000 =+  error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n+newParallelJobControl maxJobLimit = do+    inqVar   <- newTChanIO+    outqVar  <- newTChanIO+    countVar <- newTVarIO 0+    replicateM_ maxJobLimit $+      forkIO $+        worker inqVar outqVar     return JobControl {-      spawnJob   = spawn resultVar,-      collectJob = collect resultVar+      spawnJob      = spawn   inqVar  countVar,+      collectJob    = collect outqVar countVar,+      remainingJobs = remaining       countVar,+      cancelJobs    = cancel  inqVar  countVar     }   where-    spawn :: MVar (Either SomeException a) -> IO a -> IO ()-    spawn resultVar job =-      mask $ \restore ->-        forkIO (do res <- try (restore job)-                   putMVar resultVar res)-         >> return ()+    worker ::  TChan (IO a) -> TChan (Either SomeException a) -> IO ()+    worker inqVar outqVar =+      forever $ do+        job <- atomically $ readTChan inqVar+        res <- try job+        atomically $ writeTChan outqVar res -    collect :: MVar (Either SomeException a) -> IO a-    collect resultVar =-      takeMVar resultVar >>= either throw return+    spawn :: TChan (IO a) -> TVar Int -> IO a -> IO ()+    spawn inqVar countVar job =+      atomically $ do+        modifyTVar' countVar (+1)+        writeTChan inqVar job++    collect :: TChan (Either SomeException a) -> TVar Int -> IO a+    collect outqVar countVar = do+      res <- atomically $ do+        modifyTVar' countVar (subtract 1)+        readTChan outqVar+      either throwIO return res++    remaining :: TVar Int -> IO Bool+    remaining countVar = fmap (/=0) $ atomically $ readTVar countVar++    cancel :: TChan (IO a) -> TVar Int -> IO ()+    cancel inqVar countVar =+      atomically $ do+        xs <- readAllTChan inqVar+        modifyTVar' countVar (subtract (length xs))++readAllTChan :: TChan a -> STM [a]+readAllTChan qvar = go []+  where+    go xs = do+      mx <- tryReadTChan qvar+      case mx of+        Nothing -> return (reverse xs)+        Just x  -> go (x:xs)++-------------------------+-- Job limits and locks+--  data JobLimit = JobLimit QSem
cabal/cabal-install/Distribution/Client/List.hs view
@@ -14,7 +14,8 @@   ) where  import Distribution.Package-         ( PackageName(..), Package(..), packageName, packageVersion+         ( PackageName, UnqualComponentName+         , Package(..), packageName, packageVersion          , Dependency(..), simplifyDependency          , UnitId ) import Distribution.ModuleName (ModuleName)@@ -22,31 +23,32 @@ import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.PackageDescription   as Source import Distribution.PackageDescription-         ( Flag(..), FlagName(..) )+         ( Flag(..), unFlagName ) import Distribution.PackageDescription.Configuration          ( flattenPackageDescription )  import Distribution.Simple.Compiler         ( Compiler, PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration)+import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Utils         ( equating, comparing, die, notice ) import Distribution.Simple.Setup (fromFlag) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version-         ( Version(..), VersionRange, withinRange, anyVersion+         ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion          , intersectVersionRanges, simplifyVersionRange ) import Distribution.Verbosity (Verbosity) import Distribution.Text          ( Text(disp), display ) +import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.SourcePackage+ import Distribution.Client.Types-         ( SourcePackage(..), SourcePackageDb(..)+         ( SourcePackageDb(..)          , UnresolvedSourcePackage )-import Distribution.Client.Dependency.Types-         ( PackageConstraint(..) ) import Distribution.Client.Targets          ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup@@ -62,7 +64,7 @@ import Data.List          ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition ) import Data.Maybe-         ( listToMaybe, fromJust, fromMaybe, isJust )+         ( listToMaybe, fromJust, fromMaybe, isJust, maybeToList ) import qualified Data.Map as Map import Data.Tree as Tree import Control.Monad@@ -79,12 +81,12 @@            -> PackageDBStack            -> RepoContext            -> Compiler-           -> ProgramConfiguration+           -> ProgramDb            -> ListFlags            -> [String]            -> IO [PackageDisplayInfo]-getPkgList verbosity packageDBs repoCtxt comp conf listFlags pats = do-    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion@@ -135,12 +137,12 @@      -> PackageDBStack      -> RepoContext      -> Compiler-     -> ProgramConfiguration+     -> ProgramDb      -> ListFlags      -> [String]      -> IO ()-list verbosity packageDBs repos comp conf listFlags pats = do-    matches <- getPkgList verbosity packageDBs repos comp conf listFlags pats+list verbosity packageDBs repos comp progdb listFlags pats = do+    matches <- getPkgList verbosity packageDBs repos comp progdb listFlags pats      if simpleOutput       then putStr $ unlines@@ -165,7 +167,7 @@      -> PackageDBStack      -> RepoContext      -> Compiler-     -> ProgramConfiguration+     -> ProgramDb      -> GlobalFlags      -> InfoFlags      -> [UserTarget]@@ -173,10 +175,10 @@ info verbosity _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -info verbosity packageDBs repoCtxt comp conf+info verbosity packageDBs repoCtxt comp progdb      globalFlags _listFlags userTargets = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion@@ -286,7 +288,7 @@     flags             :: [Flag],     hasLib            :: Bool,     hasExe            :: Bool,-    executables       :: [String],+    executables       :: [UnqualComponentName],     modules           :: [ModuleName],     haddockHtml       :: FilePath,     haveTarball       :: Bool@@ -347,7 +349,7 @@    , entry "Author"        author       hideIfNull     reflowLines    , entry "Maintainer"    maintainer   hideIfNull     reflowLines    , entry "Source repo"   sourceRepo   orNotSpecified text-   , entry "Executables"   executables  hideIfNull     (commaSep text)+   , entry "Executables"   executables  hideIfNull     (commaSep disp)    , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)    , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)    , entry "Documentation" haddockHtml  showIfInstalled text@@ -379,7 +381,7 @@     orNotSpecified = altText null "[ Not specified ]"      commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f-    dispFlag f = case flagName f of FlagName n -> text n+    dispFlag = text . unFlagName . flagName     dispYesNo True  = text "Yes"     dispYesNo False = text "No" @@ -457,13 +459,14 @@     flags        = maybe [] Source.genPackageFlags sourceGeneric,     hasLib       = isJust installed                 || fromMaybe False-                   (fmap (not . null . Source.condLibraries) sourceGeneric),+                   (fmap (isJust . Source.condLibrary) sourceGeneric),     hasExe       = fromMaybe False                    (fmap (not . null . Source.condExecutables) sourceGeneric),     executables  = map fst (maybe [] Source.condExecutables sourceGeneric),     modules      = combine (map Installed.exposedName . Installed.exposedModules)                            installed-                           (concatMap getListOfExposedModules . Source.libraries)+                           -- NB: only for the PUBLIC library+                           (concatMap getListOfExposedModules . maybeToList . Source.library)                            source,     dependencies =       combine (map (SourceDependency . simplifyDependency)@@ -568,13 +571,13 @@ -- interestingVersions :: (Version -> Bool) -> [Version] -> [Version] interestingVersions pref =-      map ((\ns -> Version ns []) . fst) . filter snd+      map (mkVersion . fst) . filter snd     . concat  . Tree.levels     . swizzleTree-    . reorderTree (\(Node (v,_) _) -> pref (Version v []))+    . reorderTree (\(Node (v,_) _) -> pref (mkVersion v))     . reverseTree     . mkTree-    . map versionBranch+    . map versionNumbers    where     swizzleTree = unfoldTree (spine [])
cabal/cabal-install/Distribution/Client/Manpage.hs view
@@ -56,7 +56,7 @@   , "installing existing packages and developing new packages. "   , "It can be used to work with local packages or to install packages from online package archives, "   , "including automatically installing dependencies. By default it is configured to use Hackage, "-  , "which is Haskell’s central package archive that contains thousands of libraries and applications "+  , "which is Haskell's central package archive that contains thousands of libraries and applications "   , "in the Cabal package format."   , ".SH OPTIONS"   , "Global options:"
cabal/cabal-install/Distribution/Client/PackageHash.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}  -- | Functions to calculate nix-style hashes for package ids. --@@ -16,20 +17,25 @@     hashedInstalledPackageId,     hashPackageHashInputs,     renderPackageHashInputs,+    -- ** Platform-specific variations+    hashedInstalledPackageIdLong,+    hashedInstalledPackageIdShort,      -- * Low level hash choice     HashValue,     hashValue,     showHashValue,-    readFileHashValue+    readFileHashValue,+    hashFromTUF,   ) where  import Distribution.Package-         ( PackageId, mkUnitId )+         ( PackageId, PackageIdentifier(..), mkComponentId+         , PkgconfigName ) import Distribution.System-         ( Platform )+         ( Platform, OS(Windows), buildOS ) import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )+         ( unFlagName, FlagAssignment ) import Distribution.Simple.Compiler          ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)          , ProfDetailLevel(..), showProfDetailLevel )@@ -37,18 +43,25 @@          ( PathTemplate, fromPathTemplate ) import Distribution.Text          ( display )+import Distribution.Version import Distribution.Client.Types          ( InstalledPackageId )+import qualified Distribution.Solver.Types.ComponentDeps as CD +import qualified Hackage.Security.Client    as Sec++import qualified Crypto.Hash.SHA256         as SHA256+import qualified Data.ByteString.Base16     as Base16 import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as LBS-import qualified Crypto.Hash                as Hash-import qualified Data.Byteable              as Hash+import qualified Data.Map as Map import qualified Data.Set as Set import           Data.Set (Set) +import Data.Typeable import Data.Maybe        (catMaybes) import Data.List         (sortBy, intercalate)+import Data.Map          (Map) import Data.Function     (on) import Distribution.Compat.Binary (Binary(..)) import Control.Exception (evaluate)@@ -62,19 +75,74 @@ -- | Calculate a 'InstalledPackageId' for a package using our nix-style -- inputs hashing method. --+-- Note that due to path length limitations on Windows, this function uses+-- a different method on Windows that produces shorted package ids.+-- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'.+-- hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId-hashedInstalledPackageId pkghashinputs@PackageHashInputs{pkgHashPkgId} =-    mkUnitId $+hashedInstalledPackageId+  | buildOS == Windows = hashedInstalledPackageIdShort+  | otherwise          = hashedInstalledPackageIdLong++-- | Calculate a 'InstalledPackageId' for a package using our nix-style+-- inputs hashing method.+--+-- This produces large ids with big hashes. It is only suitable for systems+-- without significant path length limitations (ie not Windows).+--+hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageIdLong pkghashinputs@PackageHashInputs{pkgHashPkgId} =+    mkComponentId $          display pkgHashPkgId   -- to be a bit user friendly       ++ "-"       ++ showHashValue (hashPackageHashInputs pkghashinputs) +-- | On Windows we have serious problems with path lengths. Windows imposes a+-- maximum path length of 260 chars, and even if we can use the windows long+-- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all+-- do so too.+--+-- So our only choice is to limit the lengths of the paths, and the only real+-- way to do that is to limit the size of the 'InstalledPackageId's that we+-- generate. We do this by truncating the package names and versions and also+-- by truncating the hash sizes.+--+-- Truncating the package names and versions is technically ok because they are+-- just included for human convenience, the full source package id is included+-- in the hash.+--+-- Truncating the hash size is disappointing but also technically ok. We+-- rely on the hash primarily for collision avoidance not for any security+-- properties (at least for now).+--+hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =+    mkComponentId $+      intercalate "-"+        -- max length now 64+        [ truncateStr 14 (display name)+        , truncateStr  8 (display version)+        , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs))+        ]+  where+    PackageIdentifier name version = pkgHashPkgId++    -- Truncate a 32 byte SHA256 hash to 160bits, 20 bytes :-(+    -- It'll render as 40 hex chars.+    truncateHash (HashValue h) = HashValue (BS.take 20 h)++    -- Truncate a string, with a visual indication that it is truncated.+    truncateStr n s | length s <= n = s+                    | otherwise     = take (n-1) s ++ "_"+ -- | All the information that contribues to a package's hash, and thus its -- 'InstalledPackageId'. -- data PackageHashInputs = PackageHashInputs {        pkgHashPkgId         :: PackageId,+       pkgHashComponent     :: Maybe CD.Component,        pkgHashSourceHash    :: PackageSourceHash,+       pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe Version),        pkgHashDirectDeps    :: Set InstalledPackageId,        pkgHashOtherConfig   :: PackageHashConfigInputs      }@@ -103,6 +171,7 @@        pkgHashStripLibs           :: Bool,        pkgHashStripExes           :: Bool,        pkgHashDebugInfo           :: DebugInfoLevel,+       pkgHashProgramArgs         :: Map String [String],        pkgHashExtraLibDirs        :: [FilePath],        pkgHashExtraFrameworkDirs  :: [FilePath],        pkgHashExtraIncludeDirs    :: [FilePath],@@ -128,8 +197,10 @@ renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString renderPackageHashInputs PackageHashInputs{                           pkgHashPkgId,+                          pkgHashComponent,                           pkgHashSourceHash,                           pkgHashDirectDeps,+                          pkgHashPkgConfigDeps,                           pkgHashOtherConfig =                             PackageHashConfigInputs{..}                         } =@@ -147,9 +218,16 @@     --TODO: [nice to have] ultimately we probably want to put this config info     -- into the ghc-pkg db. At that point this should probably be changed to     -- use the config file infrastructure so it can be read back in again.-    LBS.pack $ unlines $ catMaybes+    LBS.pack $ unlines $ catMaybes $       [ entry "pkgid"       display pkgHashPkgId+      , mentry "component"  show pkgHashComponent       , entry "src"         showHashValue pkgHashSourceHash+      , entry "pkg-config-deps"+                            (intercalate ", " . map (\(pn, mb_v) -> display pn +++                                                    case mb_v of+                                                        Nothing -> ""+                                                        Just v -> " " ++ display v)+                                              . Set.toList) pkgHashPkgConfigDeps       , entry "deps"        (intercalate ", " . map display                                               . Set.toList) pkgHashDirectDeps         -- and then all the config@@ -176,17 +254,18 @@       , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs       , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix       , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix-      ]+      ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs   where     entry key     format value = Just (key ++ ": " ++ format value)+    mentry key    format value = fmap (\v -> key ++ ": " ++ format v) value     opt   key def format value          | value == def = Nothing          | otherwise    = entry key format value      showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst)       where-        showEntry (FlagName name, False) = '-' : name-        showEntry (FlagName name, True)  = '+' : name+        showEntry (fname, False) = '-' : unFlagName fname+        showEntry (fname, True)  = '+' : unFlagName fname  ----------------------------------------------- -- The specific choice of hash implementation@@ -202,25 +281,44 @@ -- there is some value in preventing intentional hash collisions in installed -- package ids. -newtype HashValue = HashValue (Hash.Digest Hash.SHA256)-  deriving (Eq, Show)+newtype HashValue = HashValue BS.ByteString+  deriving (Eq, Show, Typeable)  instance Binary HashValue where-  put (HashValue digest) = put (Hash.toBytes digest)+  put (HashValue digest) = put digest   get = do-    bs <- get-    case Hash.digestFromByteString bs of-      Nothing     -> fail "HashValue: bad digest"-      Just digest -> return (HashValue digest)+    digest <- get+    -- Cannot do any sensible validation here. Although we use SHA256+    -- for stuff we hash ourselves, we can also get hashes from TUF+    -- and that can in principle use different hash functions in future.+    return (HashValue digest) +-- | Hash some data. Currently uses SHA256.+-- hashValue :: LBS.ByteString -> HashValue-hashValue = HashValue . Hash.hashlazy+hashValue = HashValue . SHA256.hashlazy  showHashValue :: HashValue -> String-showHashValue (HashValue digest) = BS.unpack (Hash.digestToHexByteString digest)+showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) +-- | Hash the content of a file. Uses SHA256.+-- readFileHashValue :: FilePath -> IO HashValue readFileHashValue tarball =     withBinaryFile tarball ReadMode $ \hnd ->       evaluate . hashValue =<< LBS.hGetContents hnd++-- | Convert a hash from TUF metadata into a 'PackageSourceHash'.+--+-- Note that TUF hashes don't neessarily have to be SHA256, since it can+-- support new algorithms in future.+--+hashFromTUF :: Sec.Hash -> HashValue+hashFromTUF (Sec.Hash hashstr) =+    --TODO: [code cleanup] either we should get TUF to use raw bytestrings or+    -- perhaps we should also just use a base16 string as the internal rep.+    case Base16.decode (BS.pack hashstr) of+      (hash, trailing) | not (BS.null hash) && BS.null trailing+        -> HashValue hash+      _ -> error "hashFromTUF: cannot decode base16 hash"
− cabal/cabal-install/Distribution/Client/PackageIndex.hs 
@@ -1,318 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.PackageIndex--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ An index of packages.----module Distribution.Client.PackageIndex (-  -- * Package index data type-  PackageIndex,--  -- * Creating an index-  fromList,--  -- * Updates-  merge,-  insert,-  deletePackageName,-  deletePackageId,-  deleteDependency,--  -- * Queries--  -- ** Precise lookups-  elemByPackageId,-  elemByPackageName,-  lookupPackageName,-  lookupPackageId,-  lookupDependency,--  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,--  -- ** Bulk queries-  allPackages,-  allPackagesByName,-  ) where--import Prelude hiding (lookup)-import Control.Exception (assert)-import qualified Data.Map as Map-import Data.Map (Map)-import Data.List (groupBy, sortBy, isInfixOf)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif-import Data.Maybe (isJust, fromMaybe)-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)-import Distribution.Compat.Semigroup (Semigroup((<>)))--import Distribution.Package-         ( PackageName(..), PackageIdentifier(..)-         , Package(..), packageName, packageVersion-         , Dependency(Dependency) )-import Distribution.Version-         ( withinRange )-import Distribution.Simple.Utils-         ( lowercase, comparing )----- | The collection of information about packages from one or more 'PackageDB's.------ It can be searched efficiently by package name and version.----newtype PackageIndex pkg = PackageIndex-  -- This index package names to all the package records matching that package-  -- name case-sensitively. It includes all versions.-  ---  -- This allows us to find all versions satisfying a dependency.-  -- Most queries are a map lookup followed by a linear scan of the bucket.-  ---  (Map PackageName [pkg])--  deriving (Eq, Show, Read, Functor, Generic)---FIXME: the Functor instance here relies on no package id changes--instance Package pkg => Semigroup (PackageIndex pkg) where-  (<>) = merge--instance Package pkg => Monoid (PackageIndex pkg) where-  mempty  = PackageIndex Map.empty-  mappend = (<>)-  --save one mappend with empty in the common case:-  mconcat [] = mempty-  mconcat xs = foldr1 mappend xs--instance Binary pkg => Binary (PackageIndex pkg)--invariant :: Package pkg => PackageIndex pkg -> Bool-invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)-  where-    goodBucket _    [] = False-    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0-      where-        check pkgid []          = packageName pkgid == name-        check pkgid (pkg':pkgs) = packageName pkgid == name-                               && pkgid < pkgid'-                               && check pkgid' pkgs-          where pkgid' = packageId pkg'------- * Internal helpers-----mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg-mkPackageIndex index = assert (invariant (PackageIndex index))-                                         (PackageIndex index)--internalError :: String -> a-internalError name = error ("PackageIndex." ++ name ++ ": internal error")---- | Lookup a name in the index to get all packages that match that name--- case-sensitively.----lookup :: PackageIndex pkg -> PackageName -> [pkg]-lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m------- * Construction------- | Build an index out of a bunch of packages.------ If there are duplicates, later ones mask earlier ones.----fromList :: Package pkg => [pkg] -> PackageIndex pkg-fromList pkgs = mkPackageIndex-              . Map.map fixBucket-              . Map.fromListWith (++)-              $ [ (packageName pkg, [pkg])-                | pkg <- pkgs ]-  where-    fixBucket = -- out of groups of duplicates, later ones mask earlier ones-                -- but Map.fromListWith (++) constructs groups in reverse order-                map head-                -- Eq instance for PackageIdentifier is wrong, so use Ord:-              . groupBy (\a b -> EQ == comparing packageId a b)-                -- relies on sortBy being a stable sort so we-                -- can pick consistently among duplicates-              . sortBy (comparing packageId)------- * Updates------- | Merge two indexes.------ Packages from the second mask packages of the same exact name--- (case-sensitively) from the first.----merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg-merge i1@(PackageIndex m1) i2@(PackageIndex m2) =-  assert (invariant i1 && invariant i2) $-    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)---- | Elements in the second list mask those in the first.-mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]-mergeBuckets []     ys     = ys-mergeBuckets xs     []     = xs-mergeBuckets xs@(x:xs') ys@(y:ys') =-      case packageId x `compare` packageId y of-        GT -> y : mergeBuckets xs  ys'-        EQ -> y : mergeBuckets xs' ys'-        LT -> x : mergeBuckets xs' ys---- | Inserts a single package into the index.------ This is equivalent to (but slightly quicker than) using 'mappend' or--- 'merge' with a singleton index.----insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg-insert pkg (PackageIndex index) = mkPackageIndex $-  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index-  where-    pkgid = packageId pkg-    insertNoDup []                = [pkg]-    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of-      LT -> pkg  : pkgs-      EQ -> pkg  : pkgs'-      GT -> pkg' : insertNoDup pkgs'---- | Internal delete helper.----delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg-delete name p (PackageIndex index) = mkPackageIndex $-  Map.update filterBucket name index-  where-    filterBucket = deleteEmptyBucket-                 . filter (not . p)-    deleteEmptyBucket []        = Nothing-    deleteEmptyBucket remaining = Just remaining---- | Removes a single package from the index.----deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg-deletePackageId pkgid =-  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)---- | Removes all packages with this (case-sensitive) name from the index.----deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg-deletePackageName name =-  delete name (\pkg -> packageName pkg == name)---- | Removes all packages satisfying this dependency from the index.----deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg-deleteDependency (Dependency name verstionRange) =-  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)------- * Bulk queries------- | Get all the packages from the index.----allPackages :: PackageIndex pkg -> [pkg]-allPackages (PackageIndex m) = concat (Map.elems m)---- | Get all the packages from the index.------ They are grouped by package name, case-sensitively.----allPackagesByName :: PackageIndex pkg -> [[pkg]]-allPackagesByName (PackageIndex m) = Map.elems m------- * Lookups-----elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool-elemByPackageId index = isJust . lookupPackageId index--elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool-elemByPackageName index = not . null . lookupPackageName index----- | Does a lookup by package id (name & version).------ Since multiple package DBs mask each other case-sensitively by package name,--- then we get back at most one package.----lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg-lookupPackageId index pkgid =-  case [ pkg | pkg <- lookup index (packageName pkgid)-             , packageId pkg == pkgid ] of-    []    -> Nothing-    [pkg] -> Just pkg-    _     -> internalError "lookupPackageIdentifier"---- | Does a case-sensitive search by package name.----lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]-lookupPackageName index name =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name ]---- | Does a case-sensitive search by package name and a range of versions.------ We get back any number of versions of the specified package name, all--- satisfying the version range constraint.----lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]-lookupDependency index (Dependency name versionRange) =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name-        , packageVersion pkg `withinRange` versionRange ]------- * Case insensitive name lookups------- | Does a case-insensitive search by package name.------ If there is only one package that compares case-insensitively to this name--- then the search is unambiguous and we get back all versions of that package.--- If several match case-insensitively but one matches exactly then it is also--- unambiguous.------ If however several match case-insensitively and none match exactly then we--- have an ambiguous result, and we get back all the versions of all the--- packages. The list of ambiguous results is split by exact package name. So--- it is a non-empty list of non-empty lists.----searchByName :: PackageIndex pkg-             -> String -> [(PackageName, [pkg])]-searchByName (PackageIndex m) name =-    [ pkgs-    | pkgs@(PackageName name',_) <- Map.toList m-    , lowercase name' == lname ]-  where-    lname = lowercase name--data SearchResult a = None | Unambiguous a | Ambiguous [a]---- | Does a case-insensitive substring search by package name.------ That is, all packages that contain the given string in their name.----searchByNameSubstring :: PackageIndex pkg-                      -> String -> [(PackageName, [pkg])]-searchByNameSubstring (PackageIndex m) searchterm =-    [ pkgs-    | pkgs@(PackageName name, _) <- Map.toList m-    , lsearchterm `isInfixOf` lowercase name ]-  where-    lsearchterm = lowercase searchterm
cabal/cabal-install/Distribution/Client/PackageUtils.hs view
@@ -15,7 +15,7 @@   ) where  import Distribution.Package-         ( packageVersion, packageName, Dependency(..), PackageName(..) )+         ( packageVersion, packageName, Dependency(..), packageNameToUnqualComponentName ) import Distribution.PackageDescription          ( PackageDescription(..), libName ) import Distribution.Version@@ -32,5 +32,5 @@     internal (Dependency depName versionRange) =            (depName == packageName pkg &&             packageVersion pkg `withinRange` versionRange) ||-           (unPackageName depName `elem` map libName (libraries pkg) &&+           (Just (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) &&             isAnyVersion versionRange)
cabal/cabal-install/Distribution/Client/ParseUtils.hs view
@@ -92,7 +92,7 @@ -- SectionDescr definition and utilities -- --- | The description of a section in a config file. It can contains both+-- | The description of a section in a config file. It can contain both -- fields and optionally further subsections. See also 'FieldDescr'. -- data SectionDescr a = forall b. SectionDescr {
− cabal/cabal-install/Distribution/Client/PkgConfigDb.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.PkgConfigDb--- Copyright   :  (c) Iñaki García Etxebarria 2016--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Read the list of packages available to pkg-config.-------------------------------------------------------------------------------module Distribution.Client.PkgConfigDb-    (-     PkgConfigDb-    , readPkgConfigDb-    , pkgConfigDbFromList-    , pkgConfigPkgIsPresent-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Control.Exception (IOException, handle)-import Data.Char (isSpace)-import qualified Data.Map as M-import Data.Version (parseVersion)-import Text.ParserCombinators.ReadP (readP_to_S)--import Distribution.Package-    ( PackageName(..) )-import Distribution.Verbosity-    ( Verbosity )-import Distribution.Version-    ( Version, VersionRange, withinRange )--import Distribution.Simple.Program-    ( ProgramConfiguration, pkgConfigProgram, getProgramOutput,-      requireProgram )-import Distribution.Simple.Utils-    ( info )---- | The list of packages installed in the system visible to--- @pkg-config@. This is an opaque datatype, to be constructed with--- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`.-data PkgConfigDb =  PkgConfigDb (M.Map PackageName (Maybe Version))-                 -- ^ If an entry is `Nothing`, this means that the-                 -- package seems to be present, but we don't know the-                 -- exact version (because parsing of the version-                 -- number failed).-                 | NoPkgConfigDb-                 -- ^ For when we could not run pkg-config successfully.-     deriving (Show)---- | Query pkg-config for the list of installed packages, together--- with their versions. Return a `PkgConfigDb` encapsulating this--- information.-readPkgConfigDb :: Verbosity -> ProgramConfiguration -> IO PkgConfigDb-readPkgConfigDb verbosity conf = handle ioErrorHandler $ do-  (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram conf-  pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]-  -- The output of @pkg-config --list-all@ also includes a description-  -- for each package, which we do not need.-  let pkgNames = map (takeWhile (not . isSpace)) pkgList-  pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig-                             ("--modversion" : pkgNames)-  (return . pkgConfigDbFromList . zip pkgNames) pkgVersions-      where-        -- For when pkg-config invocation fails (possibly because of a-        -- too long command line).-        ioErrorHandler :: IOException -> IO PkgConfigDb-        ioErrorHandler e = do-          info verbosity ("Failed to query pkg-config, Cabal will continue"-                          ++ " without solving for pkg-config constraints: "-                          ++ show e)-          return NoPkgConfigDb---- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs.-pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb-pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs-    where-      convert :: (String, String) -> (PackageName, Maybe Version)-      convert (n,vs) = (PackageName n,-                        case (reverse . readP_to_S parseVersion) vs of-                          (v, "") : _ -> Just v-                          _           -> Nothing -- Version not (fully)-                                                 -- understood.-                       )---- | Check whether a given package range is satisfiable in the given--- @pkg-config@ database.-pkgConfigPkgIsPresent :: PkgConfigDb -> PackageName -> VersionRange -> Bool-pkgConfigPkgIsPresent (PkgConfigDb db) pn vr =-    case M.lookup pn db of-      Nothing       -> False    -- Package not present in the DB.-      Just Nothing  -> True     -- Package present, but version unknown.-      Just (Just v) -> withinRange v vr--- If we could not read the pkg-config database successfully we allow--- the check to succeed. The plan found by the solver may fail to be--- executed later on, but we have no grounds for rejecting the plan at--- this stage.-pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True
− cabal/cabal-install/Distribution/Client/PlanIndex.hs 
@@ -1,289 +0,0 @@--- | These graph traversal functions mirror the ones in Cabal, but work with--- the more complete (and fine-grained) set of dependencies provided by--- PackageFixedDeps rather than only the library dependencies provided by--- PackageInstalled.-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-module Distribution.Client.PlanIndex (-    -- * FakeMap and related operations-    FakeMap-  , fakeDepends-  , fakeLookupUnitId-    -- * Graph traversal functions-  , brokenPackages-  , dependencyCycles-  , dependencyGraph-  , dependencyInconsistencies-  ) where--import Prelude hiding (lookup)-import qualified Data.Map as Map-import qualified Data.Graph as Graph-import Data.Array ((!))-import Data.Map (Map)-import Data.Maybe (isNothing)-import Data.Either (rights)--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif--import Distribution.Package-         ( PackageName(..), PackageIdentifier(..), UnitId(..)-         , Package(..), packageName, packageVersion-         )-import Distribution.Version-         ( Version )--import Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.ComponentDeps as CD-import Distribution.Client.Types-         ( PackageFixedDeps(..) )-import Distribution.Simple.PackageIndex-         ( PackageIndex, allPackages, insert, lookupUnitId )-import Distribution.Package-         ( HasUnitId(..), PackageId )---- Note [FakeMap]--------------------- We'd like to use the PackageIndex defined in this module for cabal-install's--- InstallPlan.  However, at the moment, this data structure is indexed by--- UnitId, which we don't know until after we've compiled a package--- (whereas InstallPlan needs to store not-compiled packages in the index.)--- Eventually, an UnitId will be calculatable prior to actually building--- the package, but at the moment, the "fake installed package ID map" is a--- workaround to solve this problem while reusing PackageIndex.  The basic idea--- is that, since we don't know what an UnitId is beforehand, we just fake--- up one based on the package ID (it only needs to be unique for the particular--- install plan), and fill it out with the actual generated UnitId after--- the package is successfully compiled.------ However, there is a problem: in the index there may be references using the--- old package ID, which are now dangling if we update the UnitId.  We--- could map over the entire index to update these pointers as well (a costly--- operation), but instead, we've chosen to parametrize a variety of important--- functions by a FakeMap, which records what a fake installed package ID was--- actually resolved to post-compilation.  If we do a lookup, we first check and--- see if it's a fake ID in the FakeMap.------ It's a bit grungy, but we expect this to only be temporary anyway.  (Another--- possible workaround would have been to *not* update the installed package ID,--- but I decided this would be hard to understand.)---- | Map from fake package keys to real ones.  See Note [FakeMap]-type FakeMap = Map UnitId UnitId---- | Variant of `depends` which accepts a `FakeMap`------ Analogous to `fakeInstalledDepends`. See Note [FakeMap].-fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [UnitId]-fakeDepends fakeMap = fmap (map resolveFakeId) . depends-  where-    resolveFakeId :: UnitId -> UnitId-    resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap----- | Variant of 'lookupUnitId' which accepts a 'FakeMap'.  See Note---- [FakeMap].-fakeLookupUnitId :: FakeMap -> PackageIndex a -> UnitId-                             -> Maybe a-fakeLookupUnitId fakeMap index pkg =-  lookupUnitId index (Map.findWithDefault pkg pkg fakeMap)---- | All packages that have dependencies that are not in the index.------ Returns such packages along with the dependencies that they're missing.----brokenPackages :: (PackageFixedDeps pkg)-               => FakeMap-               -> PackageIndex pkg-               -> [(pkg, [UnitId])]-brokenPackages fakeMap index =-  [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing =-          [ pkg' | pkg' <- CD.flatDeps (depends pkg)-                 , isNothing (fakeLookupUnitId fakeMap index pkg') ]-  , not (null missing) ]---- | Compute all roots of the install plan, and verify that the transitive--- plans from those roots are all consistent.------ NOTE: This does not check for dependency cycles. Moreover, dependency cycles--- may be absent from the subplans even if the larger plan contains a dependency--- cycle. Such cycles may or may not be an issue; either way, we don't check--- for them here.-dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg)-                          => FakeMap-                          -> Bool-                          -> PackageIndex pkg-                          -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies fakeMap indepGoals index  =-    concatMap (dependencyInconsistencies' fakeMap) subplans-  where-    subplans :: [PackageIndex pkg]-    subplans = rights $-                 map (dependencyClosure fakeMap index)-                     (rootSets fakeMap indepGoals index)---- | Compute the root sets of a plan------ A root set is a set of packages whose dependency closure must be consistent.--- This is the set of all top-level library roots (taken together normally, or--- as singletons sets if we are considering them as independent goals), along--- with all setup dependencies of all packages.-rootSets :: (PackageFixedDeps pkg, HasUnitId pkg)-         => FakeMap -> Bool -> PackageIndex pkg -> [[UnitId]]-rootSets fakeMap indepGoals index =-       if indepGoals then map (:[]) libRoots else [libRoots]-    ++ setupRoots index-  where-    libRoots = libraryRoots fakeMap index---- | Compute the library roots of a plan------ The library roots are the set of packages with no reverse dependencies--- (no reverse library dependencies but also no reverse setup dependencies).-libraryRoots :: (PackageFixedDeps pkg, HasUnitId pkg)-             => FakeMap -> PackageIndex pkg -> [UnitId]-libraryRoots fakeMap index =-    map toPkgId roots-  where-    (graph, toPkgId, _) = dependencyGraph fakeMap index-    indegree = Graph.indegree graph-    roots    = filter isRoot (Graph.vertices graph)-    isRoot v = indegree ! v == 0---- | The setup dependencies of each package in the plan-setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]]-setupRoots = filter (not . null)-           . map (CD.setupDeps . depends)-           . allPackages---- | Given a package index where we assume we want to use all the packages--- (use 'dependencyClosure' if you need to get such a index subset) find out--- if the dependencies within it use consistent versions of each package.--- Return all cases where multiple packages depend on different versions of--- some other package.------ Each element in the result is a package name along with the packages that--- depend on it and the versions they require. These are guaranteed to be--- distinct.----dependencyInconsistencies' :: forall pkg.-                              (PackageFixedDeps pkg, HasUnitId pkg)-                           => FakeMap-                           -> PackageIndex pkg-                           -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies' fakeMap index =-    [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])-    | (name, ipid_map) <- Map.toList inverseIndex-    , let uses = Map.elems ipid_map-    , reallyIsInconsistent (map fst uses)-    ]-  where-    -- For each package name (of a dependency, somewhere)-    --   and each installed ID of that that package-    --     the associated package instance-    --     and a list of reverse dependencies (as source IDs)-    inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId]))-    inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))-      [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))])-      | -- For each package @pkg@-        pkg <- allPackages index-        -- Find out which @ipid@ @pkg@ depends on-      , ipid <- CD.nonSetupDeps (fakeDepends fakeMap pkg)-        -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)-      , Just dep <- [fakeLookupUnitId fakeMap index ipid]-      ]--    -- If, in a single install plan, we depend on more than one version of a-    -- package, then this is ONLY okay in the (rather special) case that we-    -- depend on precisely two versions of that package, and one of them-    -- depends on the other. This is necessary for example for the base where-    -- we have base-3 depending on base-4.-    reallyIsInconsistent :: [pkg] -> Bool-    reallyIsInconsistent []       = False-    reallyIsInconsistent [_p]     = False-    reallyIsInconsistent [p1, p2] =-      let pid1 = installedUnitId p1-          pid2 = installedUnitId p2-      in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p2)-      && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p1)-    reallyIsInconsistent _ = True------ | Find if there are any cycles in the dependency graph. If there are no--- cycles the result is @[]@.------ This actually computes the strongly connected components. So it gives us a--- list of groups of packages where within each group they all depend on each--- other, directly or indirectly.----dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg)-                 => FakeMap-                 -> PackageIndex pkg-                 -> [[pkg]]-dependencyCycles fakeMap index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]-  where-    adjacencyList = [ (pkg, installedUnitId pkg,-                            CD.flatDeps (fakeDepends fakeMap pkg))-                    | pkg <- allPackages index ]----- | Tries to take the transitive closure of the package dependencies.------ If the transitive closure is complete then it returns that subset of the--- index. Otherwise it returns the broken packages as in 'brokenPackages'.------ * Note that if the result is @Right []@ it is because at least one of--- the original given 'PackageIdentifier's do not occur in the index.-dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg)-                  => FakeMap-                  -> PackageIndex pkg-                  -> [UnitId]-                  -> Either [(pkg, [UnitId])]-                            (PackageIndex pkg)-dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of-  (completed, []) -> Right completed-  (completed, _)  -> Left (brokenPackages fakeMap completed)- where-    closure completed failed []             = (completed, failed)-    closure completed failed (pkgid:pkgids) =-      case fakeLookupUnitId fakeMap index pkgid of-        Nothing   -> closure completed (pkgid:failed) pkgids-        Just pkg  ->-          case fakeLookupUnitId fakeMap completed-               (installedUnitId pkg) of-            Just _  -> closure completed  failed pkgids-            Nothing -> closure completed' failed pkgids'-              where completed' = insert pkg completed-                    pkgids'    = CD.nonSetupDeps (depends pkg) ++ pkgids----- | Builds a graph of the package dependencies.------ Dependencies on other packages that are not in the index are discarded.--- You can check if there are any such dependencies with 'brokenPackages'.----dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg)-                => FakeMap-                -> PackageIndex pkg-                -> (Graph.Graph,-                    Graph.Vertex -> UnitId,-                    UnitId -> Maybe Graph.Vertex)-dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)-  where-    (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges-    vertexToPkg v = case vertexToPkg' v of-                      ((), pkgid, _targets) -> pkgid--    pkgs  = allPackages index-    edges = map edgesFrom pkgs--    resolve   pid = Map.findWithDefault pid pid fakeMap-    edgesFrom pkg = ( ()-                    , resolve (installedUnitId pkg)-                    , CD.flatDeps (fakeDepends fakeMap pkg)-                    )
cabal/cabal-install/Distribution/Client/ProjectBuilding.hs view
@@ -1,33 +1,53 @@ {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns,-             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,              ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE ConstraintKinds #-} --- | +-- | -- module Distribution.Client.ProjectBuilding (-    BuildStatus(..),+    -- * Dry run phase+    -- | What bits of the plan will we execute? The dry run does not change+    -- anything but tells us what will need to be built.+    rebuildTargetsDryRun,+    improveInstallPlanWithUpToDatePackages,++    -- ** Build status+    -- | This is the detailed status information we get from the dry run.     BuildStatusMap,+    BuildStatus(..),     BuildStatusRebuild(..),     BuildReason(..),     MonitorChangedReason(..),-    rebuildTargetsDryRun,-    rebuildTargets+    buildStatusToString,++    -- * Build phase+    -- | Now we actually execute the plan.+    rebuildTargets,+    -- ** Build outcomes+    -- | This is the outcome for each package of executing the plan.+    -- For each package, did the build succeed or fail?+    BuildOutcomes,+    BuildOutcome,+    BuildResult(..),+    BuildFailure(..),+    BuildFailureReason(..),   ) where  import           Distribution.Client.PackageHash (renderPackageHashInputs) import           Distribution.Client.RebuildMonad import           Distribution.Client.ProjectConfig import           Distribution.Client.ProjectPlanning+import           Distribution.Client.ProjectPlanning.Types+import           Distribution.Client.ProjectBuilding.Types  import           Distribution.Client.Types-                   ( PackageLocation(..), GenericReadyPackage(..)-                   , PackageFixedDeps(..)-                   , InstalledPackageId, installedPackageId )+                   hiding (BuildOutcomes, BuildOutcome,+                           BuildResult(..), BuildFailure(..)) import           Distribution.Client.InstallPlan-                   ( GenericInstallPlan, GenericPlanPackage )+                   ( GenericInstallPlan, GenericPlanPackage, IsUnit ) import qualified Distribution.Client.InstallPlan as InstallPlan-import qualified Distribution.Client.ComponentDeps as CD-import           Distribution.Client.ComponentDeps (ComponentDeps) import           Distribution.Client.DistDirLayout import           Distribution.Client.FileMonitor import           Distribution.Client.SetupWrapper@@ -36,11 +56,15 @@ import           Distribution.Client.GlobalFlags (RepoContext) import qualified Distribution.Client.Tar as Tar import           Distribution.Client.Setup (filterConfigureFlags)+import           Distribution.Client.SourceFiles+import           Distribution.Client.SrcDist (allPackageSourceFiles) import           Distribution.Client.Utils (removeExistingFile)  import           Distribution.Package hiding (InstalledPackageId, installedPackageId)+import qualified Distribution.PackageDescription as PD import           Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed+import           Distribution.Types.BuildType import           Distribution.Simple.Program import qualified Distribution.Simple.Setup as Cabal import           Distribution.Simple.Command (CommandUI)@@ -54,6 +78,7 @@ import           Distribution.Verbosity import           Distribution.Text import           Distribution.ParseUtils ( showPWarning )+import           Distribution.Compat.Graph (IsNode(..))  import           Data.Map (Map) import qualified Data.Map as Map@@ -61,20 +86,13 @@ import qualified Data.Set as Set import qualified Data.ByteString.Lazy as LBS -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif import           Control.Monad import           Control.Exception-import           Control.Concurrent.Async-import           Control.Concurrent.MVar-import           Data.List import           Data.Maybe  import           System.FilePath import           System.IO import           System.Directory-import           System.Exit (ExitCode)   ------------------------------------------------------------------------------@@ -82,22 +100,26 @@ ------------------------------------------------------------------------------ -- -- We start with an 'ElaboratedInstallPlan' that has already been improved by--- reusing packages from the store. So the remaining packages in the+-- reusing packages from the store, and pruned to include only the targets of+-- interest and their dependencies. So the remaining packages in the -- 'InstallPlan.Configured' state are ones we either need to build or rebuild. -- -- First, we do a preliminary dry run phase where we work out which packages -- we really need to (re)build, and for the ones we do need to build which -- build phase to start at.------------------------------------------------------------------------------------ * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?----------------------------------------------------------------------------------- We split things like this for a couple reasons. Firstly we need to be able--- to do dry runs, and these need to be reasonably accurate in terms of--- letting users know what (and why) things are going to be (re)built. --+-- We use this to improve the 'ElaboratedInstallPlan' again by changing+-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'+-- so that the build phase will skip them.+--+-- Then we execute the plan, that is actually build packages. The outcomes of+-- trying to build all the packages are collected and returned.+--+-- We split things like this (dry run and execute) for a couple reasons.+-- Firstly we need to be able to do dry runs anyway, and these need to be+-- reasonably accurate in terms of letting users know what (and why) things+-- are going to be (re)built.+-- -- Given that we need to be able to do dry runs, it would not be great if -- we had to repeat all the same work when we do it for real. Not only is -- it duplicate work, but it's duplicate code which is likely to get out of@@ -110,136 +132,54 @@ -- An additional advantage is that it makes it easier to debug rebuild -- errors (ie rebuilding too much or too little), since all the rebuild -- decisions are made without making any state changes at the same time--- (that would make it harder to reproduce the problem sitation).----- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'+-- (that would make it harder to reproduce the problem situation). ---type BuildStatusMap = Map InstalledPackageId BuildStatus+-- Finally, we can use the dry run build status and the build outcomes to+-- give us some information on the overall status of packages in the project.+-- This includes limited information about the status of things that were+-- not actually in the subset of the plan that was used for the dry run or+-- execution phases. In particular we may know that some packages are now+-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for+-- details. --- | The build status for an individual package. That is, the state that the--- package is in prior to initiating a (re)build.------ It serves two purposes:------  * For dry-run output, it lets us explain to the user if and why a package---    is going to be (re)built.------  * It tell us what step to start or resume building from, and carries---    enough information for us to be able to do so.----data BuildStatus = -     -- | The package is in the 'InstallPlan.PreExisting' state, so does not-     --   need building.-     BuildStatusPreExisting--     -- | The package has not been downloaded yet, so it will have to be-     --   downloaded, unpacked and built.-   | BuildStatusDownload--     -- | The package has not been unpacked yet, so it will have to be-     --   unpacked and built.-   | BuildStatusUnpack FilePath--     -- | The package exists in a local dir already, and just needs building-     --   or rebuilding. So this can only happen for 'BuildInplaceOnly' style-     --   packages.-   | BuildStatusRebuild FilePath BuildStatusRebuild--     -- | The package exists in a local dir already, and is fully up to date.-     --   So this package can be put into the 'InstallPlan.Installed' state-     --   and it does not need to be built.-   | BuildStatusUpToDate (Maybe InstalledPackageInfo) BuildSuccess---- | For a package that is going to be built or rebuilt, the state it's in now.------ So again, this tells us why a package needs to be rebuilt and what build--- phases need to be run. The 'MonitorChangedReason' gives us details like--- which file changed, which is mainly for high verbosity debug output.----data BuildStatusRebuild =--     -- | The package configuration changed, so the configure and build phases-     --   needs to be (re)run.-     BuildStatusConfigure (MonitorChangedReason ())--     -- | The configuration has not changed but the build phase needs to be-     -- rerun. We record the reason the (re)build is needed.-     ---     -- The optional registration info here tells us if we've registered the-     -- package already, or if we stil need to do that after building.-     ---   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason--data BuildReason =-     -- | The depencencies of this package have been (re)built so the build-     -- phase needs to be rerun.-     ---     -- The optional registration info here tells us if we've registered the-     -- package already, or if we stil need to do that after building.-     ---     BuildReasonDepsRebuilt--     -- | Changes in files within the package (or first run or corrupt cache) -   | BuildReasonFilesChanged (MonitorChangedReason ())--     -- | An important special case is that no files have changed but the-     -- set of components the /user asked to build/ has changed. We track the-     -- set of components /we have built/, which of course only grows (until-     -- some other change resets it).-     ---     -- The @Set 'ComponentName'@ is the set of components we have built-     -- previously. When we update the monitor we take the union of the ones-     -- we have built previously with the ones the user has asked for this-     -- time and save those. See 'updatePackageBuildFileMonitor'.-     ---   | BuildReasonExtraTargets (Set ComponentName)+------------------------------------------------------------------------------+-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?+------------------------------------------------------------------------------ -     -- | Although we're not going to build any additional targets as a whole,-     -- we're going to build some part of a component or run a repl or any-     -- other action that does not result in additional persistent artifacts.-     -- -   | BuildReasonEphemeralTargets+-- Refer to ProjectBuilding.Types for details of these important types: --- | Which 'BuildStatus' values indicate we'll have to do some build work of--- some sort. In particular we use this as part of checking if any of a--- package's deps have changed.----buildStatusRequiresBuild :: BuildStatus -> Bool-buildStatusRequiresBuild BuildStatusPreExisting = False-buildStatusRequiresBuild BuildStatusUpToDate {} = False-buildStatusRequiresBuild _                      = True+-- type BuildStatusMap     = ...+-- data BuildStatus        = ...+-- data BuildStatusRebuild = ...+-- data BuildReason        = ...  -- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. ----- It gives us the 'BuildStatusMap' and also gives us an improved version of+-- It gives us the 'BuildStatusMap'. This should be used with+-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of -- the 'ElaboratedInstallPlan' with packages switched to the -- 'InstallPlan.Installed' state when we find that they're already up to date. -- rebuildTargetsDryRun :: DistDirLayout+                     -> ElaboratedSharedConfig                      -> ElaboratedInstallPlan-                     -> IO (ElaboratedInstallPlan, BuildStatusMap)-rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do-+                     -> IO BuildStatusMap+rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =     -- Do the various checks to work out the 'BuildStatus' of each package-    pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg--    -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as-    -- 'InstallPlan.Installed'.-    let installPlan' = improveInstallPlanWithUpToDatePackages-                         installPlan pkgsBuildStatus--    return (installPlan', pkgsBuildStatus)+    foldMInstallPlanDepOrder dryRunPkg   where     dryRunPkg :: ElaboratedPlanPackage-              -> ComponentDeps [BuildStatus]+              -> [BuildStatus]               -> IO BuildStatus     dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =       return BuildStatusPreExisting +    dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =+      return BuildStatusInstalled+     dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do-      mloc <- checkFetched (pkgSourceLocation pkg)+      mloc <- checkFetched (elabPkgSourceLocation pkg)       case mloc of         Nothing -> return BuildStatusDownload @@ -260,18 +200,12 @@         Just (RepoTarballPackage _ _ tarball) ->           dryRunTarballPkg pkg depsBuildStatus tarball -    dryRunPkg (InstallPlan.Processing {}) _ = unexpectedState-    dryRunPkg (InstallPlan.Installed  {}) _ = unexpectedState-    dryRunPkg (InstallPlan.Failed     {}) _ = unexpectedState--    unexpectedState = error "rebuildTargetsDryRun: unexpected package state"-     dryRunTarballPkg :: ElaboratedConfiguredPackage-                     -> ComponentDeps [BuildStatus]+                     -> [BuildStatus]                      -> FilePath                      -> IO BuildStatus     dryRunTarballPkg pkg depsBuildStatus tarball =-      case pkgBuildStyle pkg of+      case elabBuildStyle pkg of         BuildAndInstall  -> return (BuildStatusUnpack tarball)         BuildInplaceOnly -> do           -- TODO: [nice to have] use a proper file monitor rather than this dir exists test@@ -283,7 +217,7 @@         srcdir = distUnpackedSrcDirectory (packageId pkg)      dryRunLocalPkg :: ElaboratedConfiguredPackage-                   -> ComponentDeps [BuildStatus]+                   -> [BuildStatus]                    -> FilePath                    -> IO BuildStatus     dryRunLocalPkg pkg depsBuildStatus srcdir = do@@ -297,65 +231,59 @@             return (BuildStatusRebuild srcdir rebuild)            -- No changes, the package is up to date. Use the saved build results.-          Right (mipkg, buildSuccess) ->-            return (BuildStatusUpToDate mipkg buildSuccess)+          Right buildResult ->+            return (BuildStatusUpToDate buildResult)       where         packageFileMonitor =-          newPackageFileMonitor distDirLayout (packageId pkg)+          newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg)   -- | A specialised traversal over the packages in an install plan. -- -- The packages are visited in dependency order, starting with packages with no--- depencencies. The result for each package is accumulated into a 'Map' and+-- dependencies. The result for each package is accumulated into a 'Map' and -- returned as the final result. In addition, when visting a package, the -- visiting function is passed the results for all the immediate package--- depencencies. This can be used to propagate information from depencencies.+-- dependencies. This can be used to propagate information from dependencies. -- foldMInstallPlanDepOrder-  :: forall m ipkg srcpkg iresult ifailure b.-     (Monad m,-      HasUnitId ipkg,   PackageFixedDeps ipkg,-      HasUnitId srcpkg, PackageFixedDeps srcpkg)-  => GenericInstallPlan ipkg srcpkg iresult ifailure-  -> (GenericPlanPackage ipkg srcpkg iresult ifailure ->-      ComponentDeps [b] -> m b)-  -> m (Map InstalledPackageId b)-foldMInstallPlanDepOrder plan0 visit =-    go Map.empty (InstallPlan.reverseTopologicalOrder plan0)+  :: forall m ipkg srcpkg b.+     (Monad m, IsUnit ipkg, IsUnit srcpkg)+  => (GenericPlanPackage ipkg srcpkg ->+      [b] -> m b)+  -> GenericInstallPlan ipkg srcpkg+  -> m (Map UnitId b)+foldMInstallPlanDepOrder visit =+    go Map.empty . InstallPlan.reverseTopologicalOrder   where-    go :: Map InstalledPackageId b-       -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-       -> m (Map InstalledPackageId b)+    go :: Map UnitId b+       -> [GenericPlanPackage ipkg srcpkg]+       -> m (Map UnitId b)     go !results [] = return results      go !results (pkg : pkgs) = do       -- we go in the right order so the results map has entries for all deps-      let depresults :: ComponentDeps [b]+      let depresults :: [b]           depresults =-            fmap (map (\ipkgid -> let Just result = Map.lookup ipkgid results-                                   in result))-                 (depends pkg)+            map (\ipkgid -> let Just result = Map.lookup ipkgid results+                              in result)+                (InstallPlan.depends pkg)       result <- visit pkg depresults-      let results' = Map.insert (installedPackageId pkg) result results+      let results' = Map.insert (nodeKey pkg) result results       go results' pkgs -improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan-                                       -> BuildStatusMap+improveInstallPlanWithUpToDatePackages :: BuildStatusMap                                        -> ElaboratedInstallPlan-improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =-    replaceWithPreInstalled installPlan-      [ (installedPackageId pkg, mipkg, buildSuccess)-      | InstallPlan.Configured pkg-          <- InstallPlan.reverseTopologicalOrder installPlan-      , let ipkgid = installedPackageId pkg-            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus-      , BuildStatusUpToDate mipkg buildSuccess <- [pkgBuildStatus]-      ]+                                       -> ElaboratedInstallPlan+improveInstallPlanWithUpToDatePackages pkgsBuildStatus =+    InstallPlan.installed canPackageBeImproved   where-    replaceWithPreInstalled =-      foldl' (\plan (ipkgid, mipkg, buildSuccess) ->-                InstallPlan.preinstalled ipkgid mipkg buildSuccess plan)+    canPackageBeImproved pkg =+      case Map.lookup (installedUnitId pkg) pkgsBuildStatus of+        Just BuildStatusUpToDate {} -> True+        Just _                      -> False+        Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "+                        ++ display (packageId pkg) ++ " not in status map"   -----------------------------@@ -374,26 +302,34 @@ -- data PackageFileMonitor = PackageFileMonitor {        pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),-       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildSuccess,+       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,        pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)      } -newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor-newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid =+-- | This is all the components of the 'BuildResult' other than the+-- @['InstalledPackageInfo']@.+--+-- We have to split up the 'BuildResult' components since they get produced+-- at different times (or rather, when different things change).+--+type BuildResultMisc = (DocsResult, TestsResult)++newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor+newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams =     PackageFileMonitor {       pkgFileMonitorConfig =-        newFileMonitor (distPackageCacheFile pkgid "config"),+        newFileMonitor (distPackageCacheFile dparams "config"),        pkgFileMonitorBuild =         FileMonitor {-          fileMonitorCacheFile = distPackageCacheFile pkgid "build",+          fileMonitorCacheFile = distPackageCacheFile dparams "build",           fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->             componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,           fileMonitorCheckIfOnlyValueChanged = True         },        pkgFileMonitorReg =-        newFileMonitor (distPackageCacheFile pkgid "registration")+        newFileMonitor (distPackageCacheFile dparams "registration")     }  -- | Helper function for 'checkPackageFileMonitorChanged',@@ -404,8 +340,8 @@ -- packageFileMonitorKeyValues :: ElaboratedConfiguredPackage                             -> (ElaboratedConfiguredPackage, Set ComponentName)-packageFileMonitorKeyValues pkg =-    (pkgconfig, buildComponents)+packageFileMonitorKeyValues elab =+    (elab_config, buildComponents)   where     -- The first part is the value used to guard (re)configuring the package.     -- That is, if this value changes then we will reconfigure.@@ -414,17 +350,18 @@     -- do not affect the configure step need to be nulled out. Those parts are     -- the specific targets that we're going to build.     ---    pkgconfig = pkg {-      pkgBuildTargets  = [],-      pkgReplTarget    = Nothing,-      pkgBuildHaddocks = False-    }+    elab_config =+        elab {+            elabBuildTargets = [],+            elabReplTarget    = Nothing,+            elabBuildHaddocks = False+        }      -- The second part is the value used to guard the build step. So this is     -- more or less the opposite of the first part, as it's just the info about     -- what targets we're going to build.     ---    buildComponents = pkgBuildTargetWholeComponents pkg+    buildComponents = elabBuildTargetWholeComponents elab  -- | Do all the checks on whether a package has changed and thus needs either -- rebuilding or reconfiguring and rebuilding.@@ -432,10 +369,8 @@ checkPackageFileMonitorChanged :: PackageFileMonitor                                -> ElaboratedConfiguredPackage                                -> FilePath-                               -> ComponentDeps [BuildStatus]-                               -> IO (Either BuildStatusRebuild-                                            (Maybe InstalledPackageInfo,-                                             BuildSuccess))+                               -> [BuildStatus]+                               -> IO (Either BuildStatusRebuild BuildResult) checkPackageFileMonitorChanged PackageFileMonitor{..}                                pkg srcdir depsBuildStatus = do     --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged@@ -450,8 +385,8 @@       MonitorUnchanged () _           -- The configChanged here includes the identity of the dependencies,           -- so depsBuildStatus is just needed for the changes in the content-          -- of depencencies.-        | any buildStatusRequiresBuild (CD.flatDeps depsBuildStatus) -> do+          -- of dependencies.+        | any buildStatusRequiresBuild depsBuildStatus -> do             regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()             let mreg = changedToMaybe regChanged             return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))@@ -489,8 +424,14 @@                 where                   buildReason = BuildReasonEphemeralTargets -              (MonitorUnchanged buildSuccess _, MonitorUnchanged mipkg _) ->-                return (Right (mipkg, buildSuccess))+              (MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->+                  return $ Right BuildResult {+                    buildResultDocs    = docsResult,+                    buildResultTests   = testsResult,+                    buildResultLogFile = Nothing+                  }+                where+                  (docsResult, testsResult) = buildResult   where     (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg     changedToMaybe (MonitorChanged     _) = Nothing@@ -513,15 +454,14 @@                               -> MonitorTimestamp                               -> ElaboratedConfiguredPackage                               -> BuildStatusRebuild-                              -> [FilePath]-                              -> BuildSuccess+                              -> [MonitorFilePath]+                              -> BuildResultMisc                               -> IO () updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}                               srcdir timestamp pkg pkgBuildStatus-                              allSrcFiles buildSuccess =+                              monitors buildResult =     updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)-                      (map monitorFileHashed allSrcFiles)-                      buildComponents' buildSuccess+                      monitors buildComponents' buildResult   where     (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg @@ -556,10 +496,17 @@ -- * Doing it: executing an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------ +-- Refer to ProjectBuilding.Types for details of these important types: +-- type BuildOutcomes = ...+-- type BuildOutcome  = ...+-- data BuildResult   = ...+-- data BuildFailure  = ...+-- data BuildFailureReason = ...+ -- | Build things for real. ----- It requires the 'BuildStatusMap' gatthered by 'rebuildTargetsDryRun'.+-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. -- rebuildTargets :: Verbosity                -> DistDirLayout@@ -567,25 +514,32 @@                -> ElaboratedSharedConfig                -> BuildStatusMap                -> BuildTimeSettings-               -> IO ElaboratedInstallPlan+               -> IO BuildOutcomes rebuildTargets verbosity                distDirLayout@DistDirLayout{..}                installPlan-               sharedPackageConfig+               sharedPackageConfig@ElaboratedSharedConfig {+                 pkgConfigCompiler      = compiler,+                 pkgConfigCompilerProgs = progdb+               }                pkgsBuildStatus-               buildSettings@BuildTimeSettings{buildSettingNumJobs} = do+               buildSettings@BuildTimeSettings{+                 buildSettingNumJobs,+                 buildSettingKeepGoing+               } = do      -- Concurrency control: create the job controller and concurrency limits     -- for downloading, building and installing.-    jobControl    <- if isParallelBuild then newParallelJobControl-                                        else newSerialJobControl-    buildLimit    <- newJobLimit buildSettingNumJobs-    installLock   <- newLock -- serialise installation+    jobControl    <- if isParallelBuild+                       then newParallelJobControl buildSettingNumJobs+                       else newSerialJobControl+    registerLock  <- newLock -- serialise registration     cacheLock     <- newLock -- serialise access to setup exe cache                              --TODO: [code cleanup] eliminate setup exe cache -    createDirectoryIfMissingVerbose verbosity False distBuildRootDirectory-    createDirectoryIfMissingVerbose verbosity False distTempDirectory+    createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory+    createDirectoryIfMissingVerbose verbosity True distTempDirectory+    mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse      -- Before traversing the install plan, pre-emptively find all packages that     -- will need to be downloaded and start downloading them.@@ -593,32 +547,44 @@                           installPlan pkgsBuildStatus $ \downloadMap ->        -- For each package in the plan, in dependency order, but in parallel...-      executeInstallPlan verbosity jobControl installPlan $ \pkg ->-        handle (return . BuildFailure) $ --TODO: review exception handling+      InstallPlan.execute jobControl keepGoing+                          (BuildFailure Nothing . DependentFailed . packageId)+                          installPlan $ \pkg ->+        --TODO: review exception handling+        handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ -        let ipkgid = installedPackageId pkg-            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in+        let uid = installedUnitId pkg+            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in          rebuildTarget           verbosity           distDirLayout           buildSettings downloadMap-          buildLimit installLock cacheLock +          registerLock cacheLock           sharedPackageConfig           pkg           pkgBuildStatus   where     isParallelBuild = buildSettingNumJobs >= 2-    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity +    keepGoing       = buildSettingKeepGoing+    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity                         buildSettings+    packageDBsToUse = -- all the package dbs we may need to create+      (Set.toList . Set.fromList)+        [ pkgdb+        | InstallPlan.Configured elab <- InstallPlan.toList installPlan+        , (pkgdb:_) <- map reverse [ elabBuildPackageDBStack elab,+                                     elabRegisterPackageDBStack elab,+                                     elabSetupPackageDBStack elab ]+        ]  -- | Given all the context and resources, (re)build an individual package. -- rebuildTarget :: Verbosity               -> DistDirLayout               -> BuildTimeSettings-              -> AsyncDownloadMap-              -> JobLimit -> Lock -> Lock+              -> AsyncFetchMap+              -> Lock -> Lock               -> ElaboratedSharedConfig               -> ElaboratedReadyPackage               -> BuildStatus@@ -626,7 +592,7 @@ rebuildTarget verbosity               distDirLayout@DistDirLayout{distBuildDirectory}               buildSettings downloadMap-              buildLimit installLock cacheLock+              registerLock cacheLock               sharedPackageConfig               rpkg@(ReadyPackage pkg)               pkgBuildStatus =@@ -639,25 +605,26 @@        -- TODO: perhaps re-nest the types to make these impossible       BuildStatusPreExisting {} -> unexpectedState+      BuildStatusInstalled   {} -> unexpectedState       BuildStatusUpToDate    {} -> unexpectedState   where     unexpectedState = error "rebuildTarget: unexpected package status"      downloadPhase = do-        downsrcloc <- waitAsyncPackageDownload verbosity downloadMap pkg+        downsrcloc <- annotateFailureNoLog DownloadFailed $+                        waitAsyncPackageDownload verbosity downloadMap pkg         case downsrcloc of           DownloadedTarball tarball -> unpackTarballPhase tarball           --TODO: [nice to have] git/darcs repos etc       unpackTarballPhase tarball =-      withJobLimit buildLimit $         withTarballLocalDirectory           verbosity distDirLayout tarball-          (packageId pkg) (pkgBuildStyle pkg)-          (pkgDescriptionOverride pkg) $+          (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg)+          (elabPkgDescriptionOverride pkg) $ -          case pkgBuildStyle pkg of+          case elabBuildStyle pkg of             BuildAndInstall  -> buildAndInstall             BuildInplaceOnly -> buildInplace buildStatus               where@@ -668,17 +635,16 @@     -- would only start from download or unpack phases.     --     rebuildPhase buildStatus srcdir =-        assert (pkgBuildStyle pkg == BuildInplaceOnly) $+        assert (elabBuildStyle pkg == BuildInplaceOnly) $ -        withJobLimit buildLimit $           buildInplace buildStatus srcdir builddir       where-        builddir = distBuildDirectory (packageId pkg)+        builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg)      buildAndInstall srcdir builddir =         buildAndInstallUnpackedPackage           verbosity distDirLayout-          buildSettings installLock cacheLock+          buildSettings registerLock cacheLock           sharedPackageConfig           rpkg           srcdir builddir'@@ -690,7 +656,7 @@         --TODO: [nice to have] use a relative build dir rather than absolute         buildInplaceUnpackedPackage           verbosity distDirLayout-          buildSettings cacheLock+          buildSettings registerLock cacheLock           sharedPackageConfig           rpkg           buildStatus@@ -699,20 +665,6 @@ --TODO: [nice to have] do we need to use a with-style for the temp files for downloading http -- packages, or are we going to cache them persistently? -type AsyncDownloadMap = Map (PackageLocation (Maybe FilePath))-                            (MVar DownloadedSourceLocation)--data DownloadedSourceLocation = DownloadedTarball FilePath-                              --TODO: [nice to have] git/darcs repos etc--downloadedSourceLocation :: PackageLocation FilePath-                         -> Maybe DownloadedSourceLocation-downloadedSourceLocation pkgloc =-    case pkgloc of-      RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)-      RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)-      _                              -> Nothing- -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the -- packages we have to download and fork off an async action to download them. -- We download them in dependency order so that the one's we'll need@@ -723,137 +675,89 @@ -- lookup the location and use 'waitAsyncPackageDownload' to get the result. -- asyncDownloadPackages :: Verbosity-                      -> ((RepoContext -> IO ()) -> IO ())+                      -> ((RepoContext -> IO a) -> IO a)                       -> ElaboratedInstallPlan                       -> BuildStatusMap-                      -> (AsyncDownloadMap -> IO a)+                      -> (AsyncFetchMap -> IO a)                       -> IO a asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body   | null pkgsToDownload = body Map.empty-  | otherwise = do-    --TODO: [research required] use parallel downloads? if so, use the fetchLimit--    asyncDownloadVars <- mapM (\loc -> (,) loc <$> newEmptyMVar) pkgsToDownload--    let downloadAction :: IO ()-        downloadAction =-          withRepoCtx $ \repoctx ->-            forM_ asyncDownloadVars $ \(pkgloc, var) -> do-              Just scrloc <- downloadedSourceLocation <$>-                             fetchPackage verbosity repoctx pkgloc-              putMVar var scrloc--    withAsync downloadAction $ \_ ->-      body (Map.fromList asyncDownloadVars)+  | otherwise           = withRepoCtx $ \repoctx ->+                            asyncFetchPackages verbosity repoctx+                                               pkgsToDownload body   where-    pkgsToDownload = -      [ pkgSourceLocation pkg-      | InstallPlan.Configured pkg+    pkgsToDownload =+      ordNub $+      [ elabPkgSourceLocation elab+      | InstallPlan.Configured elab          <- InstallPlan.reverseTopologicalOrder installPlan-      , let ipkgid = installedPackageId pkg-            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus+      , let uid = installedUnitId elab+            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus       , BuildStatusDownload <- [pkgBuildStatus]       ]   -- | Check if a package needs downloading, and if so expect to find a download--- in progress in the given 'AsyncDownloadMap' and wait on it to finish.+-- in progress in the given 'AsyncFetchMap' and wait on it to finish. -- waitAsyncPackageDownload :: Verbosity-                         -> AsyncDownloadMap+                         -> AsyncFetchMap                          -> ElaboratedConfiguredPackage                          -> IO DownloadedSourceLocation-waitAsyncPackageDownload verbosity downloadMap pkg =-    case Map.lookup (pkgSourceLocation pkg) downloadMap of-      Just hnd -> do-        debug verbosity $-          "Waiting for download of " ++ display (packageId pkg) ++ " to finish"-        --TODO: [required eventually] do the exception handling on download stuff-        takeMVar hnd-      Nothing ->-        fail "waitAsyncPackageDownload: package not being download"+waitAsyncPackageDownload verbosity downloadMap elab = do+    pkgloc <- waitAsyncFetchPackage verbosity downloadMap+                                    (elabPkgSourceLocation elab)+    case downloadedSourceLocation pkgloc of+      Just loc -> return loc+      Nothing  -> fail "waitAsyncPackageDownload: unexpected source location" +data DownloadedSourceLocation = DownloadedTarball FilePath+                              --TODO: [nice to have] git/darcs repos etc -executeInstallPlan-  :: forall ipkg srcpkg iresult.-     (HasUnitId ipkg,   PackageFixedDeps ipkg,-      HasUnitId srcpkg, PackageFixedDeps srcpkg)-  => Verbosity-  -> JobControl IO ( GenericReadyPackage srcpkg-                   , GenericBuildResult ipkg iresult BuildFailure )-  -> GenericInstallPlan ipkg srcpkg iresult BuildFailure-  -> (    GenericReadyPackage srcpkg-       -> IO (GenericBuildResult ipkg iresult BuildFailure))-  -> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure)-executeInstallPlan verbosity jobCtl plan0 installPkg =-    tryNewTasks 0 plan0-  where-    tryNewTasks taskCount plan = do-      case InstallPlan.ready plan of-        [] | taskCount == 0 -> return plan-           | otherwise      -> waitForTasks taskCount plan-        pkgs                -> do-          sequence_-            [ do debug verbosity $ "Ready to install " ++ display pkgid-                 spawnJob jobCtl $ do-                   buildResult <- installPkg pkg-                   return (pkg, buildResult)-            | pkg <- pkgs-            , let pkgid = packageId pkg-            ]+downloadedSourceLocation :: PackageLocation FilePath+                         -> Maybe DownloadedSourceLocation+downloadedSourceLocation pkgloc =+    case pkgloc of+      RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)+      RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)+      _                              -> Nothing -          let taskCount' = taskCount + length pkgs-              plan'      = InstallPlan.processing pkgs plan-          waitForTasks taskCount' plan' -    waitForTasks taskCount plan = do-      debug verbosity $ "Waiting for install task to finish..."-      (pkg, buildResult) <- collectJob jobCtl-      let taskCount' = taskCount-1-          plan'      = updatePlan pkg buildResult plan-      tryNewTasks taskCount' plan' -    updatePlan :: GenericReadyPackage srcpkg-               -> GenericBuildResult ipkg iresult BuildFailure-               -> GenericInstallPlan ipkg srcpkg iresult BuildFailure-               -> GenericInstallPlan ipkg srcpkg iresult BuildFailure-    updatePlan pkg (BuildSuccess mipkg buildSuccess) =-        InstallPlan.completed (installedPackageId pkg) mipkg buildSuccess -    updatePlan pkg (BuildFailure buildFailure) =-        InstallPlan.failed (installedPackageId pkg) buildFailure depsFailure-      where-        depsFailure = DependentFailed (packageId pkg)-        -- So this first pkgid failed for whatever reason (buildFailure).-        -- All the other packages that depended on this pkgid, which we-        -- now cannot build, we mark as failing due to 'DependentFailed'-        -- which kind of means it was not their fault.-- -- | Ensure that the package is unpacked in an appropriate directory, either--- a temporary one or a persistent one under the shared dist directory. +-- a temporary one or a persistent one under the shared dist directory. -- withTarballLocalDirectory   :: Verbosity   -> DistDirLayout   -> FilePath   -> PackageId+  -> DistDirParams   -> BuildStyle   -> Maybe CabalFileText-  -> (FilePath -> FilePath -> IO a)+  -> (FilePath -> -- Source directory+      FilePath -> -- Build directory+      IO a)   -> IO a withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}-                          tarball pkgid buildstyle pkgTextOverride+                          tarball pkgid dparams buildstyle pkgTextOverride                           buildPkg  =       case buildstyle of-        -- In this case we make a temp dir, unpack the tarball to there and-        -- build and install it from that temp dir.+        -- In this case we make a temp dir (e.g. tmp/src2345/), unpack+        -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for+        -- compatibility we put the dist dir within it+        -- (i.e. tmp/src2345/foo-1.0/dist/).+        --+        -- Unfortunately, a few custom Setup.hs scripts do not respect+        -- the --builddir flag and always look for it at ./dist/ so+        -- this way we avoid breaking those packages         BuildAndInstall ->-          withTempDirectory verbosity distTempDirectory-                            (display (packageName pkgid)) $ \tmpdir -> do-            unpackPackageTarball verbosity tarball tmpdir+          let tmpdir = distTempDirectory in+          withTempDirectory verbosity tmpdir "src"   $ \unpackdir -> do+            unpackPackageTarball verbosity tarball unpackdir                                  pkgid pkgTextOverride-            let srcdir   = tmpdir </> display pkgid+            let srcdir   = unpackdir </> display pkgid                 builddir = srcdir </> "dist"             buildPkg srcdir builddir @@ -863,15 +767,15 @@         BuildInplaceOnly -> do           let srcrootdir = distUnpackedSrcRootDirectory               srcdir     = distUnpackedSrcDirectory pkgid-              builddir   = distBuildDirectory pkgid+              builddir   = distBuildDirectory dparams           -- TODO: [nice to have] use a proper file monitor rather than this dir exists test           exists <- doesDirectoryExist srcdir           unless exists $ do-            createDirectoryIfMissingVerbose verbosity False srcrootdir+            createDirectoryIfMissingVerbose verbosity True srcrootdir             unpackPackageTarball verbosity tarball srcrootdir                                  pkgid pkgTextOverride             moveTarballShippedDistDirectory verbosity distDirLayout-                                            srcrootdir pkgid+                                            srcrootdir pkgid dparams           buildPkg srcdir builddir  @@ -880,7 +784,7 @@                      -> IO () unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =     --TODO: [nice to have] switch to tar package and catch tar exceptions-    annotateFailure UnpackFailed $ do+    annotateFailureNoLog UnpackFailed $ do        -- Unpack the tarball       --@@ -917,9 +821,9 @@ -- system, though we'll still need to keep this hack for older packages. -- moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout-                                -> FilePath -> PackageId -> IO ()+                                -> FilePath -> PackageId -> DistDirParams -> IO () moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}-                                parentdir pkgid = do+                                parentdir pkgid dparams = do     distDirExists <- doesDirectoryExist tarballDistDir     when distDirExists $ do       debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"@@ -928,7 +832,7 @@       renameDirectory tarballDistDir targetDistDir   where     tarballDistDir = parentdir </> display pkgid </> "dist"-    targetDistDir  = distBuildDirectory pkgid+    targetDistDir  = distBuildDirectory dparams   buildAndInstallUnpackedPackage :: Verbosity@@ -944,16 +848,16 @@                                  buildSettingNumJobs,                                  buildSettingLogFile                                }-                               installLock cacheLock+                               registerLock cacheLock                                pkgshared@ElaboratedSharedConfig {-                                 pkgConfigCompiler  = compiler,-                                 pkgConfigPlatform  = platform,-                                 pkgConfigProgramDb = progdb+                                 pkgConfigPlatform      = platform,+                                 pkgConfigCompiler      = compiler,+                                 pkgConfigCompilerProgs = progdb                                }                                rpkg@(ReadyPackage pkg)                                srcdir builddir = do -    createDirectoryIfMissingVerbose verbosity False builddir+    createDirectoryIfMissingVerbose verbosity True builddir     initLogFile      --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like@@ -966,25 +870,26 @@     --TODO: [required feature] docs and tests     --TODO: [required feature] sudo re-exec +    let dispname = case elabPkgOrComp pkg of+            ElabPackage _ -> display pkgid+                ++ " (all, due to Custom setup)"+            ElabComponent comp -> display pkgid+                ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")"+     -- Configure phase     when isParallelBuild $-      notice verbosity $ "Configuring " ++ display pkgid ++ "..."-    annotateFailure ConfigureFailed $-      setup configureCommand configureFlags+      notice verbosity $ "Configuring " ++ dispname ++ "..."+    annotateFailure mlogFile ConfigureFailed $+      setup' configureCommand configureFlags configureArgs      -- Build phase     when isParallelBuild $-      notice verbosity $ "Building " ++ display pkgid ++ "..."-    annotateFailure BuildFailed $+      notice verbosity $ "Building " ++ dispname ++ "..."+    annotateFailure mlogFile BuildFailed $       setup buildCommand buildFlags      -- Install phase-    mipkg <--      criticalSection installLock $ -      annotateFailure InstallFailed $ do-      --TODO: [research required] do we need the installLock for copying? can we not do that in-      -- parallel? Isn't it just registering that we have to lock for?-+    annotateFailure mlogFile InstallFailed $ do       --TODO: [required eventually] need to lock installing this ipkig so other processes don't       -- stomp on our files, since we don't have ABI compat, not safe to replace @@ -994,9 +899,9 @@        -- Actual installation       setup Cabal.copyCommand copyFlags-      +       LBS.writeFile-        (InstallDirs.prefix (pkgInstallDirs pkg) </> "cabal-hash.txt") $+        (InstallDirs.prefix (elabInstallDirs pkg) </> "cabal-hash.txt") $         (renderPackageHashInputs (packageHashInputs pkgshared pkg))        -- here's where we could keep track of the installed files ourselves if@@ -1007,51 +912,53 @@       -- then when it's done, move it to its final location, to reduce problems       -- with installs failing half-way. Could also register and then move. -      -- For libraries, grab the package configuration file-      -- and register it ourselves-      if pkgRequiresRegistration pkg+      if elabRequiresRegistration pkg         then do-          ipkg <- generateInstalledPackageInfo           -- We register ourselves rather than via Setup.hs. We need to           -- grab and modify the InstalledPackageInfo. We decide what           -- the installed package id is, not the build system.-          let ipkg' = ipkg { Installed.installedUnitId = ipkgid }-          Cabal.registerPackage verbosity compiler progdb-                                HcPkg.MultiInstance-                                (pkgRegisterPackageDBStack pkg) ipkg'-          return (Just ipkg')-        else return Nothing+          ipkg0 <- generateInstalledPackageInfo+          let ipkg = ipkg0 { Installed.installedUnitId = uid } +          criticalSection registerLock $+              Cabal.registerPackage verbosity compiler progdb+                                    HcPkg.MultiInstance+                                    (elabRegisterPackageDBStack pkg) ipkg+        else return ()+     --TODO: [required feature] docs and test phases     let docsResult  = DocsNotTried         testsResult = TestsNotTried -    return (BuildSuccess mipkg (BuildOk docsResult testsResult))+    return BuildResult {+       buildResultDocs    = docsResult,+       buildResultTests   = testsResult,+       buildResultLogFile = mlogFile+    }    where     pkgid  = packageId rpkg-    ipkgid = installedPackageId rpkg+    uid = installedUnitId rpkg      isParallelBuild = buildSettingNumJobs >= 2 -    configureCommand = Cabal.configureCommand defaultProgramConfiguration+    configureCommand = Cabal.configureCommand defaultProgramDb     configureFlags v = flip filterConfigureFlags v $                        setupHsConfigureFlags rpkg pkgshared                                              verbosity builddir+    configureArgs    = setupHsConfigureArgs pkg -    buildCommand     = Cabal.buildCommand defaultProgramConfiguration+    buildCommand     = Cabal.buildCommand defaultProgramDb     buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir      generateInstalledPackageInfo :: IO InstalledPackageInfo     generateInstalledPackageInfo =       withTempInstalledPackageInfoFile-        verbosity distTempDirectory $ \pkgConfFile -> do-        -- make absolute since setup changes dir-        pkgConfFile' <- canonicalizePath pkgConfFile+        verbosity distTempDirectory $ \pkgConfDest -> do         let registerFlags _ = setupHsRegisterFlags                                 pkg pkgshared                                 verbosity builddir-                                pkgConfFile'+                                pkgConfDest         setup Cabal.registerCommand registerFlags      copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir@@ -1060,18 +967,22 @@                                          isParallelBuild cacheLock      setup :: CommandUI flags -> (Version -> flags) -> IO ()-    setup cmd flags =-      withLogging $ \mLogFileHandle -> +    setup cmd flags = setup' cmd flags []++    setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()+    setup' cmd flags args =+      withLogging $ \mLogFileHandle ->         setupWrapper           verbosity           scriptOptions { useLoggingHandle = mLogFileHandle }-          (Just (pkgDescription pkg))-          cmd flags []+          (Just (elabPkgDescription pkg))+          cmd flags args +    mlogFile :: Maybe FilePath     mlogFile =       case buildSettingLogFile of         Nothing        -> Nothing-        Just mkLogFile -> Just (mkLogFile compiler platform pkgid ipkgid)+        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)      initLogFile =       case mlogFile of@@ -1089,7 +1000,7 @@  buildInplaceUnpackedPackage :: Verbosity                             -> DistDirLayout-                            -> BuildTimeSettings -> Lock+                            -> BuildTimeSettings -> Lock -> Lock                             -> ElaboratedSharedConfig                             -> ElaboratedReadyPackage                             -> BuildStatusRebuild@@ -1101,10 +1012,10 @@                               distPackageCacheDirectory                             }                             BuildTimeSettings{buildSettingNumJobs}-                            cacheLock+                            registerLock cacheLock                             pkgshared@ElaboratedSharedConfig {-                              pkgConfigCompiler  = compiler,-                              pkgConfigProgramDb = progdb+                              pkgConfigCompiler      = compiler,+                              pkgConfigCompilerProgs = progdb                             }                             rpkg@(ReadyPackage pkg)                             buildStatus@@ -1112,14 +1023,14 @@          --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here         --      builddir is not enough, we also need the per-package cachedir-        createDirectoryIfMissingVerbose verbosity False builddir-        createDirectoryIfMissingVerbose verbosity False (distPackageCacheDirectory pkgid)-        createPackageDBIfMissing verbosity compiler progdb (pkgBuildPackageDBStack pkg)+        createDirectoryIfMissingVerbose verbosity True builddir+        createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams)          -- Configure phase         --         whenReConfigure $ do-          setup configureCommand configureFlags []+          annotateFailureNoLog ConfigureFailed $+            setup configureCommand configureFlags configureArgs           invalidatePackageRegFileMonitor packageFileMonitor           updatePackageConfigFileMonitor packageFileMonitor srcdir pkg @@ -1128,92 +1039,126 @@         let docsResult  = DocsNotTried             testsResult = TestsNotTried -            buildSuccess :: BuildSuccess-            buildSuccess = BuildOk docsResult testsResult+            buildResult :: BuildResultMisc+            buildResult = (docsResult, testsResult)          whenRebuild $ do           timestamp <- beginUpdateFileMonitor-          setup buildCommand buildFlags buildArgs+          annotateFailureNoLog BuildFailed $+            setup buildCommand buildFlags buildArgs -          --TODO: [required eventually] temporary hack. We need to look at the package description-          -- and work out the exact file monitors to use-          allSrcFiles <- filter (not . ("dist-newstyle" `isPrefixOf`))-                     <$> getDirectoryContentsRecursive srcdir+          let listSimple =+                execRebuild srcdir (needElaboratedConfiguredPackage pkg)+              listSdist =+                fmap (map monitorFileHashed) $+                    allPackageSourceFiles verbosity scriptOptions srcdir+              ifNullThen m m' = do xs <- m+                                   if null xs then m' else return xs+          monitors <- case PD.buildType (elabPkgDescription pkg) of+            Just Simple -> listSimple+            -- If a Custom setup was used, AND the Cabal is recent+            -- enough to have sdist --list-sources, use that to+            -- determine the files that we need to track.  This can+            -- cause unnecessary rebuilding (for example, if README+            -- is edited, we will try to rebuild) but there isn't+            -- a more accurate Custom interface we can use to get+            -- this info.  We prefer not to use listSimple here+            -- as it can miss extra source files that are considered+            -- by the Custom setup.+            _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17]+              -- However, sometimes sdist --list-sources will fail+              -- and return an empty list.  In that case, fall+              -- back on the (inaccurate) simple tracking.+              -> listSdist `ifNullThen` listSimple+              | otherwise+              -> listSimple            updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp                                         pkg buildStatus-                                        allSrcFiles buildSuccess+                                        monitors buildResult -        mipkg <- whenReRegister $ do+        -- PURPOSELY omitted: no copy!++        whenReRegister $ annotateFailureNoLog InstallFailed $ do           -- Register locally-          mipkg <- if pkgRequiresRegistration pkg+          mipkg <- if elabRequiresRegistration pkg             then do-                ipkg <- generateInstalledPackageInfo+                ipkg0 <- generateInstalledPackageInfo                 -- We register ourselves rather than via Setup.hs. We need to                 -- grab and modify the InstalledPackageInfo. We decide what                 -- the installed package id is, not the build system.-                let ipkg' = ipkg { Installed.installedUnitId = ipkgid }-                Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance-                                      (pkgRegisterPackageDBStack pkg)-                                      ipkg'-                return (Just ipkg')+                let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }+                criticalSection registerLock $+                    Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance+                                          (elabRegisterPackageDBStack pkg)+                                          ipkg+                return (Just ipkg)             else return Nothing            updatePackageRegFileMonitor packageFileMonitor srcdir mipkg-          return mipkg          -- Repl phase         --         whenRepl $-          setup replCommand replFlags replArgs+          annotateFailureNoLog ReplFailed $+          setupInteractive replCommand replFlags replArgs          -- Haddock phase         whenHaddock $+          annotateFailureNoLog HaddocksFailed $           setup haddockCommand haddockFlags [] -        return (BuildSuccess mipkg buildSuccess)+        return BuildResult {+          buildResultDocs    = docsResult,+          buildResultTests   = testsResult,+          buildResultLogFile = Nothing+        }    where-    pkgid  = packageId rpkg-    ipkgid = installedPackageId rpkg+    ipkgid  = installedUnitId pkg+    dparams = elabDistDirParams pkgshared pkg      isParallelBuild = buildSettingNumJobs >= 2 -    packageFileMonitor = newPackageFileMonitor distDirLayout pkgid+    packageFileMonitor = newPackageFileMonitor distDirLayout dparams      whenReConfigure action = case buildStatus of       BuildStatusConfigure _ -> action       _                      -> return ()      whenRebuild action-      | null (pkgBuildTargets pkg) = return ()+      | null (elabBuildTargets pkg) = return ()       | otherwise                  = action      whenRepl action-      | isNothing (pkgReplTarget pkg) = return ()+      | isNothing (elabReplTarget pkg) = return ()       | otherwise                     = action      whenHaddock action-      | pkgBuildHaddocks pkg = action+      | elabBuildHaddocks pkg = action       | otherwise            = return () -    whenReRegister  action = case buildStatus of-      BuildStatusConfigure          _ -> action-      BuildStatusBuild Nothing      _ -> action-      BuildStatusBuild (Just mipkg) _ -> return mipkg+    whenReRegister  action+      = case buildStatus of+          -- We registered the package already+          BuildStatusBuild (Just _) _     -> return ()+          -- There is nothing to register+          _ | null (elabBuildTargets pkg) -> return ()+            | otherwise                   -> action -    configureCommand = Cabal.configureCommand defaultProgramConfiguration+    configureCommand = Cabal.configureCommand defaultProgramDb     configureFlags v = flip filterConfigureFlags v $                        setupHsConfigureFlags rpkg pkgshared                                              verbosity builddir+    configureArgs    = setupHsConfigureArgs pkg -    buildCommand     = Cabal.buildCommand defaultProgramConfiguration+    buildCommand     = Cabal.buildCommand defaultProgramDb     buildFlags   _   = setupHsBuildFlags pkg pkgshared                                          verbosity builddir     buildArgs        = setupHsBuildArgs  pkg -    replCommand      = Cabal.replCommand defaultProgramConfiguration+    replCommand      = Cabal.replCommand defaultProgramDb     replFlags _      = setupHsReplFlags pkg pkgshared                                         verbosity builddir     replArgs         = setupHsReplArgs  pkg@@ -1226,48 +1171,51 @@                                             srcdir builddir                                             isParallelBuild cacheLock +    setupInteractive :: CommandUI flags+                     -> (Version -> flags) -> [String] -> IO ()+    setupInteractive cmd flags args =+      setupWrapper verbosity+                   scriptOptions { isInteractive = True }+                   (Just (elabPkgDescription pkg))+                   cmd flags args+     setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()     setup cmd flags args =       setupWrapper verbosity                    scriptOptions-                   (Just (pkgDescription pkg))+                   (Just (elabPkgDescription pkg))                    cmd flags args      generateInstalledPackageInfo :: IO InstalledPackageInfo     generateInstalledPackageInfo =       withTempInstalledPackageInfoFile-        verbosity distTempDirectory $ \pkgConfFile -> do-        -- make absolute since setup changes dir-        pkgConfFile' <- canonicalizePath pkgConfFile+        verbosity distTempDirectory $ \pkgConfDest -> do         let registerFlags _ = setupHsRegisterFlags                                 pkg pkgshared                                 verbosity builddir-                                pkgConfFile'+                                pkgConfDest         setup Cabal.registerCommand registerFlags [] ---- helper-annotateFailure :: (String -> BuildFailure) -> IO a -> IO a-annotateFailure annotate action =-  action `catches`-    [ Handler $ \ioe  -> handler (ioe  :: IOException)-    , Handler $ \exit -> handler (exit :: ExitCode)-    ]-  where-    handler :: Exception e => e -> IO a-    handler = throwIO . annotate . show-                       --TODO: [nice to have] use displayException when available-- withTempInstalledPackageInfoFile :: Verbosity -> FilePath-                                 -> (FilePath -> IO ())-                                 -> IO InstalledPackageInfo+                                  -> (FilePath -> IO ())+                                  -> IO InstalledPackageInfo withTempInstalledPackageInfoFile verbosity tempdir action =-    withTempFile tempdir "package-registration-" $ \pkgConfFile hnd -> do-      hClose hnd-      action pkgConfFile+    withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do+      -- make absolute since @action@ will often change directory+      abs_dir <- canonicalizePath dir -      (warns, ipkg) <- withUTF8FileContents pkgConfFile $ \pkgConfStr ->+      let pkgConfDest = abs_dir </> "pkgConf"+      action pkgConfDest++      readPkgConf "." pkgConfDest+  where+    pkgConfParseFailed :: Installed.PError -> IO a+    pkgConfParseFailed perror =+      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"+            ++ show perror++    readPkgConf pkgConfDir pkgConfFile = do+      (warns, ipkg) <- withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfStr ->         case Installed.parseInstalledPackageInfo pkgConfStr of           Installed.ParseFailed perror -> pkgConfParseFailed perror           Installed.ParseOk warns ipkg -> return (warns, ipkg)@@ -1276,9 +1224,34 @@         warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)        return ipkg+++------------------------------------------------------------------------------+-- * Utilities+------------------------------------------------------------------------------++annotateFailureNoLog :: (SomeException -> BuildFailureReason)+                     -> IO a -> IO a+annotateFailureNoLog annotate action =+  annotateFailure Nothing annotate action++annotateFailure :: Maybe FilePath+                -> (SomeException -> BuildFailureReason)+                -> IO a -> IO a+annotateFailure mlogFile annotate action =+  action `catches`+    -- It's not just IOException and ExitCode we have to deal with, there's+    -- lots, including exceptions from the hackage-security and tar packages.+    -- So we take the strategy of catching everything except async exceptions.+    [+#if MIN_VERSION_base(4,7,0)+      Handler $ \async -> throwIO (async :: SomeAsyncException)+#else+      Handler $ \async -> throwIO (async :: AsyncException)+#endif+    , Handler $ \other -> handler (other :: SomeException)+    ]   where-    pkgConfParseFailed :: Installed.PError -> IO a-    pkgConfParseFailed perror =-      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"-            ++ show perror+    handler :: Exception e => e -> IO a+    handler = throwIO . BuildFailure mlogFile . annotate . toException
+ cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Types for the "Distribution.Client.ProjectBuilding"+--+-- Moved out to avoid module cycles.+--+module Distribution.Client.ProjectBuilding.Types (+    -- * Pre-build status+    BuildStatusMap,+    BuildStatus(..),+    buildStatusRequiresBuild,+    buildStatusToString,+    BuildStatusRebuild(..),+    BuildReason(..),+    MonitorChangedReason(..),++    -- * Build outcomes+    BuildOutcomes,+    BuildOutcome,+    BuildResult(..),+    BuildFailure(..),+    BuildFailureReason(..),+  ) where++import Distribution.Client.Types          (DocsResult, TestsResult)+import Distribution.Client.FileMonitor    (MonitorChangedReason(..))++import Distribution.Package               (UnitId, PackageId)+import Distribution.InstalledPackageInfo  (InstalledPackageInfo)+import Distribution.Simple.LocalBuildInfo (ComponentName)++import Data.Map          (Map)+import Data.Set          (Set)+import Data.Typeable     (Typeable)+import Control.Exception (Exception, SomeException)+++------------------------------------------------------------------------------+-- Pre-build status: result of the dry run+--++-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'.+--+-- This is used as the result of the dry-run of building an install plan.+--+type BuildStatusMap = Map UnitId BuildStatus++-- | The build status for an individual package is the state that the+-- package is in /prior/ to initiating a (re)build.+--+-- This should not be confused with a 'BuildResult' which is the result+-- /after/ successfully building a package.+--+-- It serves two purposes:+--+--  * For dry-run output, it lets us explain to the user if and why a package+--    is going to be (re)built.+--+--  * It tell us what step to start or resume building from, and carries+--    enough information for us to be able to do so.+--+data BuildStatus =++     -- | The package is in the 'InstallPlan.PreExisting' state, so does not+     --   need building.+     BuildStatusPreExisting++     -- | The package is in the 'InstallPlan.Installed' state, so does not+     --   need building.+   | BuildStatusInstalled++     -- | The package has not been downloaded yet, so it will have to be+     --   downloaded, unpacked and built.+   | BuildStatusDownload++     -- | The package has not been unpacked yet, so it will have to be+     --   unpacked and built.+   | BuildStatusUnpack FilePath++     -- | The package exists in a local dir already, and just needs building+     --   or rebuilding. So this can only happen for 'BuildInplaceOnly' style+     --   packages.+   | BuildStatusRebuild FilePath BuildStatusRebuild++     -- | The package exists in a local dir already, and is fully up to date.+     --   So this package can be put into the 'InstallPlan.Installed' state+     --   and it does not need to be built.+   | BuildStatusUpToDate BuildResult+++-- | Which 'BuildStatus' values indicate we'll have to do some build work of+-- some sort. In particular we use this as part of checking if any of a+-- package's deps have changed.+--+buildStatusRequiresBuild :: BuildStatus -> Bool+buildStatusRequiresBuild BuildStatusPreExisting = False+buildStatusRequiresBuild BuildStatusInstalled   = False+buildStatusRequiresBuild BuildStatusUpToDate {} = False+buildStatusRequiresBuild _                      = True++-- | This is primarily here for debugging. It's not actually used anywhere.+--+buildStatusToString :: BuildStatus -> String+buildStatusToString BuildStatusPreExisting    = "BuildStatusPreExisting"+buildStatusToString BuildStatusInstalled      = "BuildStatusInstalled"+buildStatusToString BuildStatusDownload       = "BuildStatusDownload"+buildStatusToString (BuildStatusUnpack fp)    = "BuildStatusUnpack " ++ show fp+buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp+buildStatusToString (BuildStatusUpToDate _)   = "BuildStatusUpToDate"+++-- | For a package that is going to be built or rebuilt, the state it's in now.+--+-- So again, this tells us why a package needs to be rebuilt and what build+-- phases need to be run. The 'MonitorChangedReason' gives us details like+-- which file changed, which is mainly for high verbosity debug output.+--+data BuildStatusRebuild =++     -- | The package configuration changed, so the configure and build phases+     --   needs to be (re)run.+     BuildStatusConfigure (MonitorChangedReason ())++     -- | The configuration has not changed but the build phase needs to be+     -- rerun. We record the reason the (re)build is needed.+     --+     -- The optional registration info here tells us if we've registered the+     -- package already, or if we still need to do that after building.+     -- @Just Nothing@ indicates that we know that no registration is+     -- necessary (e.g., executable.)+     --+   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason++data BuildReason =+     -- | The dependencies of this package have been (re)built so the build+     -- phase needs to be rerun.+     --+     BuildReasonDepsRebuilt++     -- | Changes in files within the package (or first run or corrupt cache)+   | BuildReasonFilesChanged (MonitorChangedReason ())++     -- | An important special case is that no files have changed but the+     -- set of components the /user asked to build/ has changed. We track the+     -- set of components /we have built/, which of course only grows (until+     -- some other change resets it).+     --+     -- The @Set 'ComponentName'@ is the set of components we have built+     -- previously. When we update the monitor we take the union of the ones+     -- we have built previously with the ones the user has asked for this+     -- time and save those. See 'updatePackageBuildFileMonitor'.+     --+   | BuildReasonExtraTargets (Set ComponentName)++     -- | Although we're not going to build any additional targets as a whole,+     -- we're going to build some part of a component or run a repl or any+     -- other action that does not result in additional persistent artifacts.+     --+   | BuildReasonEphemeralTargets+++------------------------------------------------------------------------------+-- Build outcomes: result of the build+--++-- | A summary of the outcome for building a whole set of packages.+--+type BuildOutcomes = Map UnitId BuildOutcome++-- | A summary of the outcome for building a single package: either success+-- or failure.+--+type BuildOutcome  = Either BuildFailure BuildResult++-- | Information arising from successfully building a single package.+--+data BuildResult = BuildResult {+       buildResultDocs    :: DocsResult,+       buildResultTests   :: TestsResult,+       buildResultLogFile :: Maybe FilePath+     }+  deriving Show++-- | Information arising from the failure to build a single package.+--+data BuildFailure = BuildFailure {+       buildFailureLogFile :: Maybe FilePath,+       buildFailureReason  :: BuildFailureReason+     }+  deriving (Show, Typeable)++instance Exception BuildFailure++-- | Detail on the reason that a package failed to build.+--+data BuildFailureReason = DependentFailed PackageId+                        | DownloadFailed  SomeException+                        | UnpackFailed    SomeException+                        | ConfigureFailed SomeException+                        | BuildFailed     SomeException+                        | ReplFailed      SomeException+                        | HaddocksFailed  SomeException+                        | TestsFailed     SomeException+                        | InstallFailed   SomeException+  deriving Show+
cabal/cabal-install/Distribution/Client/ProjectConfig.hs view
@@ -8,17 +8,22 @@     ProjectConfig(..),     ProjectConfigBuildOnly(..),     ProjectConfigShared(..),+    ProjectConfigProvenance(..),     PackageConfig(..),+    MapLast(..),+    MapMappend(..),      -- * Project config files     findProjectRoot,     readProjectConfig,     writeProjectLocalExtraConfig,+    writeProjectLocalFreezeConfig,     writeProjectConfigFile,     commandLineFlagsToProjectConfig,      -- * Packages within projects     ProjectPackageLocation(..),+    BadPackageLocations(..),     BadPackageLocation(..),     BadPackageLocationMatch(..),     findProjectPackages,@@ -32,8 +37,15 @@     resolveSolverSettings,     BuildTimeSettings(..),     resolveBuildTimeSettings,++    -- * Checking configuration+    checkBadPerPackageCompilerPaths,+    BadPerPackageCompilerPaths(..)   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectConfig.Legacy import Distribution.Client.RebuildMonad@@ -49,7 +61,12 @@          ( ReportLevel(..) ) import Distribution.Client.Config          ( loadConfig, defaultConfigFile )+import Distribution.Client.IndexUtils.Timestamp+         ( IndexState(..) ) +import Distribution.Solver.Types.SourcePackage+import Distribution.Solver.Types.Settings+ import Distribution.Package          ( PackageName, PackageId, packageId, UnitId, Dependency ) import Distribution.System@@ -60,9 +77,11 @@          ( readPackageDescription ) import Distribution.Simple.Compiler          ( Compiler, compilerInfo )+import Distribution.Simple.Program+         ( ConfiguredProgram(..) ) import Distribution.Simple.Setup          ( Flag(Flag), toFlag, flagToMaybe, flagToList-         , fromFlag, AllowNewer(..) )+         , fromFlag, fromFlagOrDefault, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Client.Setup          ( defaultSolver, defaultMaxBackjumps, ) import Distribution.Simple.InstallDirs@@ -80,17 +99,14 @@ import Distribution.ParseUtils          ( ParseResult(..), locatedErrorMsg, showPWarning ) -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad import Control.Monad.Trans (liftIO) import Control.Exception-import Data.Typeable import Data.Maybe import Data.Either import qualified Data.Map as Map-import Distribution.Compat.Semigroup+import Data.Set (Set)+import qualified Data.Set as Set import System.FilePath hiding (combine) import System.Directory import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)@@ -113,7 +129,8 @@                            projectConfigSpecificPackage                          } pkgname =     field projectConfigLocalPackages- <> maybe mempty field (Map.lookup pkgname projectConfigSpecificPackage)+ <> maybe mempty field+          (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))   -- | Use a 'RepoContext' based on the 'BuildTimeSettings'.@@ -137,18 +154,18 @@ -- to the 'BuildTimeSettings' -- projectConfigWithSolverRepoContext :: Verbosity-                                   -> FilePath                                    -> ProjectConfigShared                                    -> ProjectConfigBuildOnly                                    -> (RepoContext -> IO a) -> IO a-projectConfigWithSolverRepoContext verbosity downloadCacheRootDir+projectConfigWithSolverRepoContext verbosity                                    ProjectConfigShared{..}                                    ProjectConfigBuildOnly{..} =     withRepoContext'       verbosity       (fromNubList projectConfigRemoteRepos)       (fromNubList projectConfigLocalRepos)-      downloadCacheRootDir+      (fromFlagOrDefault (error "projectConfigWithSolverRepoContext: projectConfigCacheDir")+                         projectConfigCacheDir)       (flagToMaybe projectConfigHttpTransport)       (flagToMaybe projectConfigIgnoreExpiry) @@ -156,23 +173,34 @@ -- | Resolve the project configuration, with all its optional fields, into -- 'SolverSettings' with no optional fields (by applying defaults). ---resolveSolverSettings :: ProjectConfigShared -> SolverSettings-resolveSolverSettings projectConfig =+resolveSolverSettings :: ProjectConfig -> SolverSettings+resolveSolverSettings ProjectConfig{+                        projectConfigShared,+                        projectConfigLocalPackages,+                        projectConfigSpecificPackage+                      } =     SolverSettings {..}   where+    --TODO: [required eventually] some of these settings need validation, e.g.+    -- the flag assignments need checking.     solverSettingRemoteRepos       = fromNubList projectConfigRemoteRepos     solverSettingLocalRepos        = fromNubList projectConfigLocalRepos     solverSettingConstraints       = projectConfigConstraints     solverSettingPreferences       = projectConfigPreferences-    solverSettingFlagAssignment    = projectConfigFlagAssignment+    solverSettingFlagAssignment    = packageConfigFlagAssignment projectConfigLocalPackages+    solverSettingFlagAssignments   = fmap packageConfigFlagAssignment+                                          (getMapMappend projectConfigSpecificPackage)     solverSettingCabalVersion      = flagToMaybe projectConfigCabalVersion     solverSettingSolver            = fromFlag projectConfigSolver+    solverSettingAllowOlder        = fromJust projectConfigAllowOlder     solverSettingAllowNewer        = fromJust projectConfigAllowNewer     solverSettingMaxBackjumps      = case fromFlag projectConfigMaxBackjumps of                                        n | n < 0     -> Nothing                                          | otherwise -> Just n     solverSettingReorderGoals      = fromFlag projectConfigReorderGoals+    solverSettingCountConflicts    = fromFlag projectConfigCountConflicts     solverSettingStrongFlags       = fromFlag projectConfigStrongFlags+    solverSettingIndexState        = fromFlagOrDefault IndexStateHead projectConfigIndexState   --solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals   --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs   --solverSettingReinstall         = fromFlag projectConfigReinstall@@ -180,14 +208,16 @@   --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall   --solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps -    ProjectConfigShared {..} = defaults <> projectConfig+    ProjectConfigShared {..} = defaults <> projectConfigShared      defaults = mempty {        projectConfigSolver            = Flag defaultSolver,-       projectConfigAllowNewer        = Just AllowNewerNone,+       projectConfigAllowOlder        = Just (AllowOlder RelaxDepsNone),+       projectConfigAllowNewer        = Just (AllowNewer RelaxDepsNone),        projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,-       projectConfigReorderGoals      = Flag False,-       projectConfigStrongFlags       = Flag False+       projectConfigReorderGoals      = Flag (ReorderGoals False),+       projectConfigCountConflicts    = Flag (CountConflicts True),+       projectConfigStrongFlags       = Flag (StrongFlags False)      --projectConfigIndependentGoals  = Flag False,      --projectConfigShadowPkgs        = Flag False,      --projectConfigReinstall         = Flag False,@@ -208,8 +238,7 @@                          -> BuildTimeSettings resolveBuildTimeSettings verbosity                          CabalDirLayout {-                           cabalLogsDirectory,-                           cabalPackageCacheDirectory+                           cabalLogsDirectory                          }                          ProjectConfigShared {                            projectConfigRemoteRepos,@@ -228,16 +257,16 @@     buildSettingSymlinkBinDir = flagToList  projectConfigSymlinkBinDir     buildSettingOneShot       = fromFlag    projectConfigOneShot     buildSettingNumJobs       = determineNumJobs projectConfigNumJobs+    buildSettingKeepGoing     = fromFlag    projectConfigKeepGoing     buildSettingOfflineMode   = fromFlag    projectConfigOfflineMode     buildSettingKeepTempFiles = fromFlag    projectConfigKeepTempFiles     buildSettingRemoteRepos   = fromNubList projectConfigRemoteRepos     buildSettingLocalRepos    = fromNubList projectConfigLocalRepos-    buildSettingCacheDir      = cabalPackageCacheDirectory+    buildSettingCacheDir      = fromFlag    projectConfigCacheDir     buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport     buildSettingIgnoreExpiry  = fromFlag    projectConfigIgnoreExpiry     buildSettingReportPlanningFailure                               = fromFlag projectConfigReportPlanningFailure-    buildSettingRootCmd       = flagToMaybe projectConfigRootCmd      ProjectConfigBuildOnly{..} = defaults                               <> fromProjectFile@@ -248,6 +277,7 @@       projectConfigOnlyDeps              = toFlag False,       projectConfigBuildReports          = toFlag NoReports,       projectConfigReportPlanningFailure = toFlag False,+      projectConfigKeepGoing             = toFlag False,       projectConfigOneShot               = toFlag False,       projectConfigOfflineMode           = toFlag False,       projectConfigKeepTempFiles         = toFlag False,@@ -268,7 +298,8 @@       | otherwise          = fmap  substLogFileName givenTemplate      defaultTemplate = toPathTemplate $-                        cabalLogsDirectory </> "$pkgid" <.> "log"+                        cabalLogsDirectory </>+                        "$compiler" </> "$libname" <.> "log"     givenTemplate   = flagToMaybe projectConfigLogFile      useDefaultTemplate@@ -338,9 +369,10 @@ readProjectConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig readProjectConfig verbosity projectRootDir = do     global <- readGlobalConfig verbosity-    local  <- readProjectLocalConfig      verbosity projectRootDir-    extra  <- readProjectLocalExtraConfig verbosity projectRootDir-    return (global <> local <> extra)+    local  <- readProjectLocalConfig       verbosity projectRootDir+    freeze <- readProjectLocalFreezeConfig verbosity projectRootDir+    extra  <- readProjectLocalExtraConfig  verbosity projectRootDir+    return (global <> local <> freeze <> extra)   -- | Reads an explicit @cabal.project@ file in the given project root dir,@@ -352,7 +384,7 @@   if usesExplicitProjectRoot     then do       monitorFiles [monitorFileHashed projectFile]-      liftIO readProjectFile+      addProjectFileProvenance <$> liftIO readProjectFile     else do       monitorFiles [monitorNonExistentFile projectFile]       return defaultImplicitProjectConfig@@ -364,6 +396,12 @@         . parseProjectConfig       =<< readFile projectFile +    addProjectFileProvenance config =+      config {+        projectConfigProvenance =+          Set.insert (Explicit projectFile) (projectConfigProvenance config)+      }+     defaultImplicitProjectConfig :: ProjectConfig     defaultImplicitProjectConfig =       mempty {@@ -371,30 +409,48 @@         projectPackages         = [ "./*.cabal" ],          -- This is to automatically pick up deps that we unpack locally.-        projectPackagesOptional = [ "./*/*.cabal" ]-      }+        projectPackagesOptional = [ "./*/*.cabal" ], +        projectConfigProvenance = Set.singleton Implicit+      } --- | Reads a @cabal.project.extra@ file in the given project root dir,+-- | Reads a @cabal.project.local@ file in the given project root dir, -- or returns empty. This file gets written by @cabal configure@, or in -- principle can be edited manually or by other tools. -- readProjectLocalExtraConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig-readProjectLocalExtraConfig verbosity projectRootDir = do-    hasExtraConfig <- liftIO $ doesFileExist projectExtraConfigFile-    if hasExtraConfig-      then do monitorFiles [monitorFileHashed projectExtraConfigFile]-              liftIO readProjectExtraConfigFile-      else do monitorFiles [monitorNonExistentFile projectExtraConfigFile]+readProjectLocalExtraConfig verbosity =+    readProjectExtensionFile verbosity "local"+                             "project local configuration file"++-- | Reads a @cabal.project.freeze@ file in the given project root dir,+-- or returns empty. This file gets written by @cabal freeze@, or in+-- principle can be edited manually or by other tools.+--+readProjectLocalFreezeConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig+readProjectLocalFreezeConfig verbosity =+    readProjectExtensionFile verbosity "freeze"+                             "project freeze file"++-- | Reads a named config file in the given project root dir, or returns empty.+--+readProjectExtensionFile :: Verbosity -> String -> FilePath+                         -> FilePath -> Rebuild ProjectConfig+readProjectExtensionFile verbosity extensionName extensionDescription+                         projectRootDir = do+    exists <- liftIO $ doesFileExist extensionFile+    if exists+      then do monitorFiles [monitorFileHashed extensionFile]+              liftIO readExtensionFile+      else do monitorFiles [monitorNonExistentFile extensionFile]               return mempty   where-    projectExtraConfigFile = projectRootDir </> "cabal.project.extra"+    extensionFile = projectRootDir </> "cabal.project" <.> extensionName -    readProjectExtraConfigFile =-          reportParseResult verbosity "project extra configuration file"-                            projectExtraConfigFile+    readExtensionFile =+          reportParseResult verbosity extensionDescription extensionFile         . parseProjectConfig-      =<< readFile projectExtraConfigFile+      =<< readFile extensionFile   -- | Parse the 'ProjectConfig' format.@@ -418,15 +474,24 @@     showLegacyProjectConfig . convertToLegacyProjectConfig  --- | Write a @cabal.project.extra@ file in the given project root dir.+-- | Write a @cabal.project.local@ file in the given project root dir. -- writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO () writeProjectLocalExtraConfig projectRootDir =     writeProjectConfigFile projectExtraConfigFile   where-    projectExtraConfigFile = projectRootDir </> "cabal.project.extra"+    projectExtraConfigFile = projectRootDir </> "cabal.project.local"  +-- | Write a @cabal.project.freeze@ file in the given project root dir.+--+writeProjectLocalFreezeConfig :: FilePath -> ProjectConfig -> IO ()+writeProjectLocalFreezeConfig projectRootDir =+    writeProjectConfigFile projectFreezeConfigFile+  where+    projectFreezeConfigFile = projectRootDir </> "cabal.project.freeze"++ -- | Write in the @cabal.project@ format to the given file. -- writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()@@ -462,6 +527,10 @@ -- Reading packages in the project -- +-- | The location of a package as part of a project. Local file paths are+-- either absolute (if the user specified it as such) or they are relative+-- to the project root.+-- data ProjectPackageLocation =      ProjectPackageLocalCabalFile FilePath    | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file@@ -474,11 +543,21 @@  -- | Exception thrown by 'findProjectPackages'. ---newtype BadPackageLocations = BadPackageLocations [BadPackageLocation]+data BadPackageLocations+   = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]+#if MIN_VERSION_base(4,8,0)   deriving (Show, Typeable)+#else+  deriving (Typeable) -instance Exception BadPackageLocations---TODO: [required eventually] displayException for nice rendering+instance Show BadPackageLocations where+  show = renderBadPackageLocations+#endif++instance Exception BadPackageLocations where+#if MIN_VERSION_base(4,8,0)+  displayException = renderBadPackageLocations+#endif --TODO: [nice to have] custom exception subclass for Doc rendering, colour etc  data BadPackageLocation@@ -497,7 +576,96 @@    | BadLocDirManyCabalFiles   String   deriving Show +renderBadPackageLocations :: BadPackageLocations -> String+renderBadPackageLocations (BadPackageLocations provenance bpls)+      -- There is no provenance information,+      -- render standard bad package error information.+    | Set.null provenance = renderErrors renderBadPackageLocation +      -- The configuration is implicit, render bad package locations+      -- using possibly specialized error messages.+    | Set.singleton Implicit == provenance =+        renderErrors renderImplicitBadPackageLocation++      -- The configuration contains both implicit and explicit provenance.+      -- This should not occur, and a message is output to assist debugging.+    | Implicit `Set.member` provenance =+           "Warning: both implicit and explicit configuration is present."+        ++ renderExplicit++      -- The configuration was read from one or more explicit path(s),+      -- list the locations and render the bad package error information.+      -- The intent is to supersede this with the relevant location information+      -- per package error.+    | otherwise = renderExplicit+  where+    renderErrors f = unlines (map f bpls)++    renderExplicit =+           "When using configuration(s) from "+        ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance))+        ++ ", the following errors occurred:\n"+        ++ renderErrors renderBadPackageLocation++    getExplicit (Explicit path) = Just path+    getExplicit Implicit        = Nothing++--TODO: [nice to have] keep track of the config file (and src loc) packages+-- were listed, to use in error messages++-- | Render bad package location error information for the implicit+-- @cabal.project@ configuration.+--+-- TODO: This is currently not fully realized, with only one of the implicit+-- cases handled. More cases should be added with informative help text+-- about the issues related specifically when having no project configuration+-- is present.+renderImplicitBadPackageLocation :: BadPackageLocation -> String+renderImplicitBadPackageLocation bpl = case bpl of+    BadLocGlobEmptyMatch pkglocstr ->+        "No cabal.project file or cabal file matching the default glob '"+     ++ pkglocstr ++ "' was found.\n"+     ++ "Please create a package description file <pkgname>.cabal "+     ++ "or a cabal.project file referencing the packages you "+     ++ "want to build."+    _ -> renderBadPackageLocation bpl++renderBadPackageLocation :: BadPackageLocation -> String+renderBadPackageLocation bpl = case bpl of+    BadPackageLocationFile badmatch ->+        renderBadPackageLocationMatch badmatch+    BadLocGlobEmptyMatch pkglocstr ->+        "The package location glob '" ++ pkglocstr+     ++ "' does not match any files or directories."+    BadLocGlobBadMatches pkglocstr failures ->+        "The package location glob '" ++ pkglocstr ++ "' does not match any "+     ++ "recognised forms of package. "+     ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures+    BadLocUnexpectedUriScheme pkglocstr ->+        "The package location URI '" ++ pkglocstr ++ "' does not use a "+     ++ "supported URI scheme. The supported URI schemes are http, https and "+     ++ "file."+    BadLocUnrecognisedUri pkglocstr ->+        "The package location URI '" ++ pkglocstr ++ "' does not appear to "+     ++ "be a valid absolute URI."+    BadLocUnrecognised pkglocstr ->+        "The package location syntax '" ++ pkglocstr ++ "' is not recognised."++renderBadPackageLocationMatch :: BadPackageLocationMatch -> String+renderBadPackageLocationMatch bplm = case bplm of+    BadLocUnexpectedFile pkglocstr ->+        "The package location '" ++ pkglocstr ++ "' is not recognised. The "+     ++ "supported file targets are .cabal files, .tar.gz tarballs or package "+     ++ "directories (i.e. directories containing a .cabal file)."+    BadLocNonexistantFile pkglocstr ->+        "The package location '" ++ pkglocstr ++ "' does not exist."+    BadLocDirNoCabalFile pkglocstr ->+        "The package directory '" ++ pkglocstr ++ "' does not contain any "+     ++ ".cabal file."+    BadLocDirManyCabalFiles pkglocstr ->+        "The package directory '" ++ pkglocstr ++ "' contains multiple "+     ++ ".cabal files (which is not currently supported)."+ -- | Given the project config, -- -- Throws 'BadPackageLocations'.@@ -517,7 +685,7 @@       (problems, pkglocs) <-         partitionEithers <$> mapM (findPackageLocation required) pkglocstr       unless (null problems) $-        liftIO $ throwIO $ BadPackageLocations problems+        liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems       return (concat pkglocs)  @@ -556,6 +724,10 @@           | recognisedScheme && not (null host) ->             Just (Right [ProjectPackageRemoteTarball uri]) +          --TODO: [required eventually] handle file: urls which do have a null+          -- host. translate URI into filepath and use ProjectPackageLocalTarball+          -- or keep as file url and use ProjectPackageRemoteTarball?+           | not recognisedScheme && not (null host) ->             Just (Left (BadLocUnexpectedUriScheme pkglocstr)) @@ -572,7 +744,7 @@       case simpleParse pkglocstr of         Nothing   -> return Nothing         Just glob -> liftM Just $ do-          matches <- matchFileGlob projectRootDir glob+          matches <- matchFileGlob glob           case matches of             [] | isJust (isTrivialFilePathGlob glob)                -> return (Left (BadPackageLocationFile@@ -583,9 +755,11 @@             _  -> do               (failures, pkglocs) <- partitionEithers <$>                                      mapM checkFilePackageMatch matches-              if null pkglocs-                then return (Left (BadLocGlobBadMatches pkglocstr failures))-                else return (Right pkglocs)+              return $! case (failures, pkglocs) of+                ([failure], []) | isJust (isTrivialFilePathGlob glob)+                        -> Left (BadPackageLocationFile failure)+                (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)+                _       -> Right pkglocs       checkIsSingleFilePackage pkglocstr = do@@ -602,31 +776,34 @@     checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch                                                        ProjectPackageLocation)     checkFilePackageMatch pkglocstr = do-      let filename = projectRootDir </> pkglocstr-      isDir  <- liftIO $ doesDirectoryExist filename-      parentDirExists <- case takeDirectory filename of+      -- The pkglocstr may be absolute or may be relative to the project root.+      -- Either way, </> does the right thing here. We return relative paths if+      -- they were relative in the first place.+      let abspath = projectRootDir </> pkglocstr+      isFile <- liftIO $ doesFileExist abspath+      isDir  <- liftIO $ doesDirectoryExist abspath+      parentDirExists <- case takeDirectory abspath of                            []  -> return False                            dir -> liftIO $ doesDirectoryExist dir       case () of         _ | isDir-         -> do let dirname = filename -- now we know its a dir-                   glob    = globStarDotCabal pkglocstr-               matches <- matchFileGlob projectRootDir glob+         -> do matches <- matchFileGlob (globStarDotCabal pkglocstr)                case matches of-                 [match]+                 [cabalFile]                      -> return (Right (ProjectPackageLocalDirectory-                                         dirname cabalFile))-                   where-                     cabalFile = dirname </> match+                                         pkglocstr cabalFile))                  []  -> return (Left (BadLocDirNoCabalFile pkglocstr))                  _   -> return (Left (BadLocDirManyCabalFiles pkglocstr)) -          | extensionIsTarGz filename-         -> return (Right (ProjectPackageLocalTarball filename))+          | extensionIsTarGz pkglocstr+         -> return (Right (ProjectPackageLocalTarball pkglocstr)) -          | takeExtension filename == ".cabal"-         -> return (Right (ProjectPackageLocalCabalFile filename))+          | takeExtension pkglocstr == ".cabal"+         -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) +          | isFile+         -> return (Left (BadLocUnexpectedFile pkglocstr))+           | parentDirExists          -> return (Left (BadLocNonexistantFile pkglocstr)) @@ -638,12 +815,19 @@                       && takeExtension (dropExtension f) == ".tar"  +-- | A glob to find all the cabal files in a directory.+--+-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.+-- The directory part can be either absolute or relative.+-- globStarDotCabal :: FilePath -> FilePathGlob-globStarDotCabal =-    FilePathGlob FilePathRelative-  . foldr (\dirpart -> GlobDir [Literal dirpart])-          (GlobFile [WildCard, Literal ".cabal"])-  . splitDirectories+globStarDotCabal dir =+    FilePathGlob+      (if isAbsolute dir then FilePathRoot root else FilePathRelative)+      (foldr (\d -> GlobDir [Literal d])+             (GlobFile [WildCard, Literal ".cabal"]) dirComponents)+  where+    (root, dirComponents) = fmap splitDirectories (splitDrive dir)   --TODO: [code cleanup] use sufficiently recent transformers package@@ -655,6 +839,11 @@     Just x  -> return (Just x)  +-- | Read the @.cabal@ file of the given package.+--+-- Note here is where we convert from project-root relative paths to absolute+-- paths.+-- readSourcePackage :: Verbosity -> ProjectPackageLocation                   -> Rebuild UnresolvedSourcePackage readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) =@@ -663,14 +852,71 @@     dir = takeDirectory cabalFile  readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do-    -- no need to monitorFiles because findProjectCabalFiles did it already-    pkgdesc <- liftIO $ readPackageDescription verbosity cabalFile+    monitorFiles [monitorFileHashed cabalFile]+    root <- askRoot+    pkgdesc <- liftIO $ readPackageDescription verbosity (root </> cabalFile)     return SourcePackage {       packageInfoId        = packageId pkgdesc,       packageDescription   = pkgdesc,-      packageSource        = LocalUnpackedPackage dir,+      packageSource        = LocalUnpackedPackage (root </> dir),       packageDescrOverride = Nothing     } readSourcePackage _verbosity _ =     fail $ "TODO: add support for fetching and reading local tarballs, remote "         ++ "tarballs, remote repos and passing named packages through"+++---------------------------------------------+-- Checking configuration sanity+--++data BadPerPackageCompilerPaths+   = BadPerPackageCompilerPaths [(PackageName, String)]+#if MIN_VERSION_base(4,8,0)+  deriving (Show, Typeable)+#else+  deriving (Typeable)++instance Show BadPerPackageCompilerPaths where+  show = renderBadPerPackageCompilerPaths+#endif++instance Exception BadPerPackageCompilerPaths where+#if MIN_VERSION_base(4,8,0)+  displayException = renderBadPerPackageCompilerPaths+#endif+--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc++renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String+renderBadPerPackageCompilerPaths+  (BadPerPackageCompilerPaths ((pkgname, progname) : _)) =+    "The path to the compiler program (or programs used by the compiler) "+ ++ "cannot be specified on a per-package basis in the cabal.project file "+ ++ "(i.e. setting the '" ++ progname ++ "-location' for package '"+ ++ display pkgname ++ "'). All packages have to use the same compiler, so "+ ++ "specify the path in a global 'program-locations' section."+ --TODO: [nice to have] better format control so we can pretty-print the+ -- offending part of the project file. Currently the line wrapping breaks any+ -- formatting.+renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths"++-- | The project configuration is not allowed to specify program locations for+-- programs used by the compiler as these have to be the same for each set of+-- packages.+--+-- We cannot check this until we know which programs the compiler uses, which+-- in principle is not until we've configured the compiler.+--+-- Throws 'BadPerPackageCompilerPaths'+--+checkBadPerPackageCompilerPaths :: [ConfiguredProgram]+                                -> Map PackageName PackageConfig+                                -> IO ()+checkBadPerPackageCompilerPaths compilerPrograms packagesConfig =+    case [ (pkgname, progname)+         | let compProgNames = Set.fromList (map programId compilerPrograms)+         ,  (pkgname, pkgconf) <- Map.toList packagesConfig+         , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf))+         , progname `Set.member` compProgNames ] of+      [] -> return ()+      ps -> throwIO (BadPerPackageCompilerPaths ps)
cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveGeneric #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric #-}  -- | Project configuration, implementation in terms of legacy types. --@@ -20,14 +20,17 @@     renderPackageLocationToken,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types          ( RemoteRepo(..), emptyRemoteRepo )-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..) ) import Distribution.Client.Config          ( SavedConfig(..), remoteRepoFields ) +import Distribution.Solver.Types.ConstraintSource+ import Distribution.Package import Distribution.PackageDescription          ( SourceRepo(..), RepoKind(..) )@@ -39,8 +42,8 @@          ( Flag(Flag), toFlag, fromFlagOrDefault          , ConfigFlags(..), configureOptions          , HaddockFlags(..), haddockOptions, defaultHaddockFlags-         , programConfigurationPaths', splitArgs-         , AllowNewer(..) )+         , programDbPaths', splitArgs+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags@@ -76,15 +79,7 @@          ( CommandUI(commandOptions), ShowOrParseArgs(..)          , OptionField, option, reqArg' ) -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import Control.Monad-import Data.Map (Map) import qualified Data.Map as Map-import Data.Char (isSpace)-import Distribution.Compat.Semigroup-import GHC.Generics (Generic)  ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types@@ -107,7 +102,7 @@         legacySharedConfig      :: LegacySharedConfig,        legacyLocalConfig       :: LegacyPackageConfig,-       legacySpecificConfig    :: Map PackageName LegacyPackageConfig+       legacySpecificConfig    :: MapMappend PackageName LegacyPackageConfig      } deriving Generic  instance Monoid LegacyProjectConfig where@@ -243,6 +238,7 @@        projectConfigBuildOnly       = configBuildOnly,       projectConfigShared          = configAllPackages,+      projectConfigProvenance      = mempty,       projectConfigLocalPackages   = configLocalPackages,       projectConfigSpecificPackage = fmap perPackage legacySpecificConfig     }@@ -280,20 +276,15 @@     } = globalFlags      ConfigFlags {-      configProgramPaths,-      configProgramArgs,-      configProgramPathExtra    = projectConfigProgramPathExtra,       configHcFlavor            = projectConfigHcFlavor,       configHcPath              = projectConfigHcPath,       configHcPkg               = projectConfigHcPkg,     --configInstallDirs         = projectConfigInstallDirs,     --configUserInstall         = projectConfigUserInstall,     --configPackageDBs          = projectConfigPackageDBs,-      configConfigurationsFlags = projectConfigFlagAssignment,+      configAllowOlder          = projectConfigAllowOlder,       configAllowNewer          = projectConfigAllowNewer     } = configFlags-    projectConfigProgramPaths   = Map.fromList configProgramPaths-    projectConfigProgramArgs    = Map.fromList configProgramArgs      ConfigExFlags {       configCabalVersion        = projectConfigCabalVersion,@@ -307,9 +298,11 @@     --installReinstall          = projectConfigReinstall,     --installAvoidReinstalls    = projectConfigAvoidReinstalls,     --installOverrideReinstall  = projectConfigOverrideReinstall,+      installIndexState         = projectConfigIndexState,       installMaxBackjumps       = projectConfigMaxBackjumps,     --installUpgradeDeps        = projectConfigUpgradeDeps,       installReorderGoals       = projectConfigReorderGoals,+      installCountConflicts     = projectConfigCountConflicts,     --installIndependentGoals   = projectConfigIndependentGoals,     --installShadowPkgs         = projectConfigShadowPkgs,       installStrongFlags        = projectConfigStrongFlags@@ -326,6 +319,9 @@     PackageConfig{..}   where     ConfigFlags {+      configProgramPaths,+      configProgramArgs,+      configProgramPathExtra    = packageConfigProgramPathExtra,       configVanillaLib          = packageConfigVanillaLib,       configProfLib             = packageConfigProfLib,       configSharedLib           = packageConfigSharedLib,@@ -345,7 +341,7 @@       configExtraLibDirs        = packageConfigExtraLibDirs,       configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,       configExtraIncludeDirs    = packageConfigExtraIncludeDirs,-      configConfigurationsFlags = _projectConfigFlagAssignment, --TODO: should be per pkg+      configConfigurationsFlags = packageConfigFlagAssignment,       configTests               = packageConfigTests,       configBenchmarks          = packageConfigBenchmarks,       configCoverage            = coverage,@@ -353,6 +349,8 @@       configDebugInfo           = packageConfigDebugInfo,       configRelocatable         = packageConfigRelocatable     } = configFlags+    packageConfigProgramPaths   = MapLast    (Map.fromList configProgramPaths)+    packageConfigProgramArgs    = MapMappend (Map.fromList configProgramArgs)      packageConfigCoverage       = coverage <> libcoverage     --TODO: defer this merging to the resolve phase@@ -366,6 +364,7 @@       haddockHoogle             = packageConfigHaddockHoogle,       haddockHtml               = packageConfigHaddockHtml,       haddockHtmlLocation       = packageConfigHaddockHtmlLocation,+      haddockForeignLibs        = packageConfigHaddockForeignLibs,       haddockExecutables        = packageConfigHaddockExecutables,       haddockTestSuites         = packageConfigHaddockTestSuites,       haddockBenchmarks         = packageConfigHaddockBenchmarks,@@ -391,7 +390,7 @@     GlobalFlags {       globalCacheDir          = projectConfigCacheDir,       globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = projectConfigWorldFile,+      globalWorldFile         = _,       globalHttpTransport     = projectConfigHttpTransport,       globalIgnoreExpiry      = projectConfigIgnoreExpiry     } = globalFlags@@ -404,7 +403,7 @@       installDryRun             = projectConfigDryRun,       installOnly               = _,       installOnlyDeps           = projectConfigOnlyDeps,-      installRootCmd            = projectConfigRootCmd,+      installRootCmd            = _,       installSummaryFile        = projectConfigSummaryFile,       installLogFile            = projectConfigLogFile,       installBuildReports       = projectConfigBuildReports,@@ -412,6 +411,7 @@       installSymlinkBinDir      = projectConfigSymlinkBinDir,       installOneShot            = projectConfigOneShot,       installNumJobs            = projectConfigNumJobs,+      installKeepGoing          = projectConfigKeepGoing,       installOfflineMode        = projectConfigOfflineMode     } = installFlags @@ -467,7 +467,7 @@       globalCacheDir          = projectConfigCacheDir,       globalLocalRepos        = projectConfigLocalRepos,       globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = projectConfigWorldFile,+      globalWorldFile         = mempty,       globalRequireSandbox    = mempty,       globalIgnoreSandbox     = mempty,       globalIgnoreExpiry      = projectConfigIgnoreExpiry,@@ -476,6 +476,7 @@      configFlags = mempty {       configVerbosity     = projectConfigVerbosity,+      configAllowOlder    = projectConfigAllowOlder,       configAllowNewer    = projectConfigAllowNewer     } @@ -496,12 +497,14 @@       installMaxBackjumps      = projectConfigMaxBackjumps,       installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,       installReorderGoals      = projectConfigReorderGoals,+      installCountConflicts    = projectConfigCountConflicts,       installIndependentGoals  = mempty, --projectConfigIndependentGoals,       installShadowPkgs        = mempty, --projectConfigShadowPkgs,       installStrongFlags       = projectConfigStrongFlags,       installOnly              = mempty,       installOnlyDeps          = projectConfigOnlyDeps,-      installRootCmd           = projectConfigRootCmd,+      installIndexState        = projectConfigIndexState,+      installRootCmd           = mempty, --no longer supported       installSummaryFile       = projectConfigSummaryFile,       installLogFile           = projectConfigLogFile,       installBuildReports      = projectConfigBuildReports,@@ -509,6 +512,7 @@       installSymlinkBinDir     = projectConfigSymlinkBinDir,       installOneShot           = projectConfigOneShot,       installNumJobs           = projectConfigNumJobs,+      installKeepGoing         = projectConfigKeepGoing,       installRunTests          = mempty,       installOfflineMode       = projectConfigOfflineMode     }@@ -528,13 +532,15 @@     }   where     configFlags = ConfigFlags {+      configArgs                = mempty,       configPrograms_           = mempty,-      configProgramPaths        = Map.toList projectConfigProgramPaths,-      configProgramArgs         = Map.toList projectConfigProgramArgs,-      configProgramPathExtra    = projectConfigProgramPathExtra,+      configProgramPaths        = mempty,+      configProgramArgs         = mempty,+      configProgramPathExtra    = mempty,       configHcFlavor            = projectConfigHcFlavor,       configHcPath              = projectConfigHcPath,       configHcPkg               = projectConfigHcPkg,+      configInstantiateWith     = mempty,       configVanillaLib          = mempty,       configProfLib             = mempty,       configSharedLib           = mempty,@@ -550,6 +556,7 @@       configInstallDirs         = mempty,       configScratchDir          = mempty,       configDistPref            = mempty,+      configCabalFilePath       = mempty,       configVerbosity           = mempty,       configUserInstall         = mempty, --projectConfigUserInstall,       configPackageDBs          = mempty, --projectConfigPackageDBs,@@ -563,7 +570,8 @@       configDependencies        = mempty,       configExtraIncludeDirs    = mempty,       configIPID                = mempty,-      configConfigurationsFlags = projectConfigFlagAssignment,+      configCID                 = mempty,+      configConfigurationsFlags = mempty,       configTests               = mempty,       configCoverage            = mempty, --TODO: don't merge       configLibCoverage         = mempty, --TODO: don't merge@@ -572,6 +580,7 @@       configFlagError           = mempty,                --TODO: ???       configRelocatable         = mempty,       configDebugInfo           = mempty,+      configAllowOlder          = mempty,       configAllowNewer          = mempty     } @@ -589,13 +598,15 @@     }   where     configFlags = ConfigFlags {+      configArgs                = mempty,       configPrograms_           = configPrograms_ mempty,-      configProgramPaths        = mempty,-      configProgramArgs         = mempty,-      configProgramPathExtra    = mempty,+      configProgramPaths        = Map.toList (getMapLast packageConfigProgramPaths),+      configProgramArgs         = Map.toList (getMapMappend packageConfigProgramArgs),+      configProgramPathExtra    = packageConfigProgramPathExtra,       configHcFlavor            = mempty,       configHcPath              = mempty,       configHcPkg               = mempty,+      configInstantiateWith     = mempty,       configVanillaLib          = packageConfigVanillaLib,       configProfLib             = packageConfigProfLib,       configSharedLib           = packageConfigSharedLib,@@ -611,6 +622,7 @@       configInstallDirs         = mempty,       configScratchDir          = mempty,       configDistPref            = mempty,+      configCabalFilePath       = mempty,       configVerbosity           = mempty,       configUserInstall         = mempty,       configPackageDBs          = mempty,@@ -624,7 +636,8 @@       configDependencies        = mempty,       configExtraIncludeDirs    = packageConfigExtraIncludeDirs,       configIPID                = mempty,-      configConfigurationsFlags = mempty,+      configCID                 = mempty,+      configConfigurationsFlags = packageConfigFlagAssignment,       configTests               = packageConfigTests,       configCoverage            = packageConfigCoverage, --TODO: don't merge       configLibCoverage         = packageConfigCoverage, --TODO: don't merge@@ -633,6 +646,7 @@       configFlagError           = mempty,                --TODO: ???       configRelocatable         = packageConfigRelocatable,       configDebugInfo           = packageConfigDebugInfo,+      configAllowOlder          = mempty,       configAllowNewer          = mempty     } @@ -648,6 +662,7 @@       haddockHtml          = packageConfigHaddockHtml,       haddockHtmlLocation  = packageConfigHaddockHtmlLocation,       haddockForHackage    = mempty, --TODO: added recently+      haddockForeignLibs   = packageConfigHaddockForeignLibs,       haddockExecutables   = packageConfigHaddockExecutables,       haddockTestSuites    = packageConfigHaddockTestSuites,       haddockBenchmarks    = packageConfigHaddockBenchmarks,@@ -775,7 +790,7 @@       ]   . filterFields       [ "remote-repo-cache"-      , "logs-dir", "world-file", "ignore-expiry", "http-transport"+      , "logs-dir", "ignore-expiry", "http-transport"       ]   . commandOptionsToFields   ) (commandOptions (globalCommand []) ParseArgs)@@ -784,9 +799,16 @@       legacyConfigureShFlags       (\flags conf -> conf { legacyConfigureShFlags = flags })   . addFields+      [ simpleField "allow-older"+        (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)+        (fmap unAllowOlder . configAllowOlder)+        (\v conf -> conf { configAllowOlder = fmap AllowOlder v })+      ]+  . addFields       [ simpleField "allow-newer"-        (maybe mempty dispAllowNewer) (fmap Just parseAllowNewer)-        configAllowNewer (\v conf -> conf { configAllowNewer = v })+        (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)+        (fmap unAllowNewer . configAllowNewer)+        (\v conf -> conf { configAllowNewer = fmap AllowNewer v })       ]   . filterFields ["verbose"]   . commandOptionsToFields@@ -825,26 +847,27 @@       , "root-cmd", "symlink-bindir"       , "build-log"       , "remote-build-reporting", "report-planning-failure"-      , "one-shot", "jobs", "offline"+      , "one-shot", "jobs", "keep-going", "offline"         -- solver flags:-      , "max-backjumps", "reorder-goals", "strong-flags"+      , "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags"+      , "index-state"       ]   . commandOptionsToFields   ) (installOptions ParseArgs)   where     constraintSrc = ConstraintSourceProjectConfig "TODO" -parseAllowNewer :: ReadP r AllowNewer-parseAllowNewer =-     ((const AllowNewerNone <$> (Parse.string "none" +++ Parse.string "None"))-  +++ (const AllowNewerAll  <$> (Parse.string "all"  +++ Parse.string "All")))-  <++ (      AllowNewerSome <$> parseOptCommaList parse)+parseRelaxDeps :: ReadP r RelaxDeps+parseRelaxDeps =+     ((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None"))+  +++ (const RelaxDepsAll  <$> (Parse.string "all"  +++ Parse.string "All")))+  <++ (      RelaxDepsSome <$> parseOptCommaList parse) -dispAllowNewer :: AllowNewer -> Doc-dispAllowNewer  AllowNewerNone       = Disp.text "None"-dispAllowNewer (AllowNewerSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma-                                                 . map disp $ pkgs-dispAllowNewer  AllowNewerAll        = Disp.text "All"+dispRelaxDeps :: RelaxDeps -> Doc+dispRelaxDeps  RelaxDepsNone       = Disp.text "None"+dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma+                                               . map disp $ pkgs+dispRelaxDeps  RelaxDepsAll        = Disp.text "All"   legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]@@ -879,13 +902,13 @@           (\v conf -> conf { configConfigurationsFlags = v })       ]   . filterFields-      [ "compiler", "with-compiler", "with-hc-pkg"+      [ "with-compiler", "with-hc-pkg"       , "program-prefix", "program-suffix"       , "library-vanilla", "library-profiling"       , "shared", "executable-dynamic"       , "profiling", "executable-profiling"       , "profiling-detail", "library-profiling-detail"-      , "optimization", "debug-info", "library-for-ghci", "split-objs"+      , "library-for-ghci", "split-objs"       , "executable-stripping", "library-stripping"       , "tests", "benchmarks"       , "coverage", "library-coverage"@@ -921,6 +944,7 @@       ("haddock-"++)   . filterFields       [ "hoogle", "html", "html-location"+      , "foreign-libraries"       , "executables", "tests", "benchmarks", "all", "internal", "css"       , "hyperlink-source", "hscolour-css"       , "contents-location", "keep-temp-files"@@ -1050,11 +1074,20 @@                                    configProgramArgs  = args                                  }                                }-                             ),+                             )+                        ++ liftFields+                             legacyConfigureFlags+                             (\flags pkgconf -> pkgconf {+                                 legacyConfigureFlags = flags+                               }+                             )+                             programLocationsFieldDescrs,       sectionSubsections = [],       sectionGet         = \projconf ->                              [ (display pkgname, pkgconf)-                             | (pkgname, pkgconf) <- Map.toList (legacySpecificConfig projconf) ],+                             | (pkgname, pkgconf) <-+                                 Map.toList . getMapMappend+                               . legacySpecificConfig $ projconf ],       sectionSet         =         \lineno pkgnamestr pkgconf projconf -> do           pkgname <- case simpleParse pkgnamestr of@@ -1064,8 +1097,9 @@                              ++ "as an argument"           return projconf {             legacySpecificConfig =+              MapMappend $               Map.insertWith mappend pkgname pkgconf-                             (legacySpecificConfig projconf)+                             (getMapMappend $ legacySpecificConfig projconf)           },       sectionEmpty       = mempty     }@@ -1073,11 +1107,11 @@ programOptionsFieldDescrs :: (a -> [(String, [String])])                           -> ([(String, [String])] -> a -> a)                           -> [FieldDescr a]-programOptionsFieldDescrs get set =+programOptionsFieldDescrs get' set =     commandOptionsToFields-  $ programConfigurationOptions+  $ programDbOptions       defaultProgramDb-      ParseArgs get set+      ParseArgs get' set  programOptionsSectionDescr :: SectionDescr LegacyPackageConfig programOptionsSectionDescr =@@ -1102,7 +1136,7 @@ programLocationsFieldDescrs :: [FieldDescr ConfigFlags] programLocationsFieldDescrs =      commandOptionsToFields-   $ programConfigurationPaths'+   $ programDbPaths'        (++ "-location")        defaultProgramDb        ParseArgs@@ -1128,25 +1162,25 @@     }  --- | For each known program @PROG@ in 'progConf', produce a @PROG-options@+-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ -- 'OptionField'.-programConfigurationOptions+programDbOptions   :: ProgramDb   -> ShowOrParseArgs   -> (flags -> [(String, [String])])   -> ([(String, [String])] -> (flags -> flags))   -> [OptionField flags]-programConfigurationOptions progConf showOrParseArgs get set =+programDbOptions progDb showOrParseArgs get' set =   case showOrParseArgs of     -- we don't want a verbose help text list so we just show a generic one:     ShowArgs  -> [programOptions  "PROG"]     ParseArgs -> map (programOptions . programName . fst)-                 (knownPrograms progConf)+                 (knownPrograms progDb)   where     programOptions prog =       option "" [prog ++ "-options"]         ("give extra options to " ++ prog)-        get set+        get' set         (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])            (\progArgs -> [ joinsArgs args                          | (prog', args) <- progArgs, prog==prog' ]))@@ -1205,11 +1239,11 @@ -- of parseOptCommaList below listFieldWithSep :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listFieldWithSep separator name showF readF get set =-  liftField get set' $+listFieldWithSep separator name showF readF get' set =+  liftField get' set' $     ParseUtils.field name showF' (parseOptCommaList readF)   where-    set' xs b = set (get b ++ xs) b+    set' xs b = set (get' b ++ xs) b     showF'    = separator . map showF  --TODO: [code cleanup] local redefinition that should replace the version in
cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}  -- | Handling project configuration, types. --@@ -8,23 +8,33 @@     ProjectConfig(..),     ProjectConfigBuildOnly(..),     ProjectConfigShared(..),+    ProjectConfigProvenance(..),     PackageConfig(..),      -- * Resolving configuration     SolverSettings(..),     BuildTimeSettings(..), +    -- * Extra useful Monoids+    MapLast(..),+    MapMappend(..),   ) where  import Distribution.Client.Types          ( RemoteRepo ) import Distribution.Client.Dependency.Types-         ( PreSolver, ConstraintSource )+         ( PreSolver ) import Distribution.Client.Targets          ( UserConstraint )-import Distribution.Client.BuildReports.Types +import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) +import Distribution.Client.IndexUtils.Timestamp+         ( IndexState )++import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.ConstraintSource+ import Distribution.Package          ( PackageName, PackageId, UnitId, Dependency ) import Distribution.Version@@ -37,7 +47,7 @@          ( Compiler, CompilerFlavor          , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup-         ( Flag, AllowNewer(..) )+         ( Flag, AllowNewer(..), AllowOlder(..) ) import Distribution.Simple.InstallDirs          ( PathTemplate ) import Distribution.Utils.NubList@@ -46,9 +56,12 @@          ( Verbosity )  import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set) import Distribution.Compat.Binary (Binary) import Distribution.Compat.Semigroup import GHC.Generics (Generic)+import Data.Typeable   -------------------------------@@ -76,14 +89,15 @@    = ProjectConfig {         -- | Packages in this project, including local dirs, local .cabal files-       -- local and remote tarballs. Where these are file globs, they must-       -- match something.+       -- local and remote tarballs. When these are file globs, they must+       -- match at least one package.        projectPackages              :: [String],         -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that        -- file globs are allowed to match nothing. The primary use case for        -- this is to be able to say @optional-packages: */@ to automagically-       -- pick up deps that we unpack locally.+       -- pick up deps that we unpack locally without erroring when+       -- there aren't any.        projectPackagesOptional      :: [String],         -- | Packages in this project from remote source repositories.@@ -92,12 +106,18 @@        -- | Packages in this project from hackage repositories.        projectPackagesNamed         :: [Dependency], +       -- See respective types for an explanation of what these+       -- values are about:        projectConfigBuildOnly       :: ProjectConfigBuildOnly,        projectConfigShared          :: ProjectConfigShared,+       projectConfigProvenance      :: Set ProjectConfigProvenance,++       -- | Configuration to be applied to *local* packages; i.e.,+       -- any packages which are explicitly named in `cabal.project`.        projectConfigLocalPackages   :: PackageConfig,-       projectConfigSpecificPackage :: Map PackageName PackageConfig+       projectConfigSpecificPackage :: MapMappend PackageName PackageConfig      }-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Typeable)  -- | That part of the project configuration that only affects /how/ we build -- and not the /value/ of the things we build. This means this information@@ -116,14 +136,13 @@        projectConfigSymlinkBinDir         :: Flag FilePath,        projectConfigOneShot               :: Flag Bool,        projectConfigNumJobs               :: Flag (Maybe Int),+       projectConfigKeepGoing             :: Flag Bool,        projectConfigOfflineMode           :: Flag Bool,        projectConfigKeepTempFiles         :: Flag Bool,        projectConfigHttpTransport         :: Flag String,        projectConfigIgnoreExpiry          :: Flag Bool,        projectConfigCacheDir              :: Flag FilePath,-       projectConfigLogsDir               :: Flag FilePath,-       projectConfigWorldFile             :: Flag FilePath,-       projectConfigRootCmd               :: Flag String+       projectConfigLogsDir               :: Flag FilePath      }   deriving (Eq, Show, Generic) @@ -133,9 +152,6 @@ -- data ProjectConfigShared    = ProjectConfigShared {-       projectConfigProgramPaths      :: Map String FilePath,-       projectConfigProgramArgs       :: Map String [String],-       projectConfigProgramPathExtra  :: NubList FilePath,        projectConfigHcFlavor          :: Flag CompilerFlavor,        projectConfigHcPath            :: Flag FilePath,        projectConfigHcPkg             :: Flag FilePath,@@ -152,17 +168,19 @@        -- configuration used both by the solver and other phases        projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.        projectConfigLocalRepos        :: NubList FilePath,+       projectConfigIndexState        :: Flag IndexState,         -- solver configuration        projectConfigConstraints       :: [(UserConstraint, ConstraintSource)],        projectConfigPreferences       :: [Dependency],-       projectConfigFlagAssignment    :: FlagAssignment, --TODO: [required eventually] must be per-package, not global        projectConfigCabalVersion      :: Flag Version,  --TODO: [required eventually] unused        projectConfigSolver            :: Flag PreSolver,+       projectConfigAllowOlder        :: Maybe AllowOlder,        projectConfigAllowNewer        :: Maybe AllowNewer,        projectConfigMaxBackjumps      :: Flag Int,-       projectConfigReorderGoals      :: Flag Bool,-       projectConfigStrongFlags       :: Flag Bool+       projectConfigReorderGoals      :: Flag ReorderGoals,+       projectConfigCountConflicts    :: Flag CountConflicts,+       projectConfigStrongFlags       :: Flag StrongFlags         -- More things that only make sense for manual mode, not --local mode        -- too much control!@@ -176,12 +194,31 @@   deriving (Eq, Show, Generic)  +-- | Specifies the provenance of project configuration, whether defaults were+-- used or if the configuration was read from an explicit file path.+data ProjectConfigProvenance++     -- | The configuration is implicit due to no explicit configuration+     -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig'+     -- for how implicit configuration is determined.+   = Implicit++     -- | The path the project configuration was explicitly read from.+     -- | The configuration was explicitly read from the specified 'FilePath'.+   | Explicit FilePath+  deriving (Eq, Ord, Show, Generic)++ -- | Project configuration that is specific to each package, that is where we -- can in principle have different values for different packages in the same -- project. -- data PackageConfig    = PackageConfig {+       packageConfigProgramPaths        :: MapLast String FilePath,+       packageConfigProgramArgs         :: MapMappend String [String],+       packageConfigProgramPathExtra    :: NubList FilePath,+       packageConfigFlagAssignment      :: FlagAssignment,        packageConfigVanillaLib          :: Flag Bool,        packageConfigSharedLib           :: Flag Bool,        packageConfigDynExe              :: Flag Bool,@@ -211,6 +248,7 @@        packageConfigHaddockHoogle       :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockHtml         :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this+       packageConfigHaddockForeignLibs  :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockExecutables  :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockTestSuites   :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockBenchmarks   :: Flag Bool, --TODO: [required eventually] use this@@ -225,9 +263,38 @@ instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly instance Binary ProjectConfigShared+instance Binary ProjectConfigProvenance instance Binary PackageConfig  +-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes+-- the last value rather than the first value for overlapping keys.+newtype MapLast k v = MapLast { getMapLast :: Map k v }+  deriving (Eq, Show, Functor, Generic, Binary, Typeable)++instance Ord k => Monoid (MapLast k v) where+  mempty  = MapLast Map.empty+  mappend = (<>)++instance Ord k => Semigroup (MapLast k v) where+  MapLast a <> MapLast b = MapLast (flip Map.union a b)+  -- rather than Map.union which is the normal Map monoid instance+++-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that+-- 'mappend's values of overlapping keys rather than taking the first.+newtype MapMappend k v = MapMappend { getMapMappend :: Map k v }+  deriving (Eq, Show, Functor, Generic, Binary, Typeable)++instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where+  mempty  = MapMappend Map.empty+  mappend = (<>)++instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where+  MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b)+  -- rather than Map.union which is the normal Map monoid instance++ instance Monoid ProjectConfig where   mempty = gmempty   mappend = (<>)@@ -277,13 +344,17 @@        solverSettingLocalRepos        :: [FilePath],        solverSettingConstraints       :: [(UserConstraint, ConstraintSource)],        solverSettingPreferences       :: [Dependency],-       solverSettingFlagAssignment    :: FlagAssignment, --TODO: [required eventually] must be per-package, not global+       solverSettingFlagAssignment    :: FlagAssignment, -- ^ For all local packages+       solverSettingFlagAssignments   :: Map PackageName FlagAssignment,        solverSettingCabalVersion      :: Maybe Version,  --TODO: [required eventually] unused        solverSettingSolver            :: PreSolver,+       solverSettingAllowOlder        :: AllowOlder,        solverSettingAllowNewer        :: AllowNewer,        solverSettingMaxBackjumps      :: Maybe Int,-       solverSettingReorderGoals      :: Bool,-       solverSettingStrongFlags       :: Bool+       solverSettingReorderGoals      :: ReorderGoals,+       solverSettingCountConflicts    :: CountConflicts,+       solverSettingStrongFlags       :: StrongFlags,+       solverSettingIndexState        :: IndexState        -- Things that only make sense for manual mode, not --local mode        -- too much control!      --solverSettingIndependentGoals  :: Bool,@@ -293,7 +364,7 @@      --solverSettingOverrideReinstall :: Bool,      --solverSettingUpgradeDeps       :: Bool      }-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Typeable)  instance Binary SolverSettings @@ -321,13 +392,13 @@        buildSettingSymlinkBinDir         :: [FilePath],        buildSettingOneShot               :: Bool,        buildSettingNumJobs               :: Int,+       buildSettingKeepGoing             :: Bool,        buildSettingOfflineMode           :: Bool,        buildSettingKeepTempFiles         :: Bool,        buildSettingRemoteRepos           :: [RemoteRepo],        buildSettingLocalRepos            :: [FilePath],        buildSettingCacheDir              :: FilePath,        buildSettingHttpTransport         :: Maybe String,-       buildSettingIgnoreExpiry          :: Bool,-       buildSettingRootCmd               :: Maybe String+       buildSettingIgnoreExpiry          :: Bool      }
+ cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs view
@@ -0,0 +1,837 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++-- | This module deals with building and incrementally rebuilding a collection+-- of packages. It is what backs the @cabal build@ and @configure@ commands,+-- as well as being a core part of @run@, @test@, @bench@ and others. +--+-- The primary thing is in fact rebuilding (and trying to make that quick by+-- not redoing unnecessary work), so building from scratch is just a special+-- case.+--+-- The build process and the code can be understood by breaking it down into+-- three major parts:+--+-- * The 'ElaboratedInstallPlan' type+--+-- * The \"what to do\" phase, where we look at the all input configuration+--   (project files, .cabal files, command line etc) and produce a detailed+--   plan of what to do -- the 'ElaboratedInstallPlan'.+--+-- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we+-- re-execute it.+--+-- As far as possible, the \"what to do\" phase embodies all the policy, leaving+-- the \"do it\" phase policy free. The first phase contains more of the+-- complicated logic, but it is contained in code that is either pure or just+-- has read effects (except cache updates). Then the second phase does all the+-- actions to build packages, but as far as possible it just follows the+-- instructions and avoids any logic for deciding what to do (apart from+-- recompilation avoidance in executing the plan).+--+-- This division helps us keep the code under control, making it easier to+-- understand, test and debug. So when you are extending these modules, please+-- think about which parts of your change belong in which part. It is+-- perfectly ok to extend the description of what to do (i.e. the +-- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the+-- first phase. Also, the second phase does not have direct access to any of+-- the input configuration anyway; all the information has to flow via the+-- 'ElaboratedInstallPlan'.+--+module Distribution.Client.ProjectOrchestration (+    -- * Pre-build phase: decide what to do.+    runProjectPreBuildPhase,+    CliConfigFlags,+    PreBuildHooks(..),+    ProjectBuildContext(..),++    -- ** Adjusting the plan+    selectTargets,+    printPlan,++    -- * Build phase: now do it.+    runProjectBuildPhase,++    -- * Post build actions+    runProjectPostBuildPhase,+    dieOnBuildFailures,+  ) where++import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectPlanning+import           Distribution.Client.ProjectPlanning.Types+import           Distribution.Client.ProjectBuilding+import           Distribution.Client.ProjectPlanOutput++import           Distribution.Client.Types+                   ( GenericReadyPackage(..), PackageLocation(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.BuildTarget+                   ( UserBuildTarget, resolveUserBuildTargets+                   , BuildTarget(..), buildTargetPackage )+import           Distribution.Client.DistDirLayout+import           Distribution.Client.Config (defaultCabalDir)+import           Distribution.Client.Setup hiding (packageName)++import           Distribution.Solver.Types.OptionalStanza++import           Distribution.Package+                   hiding (InstalledPackageId, installedPackageId)+import qualified Distribution.PackageDescription as PD+import           Distribution.PackageDescription (FlagAssignment)+import           Distribution.Simple.Setup (HaddockFlags)+import qualified Distribution.Simple.Setup as Setup+import           Distribution.Simple.Command (commandShowOptions)++import           Distribution.Simple.Utils+                   ( die, dieMsg, dieMsgNoWrap, info+                   , notice, noticeNoWrap, debug, debugNoWrap )+import           Distribution.Verbosity+import           Distribution.Text++import qualified Data.Monoid as Mon+import qualified Data.Set as Set+import qualified Data.Map as Map+import           Data.Map (Map)+import           Data.List+import           Data.Maybe+import           Data.Either+import           Control.Exception (Exception(..), throwIO)+import           System.Exit (ExitCode(..), exitFailure)+import qualified System.Process.Internals as Process (translate)+#ifdef MIN_VERSION_unix+import           System.Posix.Signals (sigKILL, sigSEGV)+#endif+++-- | Command line configuration flags. These are used to extend\/override the+-- project configuration.+--+type CliConfigFlags = ( GlobalFlags+                      , ConfigFlags, ConfigExFlags+                      , InstallFlags, HaddockFlags )++-- | Hooks to alter the behaviour of 'runProjectPreBuildPhase'.+--+-- For example the @configure@, @build@ and @repl@ commands use this to get+-- their different behaviour.+--+data PreBuildHooks = PreBuildHooks {+       hookPrePlanning      :: FilePath+                            -> DistDirLayout+                            -> ProjectConfig+                            -> IO (),+       hookSelectPlanSubset :: BuildTimeSettings+                            -> ElaboratedInstallPlan+                            -> IO ElaboratedInstallPlan+     }++-- | This holds the context between the pre-build, build and post-build phases.+--+data ProjectBuildContext = ProjectBuildContext {+      projectRootDir         :: FilePath,+      distDirLayout          :: DistDirLayout,++      -- | This is the improved plan, before we select a plan subset based on+      -- the build targets, and before we do the dry-run. So this contains+      -- all packages in the project.+      elaboratedPlanOriginal :: ElaboratedInstallPlan,++      -- | This is the 'elaboratedPlanOriginal' after we select a plan subset+      -- and do the dry-run phase to find out what is up-to or out-of date.+      -- This is the plan that will be executed during the build phase. So+      -- this contains only a subset of packages in the project.+      elaboratedPlanToExecute:: ElaboratedInstallPlan,++      -- | The part of the install plan that's shared between all packages in+      -- the plan. This does not change between the two plan variants above,+      -- so there is just the one copy.+      elaboratedShared       :: ElaboratedSharedConfig,++      -- | The result of the dry-run phase. This tells us about each member of+      -- the 'elaboratedPlanToExecute'.+      pkgsBuildStatus        :: BuildStatusMap,++      buildSettings          :: BuildTimeSettings+    }+++-- | Pre-build phase: decide what to do.+--+runProjectPreBuildPhase :: Verbosity+                        -> CliConfigFlags+                        -> PreBuildHooks+                        -> IO ProjectBuildContext+runProjectPreBuildPhase+    verbosity+    ( globalFlags+    , configFlags, configExFlags+    , installFlags, haddockFlags )+    PreBuildHooks{..} = do++    cabalDir <- defaultCabalDir+    let cabalDirLayout = defaultCabalDirLayout cabalDir++    projectRootDir <- findProjectRoot+    let distDirLayout = defaultDistDirLayout projectRootDir++    let cliConfig = commandLineFlagsToProjectConfig+                      globalFlags configFlags configExFlags+                      installFlags haddockFlags++    hookPrePlanning+      projectRootDir+      distDirLayout+      cliConfig++    -- Take the project configuration and make a plan for how to build+    -- everything in the project. This is independent of any specific targets+    -- the user has asked for.+    --+    (elaboratedPlan, _, elaboratedShared, projectConfig) <-+      rebuildInstallPlan verbosity+                         projectRootDir distDirLayout cabalDirLayout+                         cliConfig++    let buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          (projectConfigShared    projectConfig)+                          (projectConfigBuildOnly projectConfig)+                          (projectConfigBuildOnly cliConfig)+    info verbosity $ "Number of threads used: "+      ++ (show . buildSettingNumJobs $ buildSettings) ++ "."+    -- The plan for what to do is represented by an 'ElaboratedInstallPlan'++    -- Now given the specific targets the user has asked for, decide+    -- which bits of the plan we will want to execute.+    --+    elaboratedPlan' <- hookSelectPlanSubset buildSettings elaboratedPlan++    -- Check which packages need rebuilding.+    -- This also gives us more accurate reasons for the --dry-run output.+    --+    pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared+                                            elaboratedPlan'++    -- Improve the plan by marking up-to-date packages as installed.+    --+    let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages+                             pkgsBuildStatus elaboratedPlan'+    debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')++    return ProjectBuildContext {+      projectRootDir,+      distDirLayout,+      elaboratedPlanOriginal = elaboratedPlan,+      elaboratedPlanToExecute  = elaboratedPlan'',+      elaboratedShared,+      pkgsBuildStatus,+      buildSettings+    }+++-- | Build phase: now do it.+--+-- Execute all or parts of the description of what to do to build or+-- rebuild the various packages needed.+--+runProjectBuildPhase :: Verbosity+                     -> ProjectBuildContext+                     -> IO BuildOutcomes+runProjectBuildPhase _ ProjectBuildContext {buildSettings}+  | buildSettingDryRun buildSettings+  = return Map.empty++runProjectBuildPhase verbosity ProjectBuildContext {..} =+    fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $+    rebuildTargets verbosity+                   distDirLayout+                   elaboratedPlanToExecute+                   elaboratedShared+                   pkgsBuildStatus+                   buildSettings+  where+    previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes+    previousBuildOutcomes =+      Map.mapMaybe $ \status -> case status of+        BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)+        --TODO: [nice to have] record build failures persistently+        _                                  -> Nothing++-- | Post-build phase: various administrative tasks+--+-- Update bits of state based on the build outcomes and report any failures.+--+runProjectPostBuildPhase :: Verbosity+                         -> ProjectBuildContext+                         -> BuildOutcomes+                         -> IO ()+runProjectPostBuildPhase _ ProjectBuildContext {buildSettings} _+  | buildSettingDryRun buildSettings+  = return ()++runProjectPostBuildPhase verbosity ProjectBuildContext {..} buildOutcomes = do+    -- Update other build artefacts+    -- TODO: currently none, but could include:+    --        - bin symlinks/wrappers+    --        - haddock/hoogle/ctags indexes+    --        - delete stale lib registrations+    --        - delete stale package dirs++    postBuildStatus <- updatePostBuildProjectStatus+                         verbosity+                         distDirLayout+                         elaboratedPlanOriginal+                         pkgsBuildStatus+                         buildOutcomes++    writePlanGhcEnvironment projectRootDir+                            elaboratedPlanOriginal+                            elaboratedShared+                            postBuildStatus++    -- Finally if there were any build failures then report them and throw+    -- an exception to terminate the program+    dieOnBuildFailures verbosity elaboratedPlanToExecute buildOutcomes++    -- Note that it is a deliberate design choice that the 'buildTargets' is+    -- not passed to phase 1, and the various bits of input config is not+    -- passed to phase 2.+    --+    -- We make the install plan without looking at the particular targets the+    -- user asks us to build. The set of available things we can build is+    -- discovered from the env and config and is used to make the install plan.+    -- The targets just tell us which parts of the install plan to execute.+    --+    -- Conversely, executing the plan does not directly depend on any of the+    -- input config. The bits that are needed (or better, the decisions based+    -- on it) all go into the install plan.++    -- Notionally, the 'BuildFlags' should be things that do not affect what+    -- we build, just how we do it. These ones of course do +++------------------------------------------------------------------------------+-- Taking targets into account, selecting what to build+--++-- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it+-- required to build the given user targets.+--+-- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable,+-- so that we can change the meaning of @pkgname@ to target a build or+-- repl depending on which command is calling it.+--+-- Conceptually, every target identifies one or more roots in the+-- 'ElaboratedInstallPlan', which we then use to determine the closure+-- of what packages need to be built, dropping everything from+-- 'ElaboratedInstallPlan' that is unnecessary.+--+-- There is a complication, however: In an ideal world, every+-- possible target would be a node in the graph.  However, it is+-- currently not possible (and possibly not even desirable) to invoke a+-- Setup script to build *just* one file.  Similarly, it is not possible+-- to invoke a pre Cabal-1.25 custom Setup script and build only one+-- component.  In these cases, we want to build the entire package, BUT+-- only actually building some of the files/components.  This is what+-- 'pkgBuildTargets', 'pkgReplTarget' and 'pkgBuildHaddock' control.+-- Arguably, these should an out-of-band mechanism rather than stored+-- in 'ElaboratedInstallPlan', but it's what we have.  We have+-- to fiddle around with the ElaboratedConfiguredPackage roots to say+-- what it will build.+--+selectTargets :: Verbosity -> PackageTarget+              -> (ComponentTarget -> PackageTarget)+              -> [UserBuildTarget]+              -> Bool+              -> ElaboratedInstallPlan+              -> IO ElaboratedInstallPlan+selectTargets verbosity targetDefaultComponents targetSpecificComponent+              userBuildTargets onlyDependencies installPlan = do++    -- Match the user targets against the available targets. If no targets are+    -- given this uses the package in the current directory, if any.+    --+    buildTargets <- resolveUserBuildTargets localPackages userBuildTargets+    --TODO: [required eventually] report something if there are no targets++    --TODO: [required eventually]+    -- we cannot resolve names of packages other than those that are+    -- directly in the current plan. We ought to keep a set of the known+    -- hackage packages so we can resolve names to those. Though we don't+    -- really need that until we can do something sensible with packages+    -- outside of the project.++    -- Now check if those targets belong to the current project or not.+    -- Ultimately we want to do something sensible for targets not in this+    -- project, but for now we just bail. This gives us back the ipkgid from+    -- the plan.+    --+    buildTargets' <- either reportBuildTargetProblems return+                   $ resolveAndCheckTargets+                       targetDefaultComponents+                       targetSpecificComponent+                       installPlan+                       buildTargets+    debug verbosity ("buildTargets': " ++ show buildTargets')++    -- Finally, prune the install plan to cover just those target packages+    -- and their deps (or only their deps with the --only-dependencies flag).+    --+    let installPlan' = pruneInstallPlanToTargets+                         buildTargets' installPlan+    if onlyDependencies+      then either throwIO return $+             pruneInstallPlanToDependencies+               (Map.keysSet buildTargets') installPlan'+      else return installPlan'+  where+    localPackages =+      [ (elabPkgDescription elab, elabPkgSourceLocation elab)+      | InstallPlan.Configured elab <- InstallPlan.toList installPlan ]+      --TODO: [code cleanup] is there a better way to identify local packages?++++resolveAndCheckTargets :: PackageTarget+                       -> (ComponentTarget -> PackageTarget)+                       -> ElaboratedInstallPlan+                       -> [BuildTarget PackageName]+                       -> Either [BuildTargetProblem]+                                 (Map UnitId [PackageTarget])+resolveAndCheckTargets targetDefaultComponents+                       targetSpecificComponent+                       installPlan targets =+    case partitionEithers (map checkTarget targets) of+      ([], targets') -> Right $ Map.fromListWith (++)+                                  [ (uid, [t]) | (uids, t) <- targets'+                                               , uid <- uids ]+      (problems, _)  -> Left problems+  where+    -- TODO [required eventually] currently all build targets refer to packages+    -- inside the project. Ultimately this has to be generalised to allow+    -- referring to other packages and targets.++    -- We can ask to build any whole package, project-local or a dependency+    checkTarget (BuildTargetPackage pn)+      | Just ipkgid <- Map.lookup pn projAllPkgs+      = Right (ipkgid, targetDefaultComponents)++    -- But if we ask to build an individual component, then that component+    -- had better be in a package that is local to the project.+    -- TODO: and if it's an optional stanza, then that stanza must be available+    checkTarget t@(BuildTargetComponent pn cn)+      | Just ipkgid <- Map.lookup pn projLocalPkgs+      = Right (ipkgid, targetSpecificComponent+                         (ComponentTarget cn WholeComponent))++      | Map.member pn projAllPkgs+      = Left (BuildTargetComponentNotProjectLocal t)++    checkTarget t@(BuildTargetModule pn cn mn)+      | Just ipkgid <- Map.lookup pn projLocalPkgs+      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (ModuleTarget mn)))++      | Map.member pn projAllPkgs+      = Left (BuildTargetComponentNotProjectLocal t)++    checkTarget t@(BuildTargetFile pn cn fn)+      | Just ipkgid <- Map.lookup pn projLocalPkgs+      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (FileTarget fn)))++      | Map.member pn projAllPkgs+      = Left (BuildTargetComponentNotProjectLocal t)++    checkTarget t+      = Left (BuildTargetNotInProject (buildTargetPackage t))+++    -- NB: It's a list of 'InstalledPackageId', because each component+    -- in the install plan from a single package needs to be associated with+    -- the same 'PackageName'.+    projAllPkgs, projLocalPkgs :: Map PackageName [UnitId]+    projAllPkgs =+      Map.fromListWith (++)+        [ (packageName pkg, [installedUnitId pkg])+        | pkg <- InstallPlan.toList installPlan ]++    projLocalPkgs =+      Map.fromListWith (++)+        [ (packageName elab, [installedUnitId elab])+        | InstallPlan.Configured elab <- InstallPlan.toList installPlan+        , case elabPkgSourceLocation elab of+            LocalUnpackedPackage _ -> True; _ -> False+          --TODO: [code cleanup] is there a better way to identify local packages?+        ]++    --TODO: [research required] what if the solution has multiple versions of this package?+    --      e.g. due to setup deps or due to multiple independent sets of+    --      packages being built (e.g. ghc + ghcjs in a project)++data BuildTargetProblem+   = BuildTargetNotInProject PackageName+   | BuildTargetComponentNotProjectLocal (BuildTarget PackageName)+   | BuildTargetOptionalStanzaDisabled Bool+      -- ^ @True@: explicitly disabled by user+      -- @False@: disabled by solver++reportBuildTargetProblems :: [BuildTargetProblem] -> IO a+reportBuildTargetProblems = die . unlines . map reportBuildTargetProblem++reportBuildTargetProblem :: BuildTargetProblem -> String+reportBuildTargetProblem (BuildTargetNotInProject pn) =+        "Cannot build the package " ++ display pn ++ ", it is not in this project."+     ++ "(either directly or indirectly). If you want to add it to the "+     ++ "project then edit the cabal.project file."++reportBuildTargetProblem (BuildTargetComponentNotProjectLocal t) =+        "The package " ++ display (buildTargetPackage t) ++ " is in the "+     ++ "project but it is not a locally unpacked package, so  "++reportBuildTargetProblem (BuildTargetOptionalStanzaDisabled _) = undefined+++------------------------------------------------------------------------------+-- Displaying what we plan to do+--++-- | Print a user-oriented presentation of the install plan, indicating what+-- will be built.+--+printPlan :: Verbosity -> ProjectBuildContext -> IO ()+printPlan verbosity+          ProjectBuildContext {+            elaboratedPlanToExecute = elaboratedPlan,+            elaboratedShared,+            pkgsBuildStatus,+            buildSettings = BuildTimeSettings{buildSettingDryRun}+          }++  | null pkgs+  = notice verbosity "Up to date"++  | otherwise+  = noticeNoWrap verbosity $ unlines $+      ("In order, the following " ++ wouldWill ++ " be built" +++      ifNormal " (use -v for more details)" ++ ":")+    : map showPkgAndReason pkgs++  where+    pkgs = InstallPlan.executionOrder elaboratedPlan++    ifVerbose s | verbosity >= verbose = s+                | otherwise            = ""++    ifNormal s | verbosity >= verbose = ""+               | otherwise            = s++    wouldWill | buildSettingDryRun = "would"+              | otherwise          = "will"++    showPkgAndReason :: ElaboratedReadyPackage -> String+    showPkgAndReason (ReadyPackage elab) =+      " - " +++      (if verbosity >= verbose+        then display (installedUnitId elab)+        else display (packageId elab)+        ) +++      (case elabPkgOrComp elab of+          ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)+          ElabComponent comp ->+            " (" ++ maybe "custom" display (compComponentName comp) ++ ")"+            ) +++      showFlagAssignment (nonDefaultFlags elab) +++      showConfigureFlags elab +++      let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in+      " (" ++ showBuildStatus buildStatus ++ ")"++    nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment+    nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab++    showStanzas pkg = concat+                    $ [ " *test"+                      | TestStanzas  `Set.member` pkgStanzasEnabled pkg ]+                   ++ [ " *bench"+                      | BenchStanzas `Set.member` pkgStanzasEnabled pkg ]++    showTargets elab+      | null (elabBuildTargets elab) = ""+      | otherwise+      = " (" ++ intercalate ", " [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ]+             ++ ")"++    -- TODO: [code cleanup] this should be a proper function in a proper place+    showFlagAssignment :: FlagAssignment -> String+    showFlagAssignment = concatMap ((' ' :) . showFlagValue)+    showFlagValue (f, True)   = '+' : showFlagName f+    showFlagValue (f, False)  = '-' : showFlagName f+    showFlagName = PD.unFlagName++    showConfigureFlags elab =+        let fullConfigureFlags+              = setupHsConfigureFlags+                    (ReadyPackage elab)+                    elaboratedShared+                    verbosity+                    "$builddir"+            -- | Given a default value @x@ for a flag, nub @Flag x@+            -- into @NoFlag@.  This gives us a tidier command line+            -- rendering.+            nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a+            nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag+            nubFlag _ f = f+            -- TODO: Closely logic from 'configureProfiling'.+            tryExeProfiling = Setup.fromFlagOrDefault False+                                (configProf fullConfigureFlags)+            tryLibProfiling = Setup.fromFlagOrDefault False+                                (Mon.mappend (configProf    fullConfigureFlags)+                                             (configProfExe fullConfigureFlags))+            partialConfigureFlags+              = Mon.mempty {+                configProf    =+                    nubFlag False (configProf fullConfigureFlags),+                configProfExe =+                    nubFlag tryExeProfiling (configProfExe fullConfigureFlags),+                configProfLib =+                    nubFlag tryLibProfiling (configProfLib fullConfigureFlags)+                -- Maybe there are more we can add+              }+        in unwords . ("":) . map Process.translate $+            commandShowOptions+            (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))+            partialConfigureFlags++    showBuildStatus status = case status of+      BuildStatusPreExisting -> "existing package"+      BuildStatusInstalled   -> "already installed"+      BuildStatusDownload {} -> "requires download & build"+      BuildStatusUnpack   {} -> "requires build"+      BuildStatusRebuild _ rebuild -> case rebuild of+        BuildStatusConfigure+          (MonitoredValueChanged _)   -> "configuration changed"+        BuildStatusConfigure mreason  -> showMonitorChangedReason mreason+        BuildStatusBuild _ buildreason -> case buildreason of+          BuildReasonDepsRebuilt      -> "dependency rebuilt"+          BuildReasonFilesChanged+            mreason                   -> showMonitorChangedReason mreason+          BuildReasonExtraTargets _   -> "additional components to build"+          BuildReasonEphemeralTargets -> "ephemeral targets"+      BuildStatusUpToDate {} -> "up to date" -- doesn't happen++    showMonitorChangedReason (MonitoredFileChanged file) = "file " ++ file ++ " changed"+    showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"+    showMonitorChangedReason  MonitorFirstRun     = "first run"+    showMonitorChangedReason  MonitorCorruptCache = "cannot read state cache"+++-- | If there are build failures then report them and throw an exception.+--+dieOnBuildFailures :: Verbosity+                   -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()+dieOnBuildFailures verbosity plan buildOutcomes+  | null failures = return ()++  | isSimpleCase  = exitFailure++  | otherwise = do+      -- For failures where we have a build log, print the log plus a header+       sequence_+         [ do dieMsg verbosity $+                '\n' : renderFailureDetail False pkg reason+                    ++ "\nBuild log ( " ++ logfile ++ " ):"+              readFile logfile >>= dieMsgNoWrap+         | verbosity >= normal+         ,  (pkg, ShowBuildSummaryAndLog reason logfile)+             <- failuresClassification+         ]++       -- For all failures, print either a short summary (if we showed the+       -- build log) or all details+       die $ unlines+         [ case failureClassification of+             ShowBuildSummaryAndLog reason _+               | verbosity > normal+              -> renderFailureDetail mentionDepOf pkg reason++               | otherwise+              -> renderFailureSummary mentionDepOf pkg reason+              ++ ". See the build log above for details."++             ShowBuildSummaryOnly reason ->+               renderFailureDetail mentionDepOf pkg reason++         | let mentionDepOf = verbosity <= normal+         , (pkg, failureClassification) <- failuresClassification ]+  where+    failures =  [ (pkgid, failure)+                | (pkgid, Left failure) <- Map.toList buildOutcomes ]++    failuresClassification =+      [ (pkg, classifyBuildFailure failure)+      | (pkgid, failure) <- failures+      , case buildFailureReason failure of+          DependentFailed {} -> verbosity > normal+          _                  -> True+      , InstallPlan.Configured pkg <-+           maybeToList (InstallPlan.lookup plan pkgid)+      ]++    classifyBuildFailure :: BuildFailure -> BuildFailurePresentation+    classifyBuildFailure BuildFailure {+                           buildFailureReason  = reason,+                           buildFailureLogFile = mlogfile+                         } =+      maybe (ShowBuildSummaryOnly   reason)+            (ShowBuildSummaryAndLog reason) $ do+        logfile <- mlogfile+        e       <- buildFailureException reason+        ExitFailure 1 <- fromException e+        return logfile++    -- Special case: we don't want to report anything complicated in the case+    -- of just doing build on the current package, since it's clear from+    -- context which package failed.+    --+    -- We generalise this rule as follows:+    --  - if only one failure occurs, and it is in a single root package (ie a+    --    package with nothing else depending on it)+    --  - and that failure is of a kind that always reports enough detail+    --    itself (e.g. ghc reporting errors on stdout)+    --  - then we do not report additional error detail or context.+    --+    isSimpleCase+      | [(pkgid, failure)] <- failures+      , [pkg]              <- rootpkgs+      , installedUnitId pkg == pkgid+      , isFailureSelfExplanatory (buildFailureReason failure)+      = True+      | otherwise+      = False++    -- NB: if the Setup script segfaulted or was interrupted,+    -- we should give more detailed information.  So only+    -- assume that exit code 1 is "pedestrian failure."+    isFailureSelfExplanatory (BuildFailed e)+      | Just (ExitFailure 1) <- fromException e = True++    isFailureSelfExplanatory (ConfigureFailed e)+      | Just (ExitFailure 1) <- fromException e = True++    isFailureSelfExplanatory _                  = False++    rootpkgs =+      [ pkg+      | InstallPlan.Configured pkg <- InstallPlan.toList plan+      , hasNoDependents pkg ]++    ultimateDeps pkgid =+        filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)+               (InstallPlan.reverseDependencyClosure plan [pkgid])++    hasNoDependents :: HasUnitId pkg => pkg -> Bool+    hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId++    renderFailureDetail mentionDepOf pkg reason =+        renderFailureSummary mentionDepOf pkg reason ++ "."+     ++ renderFailureExtraDetail reason+     ++ maybe "" showException (buildFailureException reason)++    renderFailureSummary mentionDepOf pkg reason =+        case reason of+          DownloadFailed  _ -> "Failed to download " ++ pkgstr+          UnpackFailed    _ -> "Failed to unpack "   ++ pkgstr+          ConfigureFailed _ -> "Failed to build "    ++ pkgstr+          BuildFailed     _ -> "Failed to build "    ++ pkgstr+          ReplFailed      _ -> "repl failed for "    ++ pkgstr+          HaddocksFailed  _ -> "Failed to build documentation for " ++ pkgstr+          TestsFailed     _ -> "Tests failed for " ++ pkgstr+          InstallFailed   _ -> "Failed to build "  ++ pkgstr+          DependentFailed depid+                            -> "Failed to build " ++ display (packageId pkg)+                            ++ " because it depends on " ++ display depid+                            ++ " which itself failed to build"+      where+        pkgstr = elabConfiguredName verbosity pkg+              ++ if mentionDepOf+                   then renderDependencyOf (installedUnitId pkg)+                   else ""++    renderFailureExtraDetail reason =+      case reason of+        ConfigureFailed _ -> " The failure occurred during the configure step."+        InstallFailed   _ -> " The failure occurred during the final install step."+        _                 -> ""++    renderDependencyOf pkgid =+      case ultimateDeps pkgid of+        []         -> ""+        (p1:[])    -> " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")"+        (p1:p2:[]) -> " (which is required by " ++ elabPlanPackageName verbosity p1+                                     ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")"+        (p1:p2:_)  -> " (which is required by " ++ elabPlanPackageName verbosity p1+                                        ++ ", " ++ elabPlanPackageName verbosity p2+                                        ++ " and others)"++    showException e = case fromException e of+      Just (ExitFailure 1) -> ""++#ifdef MIN_VERSION_unix+      -- Note [Positive "signal" exit code]+      -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+      -- What's the business with the test for negative and positive+      -- signal values?  The API for process specifies that if the+      -- process died due to a signal, it returns a *negative* exit+      -- code.  So that's the negative test.+      --+      -- What about the positive test?  Well, when we find out that+      -- a process died due to a signal, we ourselves exit with that+      -- exit code.  However, we don't "kill ourselves" with the+      -- signal; we just exit with the same code as the signal: thus+      -- the caller sees a *positive* exit code.  So that's what+      -- happens when we get a positive exit code.+      Just (ExitFailure n)+        | -n == fromIntegral sigSEGV ->+            " The build process segfaulted (i.e. SIGSEGV)."++        |  n == fromIntegral sigSEGV ->+            " The build process terminated with exit code " ++ show n+         ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."++        | -n == fromIntegral sigKILL ->+            " The build process was killed (i.e. SIGKILL). " ++ explanation++        |  n == fromIntegral sigKILL ->+            " The build process terminated with exit code " ++ show n+         ++ " which may be because some part of it was killed "+         ++ "(i.e. SIGKILL). " ++ explanation+        where+          explanation = "The typical reason for this is that there is not "+                     ++ "enough memory available (e.g. the OS killed a process "+                     ++ "using lots of memory)."+#endif+      Just (ExitFailure n) ->+        " The build process terminated with exit code " ++ show n++      _ -> " The exception was:\n  "+#if MIN_VERSION_base(4,8,0)+             ++ displayException e+#else+             ++ show e+#endif++    buildFailureException reason =+      case reason of+        DownloadFailed  e -> Just e+        UnpackFailed    e -> Just e+        ConfigureFailed e -> Just e+        BuildFailed     e -> Just e+        ReplFailed      e -> Just e+        HaddocksFailed  e -> Just e+        TestsFailed     e -> Just e+        InstallFailed   e -> Just e+        DependentFailed _ -> Nothing++data BuildFailurePresentation =+       ShowBuildSummaryOnly   BuildFailureReason+     | ShowBuildSummaryAndLog BuildFailureReason FilePath+
+ cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs view
@@ -0,0 +1,821 @@+{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,+             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,+             ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Distribution.Client.ProjectPlanOutput (+    -- * Plan output+    writePlanExternalRepresentation,++    -- * Project status+    -- | Several outputs rely on having a general overview of+    PostBuildProjectStatus(..),+    updatePostBuildProjectStatus,+    writePlanGhcEnvironment,+  ) where++import           Distribution.Client.ProjectPlanning.Types+import           Distribution.Client.ProjectBuilding.Types+import           Distribution.Client.DistDirLayout+import           Distribution.Client.Types (confInstId)+import           Distribution.Client.PackageHash (showHashValue)++import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.Utils.Json as J+import qualified Distribution.Simple.InstallDirs as InstallDirs++import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps++import           Distribution.Package+import           Distribution.System+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.PackageDescription as PD+import           Distribution.Compiler (CompilerFlavor(GHC))+import           Distribution.Simple.Compiler+                   ( PackageDBStack, PackageDB(..)+                   , compilerVersion, compilerFlavor, showCompilerId )+import           Distribution.Simple.GHC+                   ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)+                   , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile+                   , writeGhcEnvironmentFile )+import           Distribution.Text+import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph (Graph, Node)+import qualified Distribution.Compat.Binary as Binary+import qualified Distribution.Utils.BinaryWithFingerprint as Binary+import           Distribution.Simple.Utils+import           Distribution.Verbosity+import qualified Paths_cabal_install as Our (version)++import           Data.Maybe (maybeToList, fromMaybe)+import           Data.Monoid+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Builder as BB++import           GHC.Generics+import           System.FilePath+import           System.IO+++-----------------------------------------------------------------------------+-- Writing plan.json files+--++-- | Write out a representation of the elaborated install plan.+--+-- This is for the benefit of debugging and external tools like editors.+--+writePlanExternalRepresentation :: DistDirLayout+                                -> ElaboratedInstallPlan+                                -> ElaboratedSharedConfig+                                -> IO ()+writePlanExternalRepresentation distDirLayout elaboratedInstallPlan+                                elaboratedSharedConfig =+    writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $+        BB.toLazyByteString+      . J.encodeToBuilder+      $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig++-- | Renders a subset of the elaborated install plan in a semi-stable JSON+-- format.+--+encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value+encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =+    --TODO: [nice to have] include all of the sharedPackageConfig and all of+    --      the parts of the elaboratedInstallPlan+    J.object [ "cabal-version"     J..= jdisplay Our.version+             , "cabal-lib-version" J..= jdisplay cabalVersion+             , "compiler-id"       J..= (J.String . showCompilerId . pkgConfigCompiler)+                                        elaboratedSharedConfig+             , "os"                J..= jdisplay os+             , "arch"              J..= jdisplay arch+             , "install-plan"      J..= installPlanToJ elaboratedInstallPlan+             ]+  where+    Platform arch os = pkgConfigPlatform elaboratedSharedConfig++    installPlanToJ :: ElaboratedInstallPlan -> [J.Value]+    installPlanToJ = map planPackageToJ . InstallPlan.toList++    planPackageToJ :: ElaboratedPlanPackage -> J.Value+    planPackageToJ pkg =+      case pkg of+        InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi+        InstallPlan.Configured elab -> elaboratedPackageToJ False elab+        InstallPlan.Installed  elab -> elaboratedPackageToJ True  elab+        -- Note that the plan.json currently only uses the elaborated plan,+        -- not the improved plan. So we will not get the Installed state for+        -- that case, but the code supports it in case we want to use this+        -- later in some use case where we want the status of the build.++    installedPackageInfoToJ :: InstalledPackageInfo -> J.Value+    installedPackageInfoToJ ipi =+      -- Pre-existing packages lack configuration information such as their flag+      -- settings or non-lib components. We only get pre-existing packages for+      -- the global/core packages however, so this isn't generally a problem.+      -- So these packages are never local to the project.+      --+      J.object+        [ "type"       J..= J.String "pre-existing"+        , "id"         J..= (jdisplay . installedUnitId) ipi+        , "pkg-name"   J..= (jdisplay . pkgName . packageId) ipi+        , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi+        , "depends"    J..= map jdisplay (installedDepends ipi)+        ]++    elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value+    elaboratedPackageToJ isInstalled elab =+      J.object $+        [ "type"       J..= J.String (if isInstalled then "installed"+                                                     else "configured")+        , "id"         J..= (jdisplay . installedUnitId) elab+        , "pkg-name"   J..= (jdisplay . pkgName . packageId) elab+        , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab+        , "flags"      J..= J.object [ PD.unFlagName fn J..= v+                                     | (fn,v) <- elabFlagAssignment elab ]+        , "style"      J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))+        ] +++        [ "pkg-src-sha256" J..= J.String (showHashValue hash)+        | Just hash <- [elabPkgSourceHash elab] ] +++        (case elabBuildStyle elab of+            BuildInplaceOnly ->+                ["dist-dir"   J..= J.String dist_dir]+            BuildAndInstall ->+                -- TODO: install dirs?+                []+            ) +++        case elabPkgOrComp elab of+          ElabPackage pkg ->+            let components = J.object $+                  [ comp2str c J..= (J.object $+                    [ "depends"     J..= map (jdisplay . confInstId) ldeps+                    , "exe-depends" J..= map (jdisplay . confInstId) edeps ] +++                    bin_file c)+                  | (c,(ldeps,edeps))+                      <- ComponentDeps.toList $+                         ComponentDeps.zip (pkgLibDependencies pkg)+                                           (pkgExeDependencies pkg) ]+            in ["components" J..= components]+          ElabComponent comp ->+            ["depends"     J..= map (jdisplay . confInstId) (elabLibDependencies elab)+            ,"exe-depends" J..= map jdisplay (elabExeDependencies elab)+            ,"component-name" J..= J.String (comp2str (compSolverName comp))+            ] +++            bin_file (compSolverName comp)+     where+      dist_dir = distBuildDirectory distDirLayout+                    (elabDistDirParams elaboratedSharedConfig elab)++      bin_file c = case c of+        ComponentDeps.ComponentExe s   -> bin_file' s+        ComponentDeps.ComponentTest s  -> bin_file' s+        ComponentDeps.ComponentBench s -> bin_file' s+        _ -> []+      bin_file' s =+        ["bin-file" J..= J.String bin]+       where+        bin = if elabBuildStyle elab == BuildInplaceOnly+               then dist_dir </> "build" </> display s </> display s+               else InstallDirs.bindir (elabInstallDirs elab) </> display s++    -- TODO: maybe move this helper to "ComponentDeps" module?+    --       Or maybe define a 'Text' instance?+    comp2str :: ComponentDeps.Component -> String+    comp2str c = case c of+        ComponentDeps.ComponentLib     -> "lib"+        ComponentDeps.ComponentSubLib s -> "lib:"   <> display s+        ComponentDeps.ComponentFLib s  -> "flib:"  <> display s+        ComponentDeps.ComponentExe s   -> "exe:"   <> display s+        ComponentDeps.ComponentTest s  -> "test:"  <> display s+        ComponentDeps.ComponentBench s -> "bench:" <> display s+        ComponentDeps.ComponentSetup   -> "setup"++    style2str :: Bool -> BuildStyle -> String+    style2str True  _                = "local"+    style2str False BuildInplaceOnly = "inplace"+    style2str False BuildAndInstall  = "global"++    jdisplay :: Text a => a -> J.Value+    jdisplay = J.String . display+++-----------------------------------------------------------------------------+-- Project status+--++-- So, what is the status of a project after a build? That is, how do the+-- inputs (package source files etc) compare to the output artefacts (build+-- libs, exes etc)? Do the outputs reflect the current values of the inputs+-- or are outputs out of date or invalid?+--+-- First of all, what do we mean by out-of-date and what do we mean by+-- invalid? We think of the build system as a morally pure function that+-- computes the output artefacts given input values. We say an output artefact+-- is out of date when its value is not the value that would be computed by a+-- build given the current values of the inputs. An output artefact can be+-- out-of-date but still be perfectly usable; it simply correspond to a+-- previous state of the inputs.+--+-- On the other hand there are cases where output artefacts cannot safely be+-- used. For example libraries and dynamically linked executables cannot be+-- used when the libs they depend on change without them being recompiled+-- themselves. Whether an artefact is still usable depends on what it is, e.g.+-- dynamically linked vs statically linked and on how it gets updated (e.g.+-- only atomically on success or if failure can leave invalid states). We need+-- a definition (or two) that is independent of the kind of artefact and can+-- be computed just in terms of changes in package graphs, but are still+-- useful for determining when particular kinds of artefacts are invalid.+--+-- Note that when we talk about packages in this context we just mean nodes+-- in the elaborated install plan, which can be components or packages.+--+-- There's obviously a close connection between packages being out of date and+-- their output artefacts being unusable: most of the time if a package+-- remains out of date at the end of a build then some of its output artefacts+-- will be unusable. That is true most of the time because a build will have+-- attempted to build one of the out-of-date package's dependencies. If the+-- build of the dependency succeeded then it changed output artefacts (like+-- libs) and if it failed then it may have failed after already changing+-- things (think failure after updating some but not all .hi files).+--+-- There are a few reasons we may end up with still-usable output artefacts+-- for a package even when it remains out of date at the end of a build.+-- Firstly if executing a plan fails then packages can be skipped, and thus we+-- may have packages where all their dependencies were skipped. Secondly we+-- have artefacts like statically linked executables which are not affected by+-- libs they depend on being recompiled. Furthermore, packages can be out of+-- date due to changes in build tools or Setup.hs scripts they depend on, but+-- again libraries or executables in those out-of-date packages remain usable.+--+-- So we have two useful definitions of invalid. Both are useful, for+-- different purposes, so we will compute both. The first corresponds to the+-- invalid libraries and dynamic executables. We say a package is invalid by+-- changed deps if any of the packages it depends on (via library dep edges)+-- were rebuilt (successfully or unsuccessfully). The second definition+-- corresponds to invalid static executables. We say a package is invalid by+-- a failed build simply if the package was built but unsuccessfully.+--+-- So how do we find out what packages are out of date or invalid?+--+-- Obviously we know something for all the packages that were part of the plan+-- that was executed, but that is just a subset since we prune the plan down+-- to the targets and their dependencies.+--+-- Recall the steps we go though:+--+-- + starting with the initial improved plan (this is the full project);+--+-- + prune the plan to the user's build targets;+--+-- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap+--   covering the pruned subset of the original plan;+--+-- + execute the plan giving us BuildOutcomes which tell us success/failure+--   for each package.+--+-- So given that the BuildStatusMap and BuildOutcomes do not cover everything+-- in the original plan, what can they tell us about the original plan?+--+-- The BuildStatusMap tells us directly that some packages are up to date and+-- others out of date (but only for the pruned subset). But we know that+-- everything that is a reverse dependency of an out-of-date package is itself+-- out-of-date (whether or not it is in the pruned subset). Of course after+-- a build the BuildOutcomes may tell us that some of those out-of-date+-- packages are now up to date (ie a successful build outcome).+--+-- The difference is packages that are reverse dependencies of out-of-date+-- packages but are not brought up-to-date by the build (i.e. did not have+-- successful outcomes, either because they failed or were not in the pruned+-- subset to be built). We also know which packages were rebuilt, so we can+-- use this to find the now-invalid packages.+--+-- Note that there are still packages for which we cannot discover full status+-- information. There may be packages outside of the pruned plan that do not+-- depend on packages within the pruned plan that were discovered to be+-- out-of-date. For these packages we do not know if their build artefacts+-- are out-of-date or not. We do know however that they are not invalid, as+-- that's not possible given our definition of invalid. Intuitively it is+-- because we have not disturbed anything that these packages depend on, e.g.+-- we've not rebuilt any libs they depend on. Recall that our widest+-- definition of invalid was only concerned about dependencies on libraries+-- (to cover problems like shared libs or GHC seeing inconsistent .hi files).+--+-- So our algorithm for out-of-date packages is relatively simple: take the+-- reverse dependency closure in the original improved plan (pre-pruning) of+-- the out-of-date packages (as determined by the BuildStatusMap from the dry+-- run). That gives a set of packages that were definitely out of date after+-- the dry run. Now we remove from this set the packages that the+-- BuildOutcomes tells us are now up-to-date after the build. The remaining+-- set is the out-of-date packages.+--+-- As for packages that are invalid by changed deps, we start with the plan+-- dependency graph but keep only those edges that point to libraries (so+-- ignoring deps on exes and setup scripts). We take the packages for which a+-- build was attempted (successfully or unsuccessfully, but not counting+-- knock-on failures) and take the reverse dependency closure. We delete from+-- this set all the packages that were built successfully. Note that we do not+-- need to intersect with the out-of-date packages since this follows+-- automatically: all rev deps of packages we attempted to build must have+-- been out of date at the start of the build, and if they were not built+-- successfully then they're still out of date -- meeting our definition of+-- invalid.+++type PackageIdSet     = Set UnitId+type PackagesUpToDate = PackageIdSet++newtype PackagesUpToDateG = PackagesUpToDateG { unPackagesUpToDateG :: PackagesUpToDate }++instance Binary.Binary PackagesUpToDateG++instance Generic PackagesUpToDateG where+    type Rep PackagesUpToDateG = Rep [UnitId]+    from = from . Set.toList . unPackagesUpToDateG+    to   = PackagesUpToDateG . Set.fromList . to++data PostBuildProjectStatus = PostBuildProjectStatus {++       -- | Packages that are known to be up to date. These were found to be+       -- up to date before the build, or they have a successful build outcome+       -- afterwards.+       --+       -- This does not include any packages outside of the subset of the plan+       -- that was executed because we did not check those and so don't know+       -- for sure that they're still up to date.+       --+       packagesDefinitelyUpToDate :: PackageIdSet,++       -- | Packages that are probably still up to date (and at least not+       -- known to be out of date, and certainly not invalid). This includes+       -- 'packagesDefinitelyUpToDate' plus packages that were up to date+       -- previously and are outside of the subset of the plan that was+       -- executed. It excludes 'packagesOutOfDate'.+       --+       packagesProbablyUpToDate :: PackageIdSet,++       -- | Packages that are known to be out of date. These are packages+       -- that were determined to be out of date before the build, and they+       -- do not have a successful build outcome afterwards.+       --+       -- Note that this can sometimes include packages outside of the subset+       -- of the plan that was executed. For example suppose package A and B+       -- depend on C, and A is the target so only A and C are in the subset+       -- to be built. Now suppose C is found to have changed, then both A+       -- and B are out-of-date before the build and since B is outside the+       -- subset to be built then it will remain out of date.+       --+       -- Note also that this is /not/ the inverse of+       -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'.+       -- There are packages where we have no information (ones that were not+       -- in the subset of the plan that was executed).+       --+       packagesOutOfDate :: PackageIdSet,++       -- | Packages that depend on libraries that have changed during the+       -- build (either build success or failure).+       --+       -- This corresponds to the fact that libraries and dynamic executables+       -- are invalid once any of the libs they depend on change.+       --+       -- This does include packages that themselves failed (i.e. it is a+       -- superset of 'packagesInvalidByFailedBuild'). It does not include+       -- changes in dependencies on executables (i.e. build tools).+       --+       packagesInvalidByChangedLibDeps :: PackageIdSet,++       -- | Packages that themselves failed during the build (i.e. them+       -- directly not a dep).+       --+       -- This corresponds to the fact that static executables are invalid+       -- in unlucky circumstances such as linking failing half way though,+       -- or data file generation failing.+       --+       -- This is a subset of 'packagesInvalidByChangedLibDeps'.+       --+       packagesInvalidByFailedBuild :: PackageIdSet,++       -- | A subset of the plan graph, including only dependency-on-library+       -- edges. That is, dependencies /on/ libraries, not dependencies /of/+       -- libraries. This tells us all the libraries that packages link to.+       --+       -- This is here as a convenience, as strictly speaking it's not status+       -- as it's just a function of the original 'ElaboratedInstallPlan'.+       --+       packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage),++       -- | As a convenience for 'Set.intersection' with any of the other+       -- 'PackageIdSet's to select only packages that are part of the+       -- project locally (i.e. with a local source dir).+       --+       packagesBuildLocal     :: PackageIdSet,++       -- | As a convenience for 'Set.intersection' with any of the other+       -- 'PackageIdSet's to select only packages that are being built+       -- in-place within the project (i.e. not destined for the store).+       --+       packagesBuildInplace   :: PackageIdSet,++       -- | As a convenience for 'Set.intersection' or 'Set.difference' with+       -- any of the other 'PackageIdSet's to select only packages that were+       -- pre-installed or already in the store prior to the build.+       --+       packagesAlreadyInStore :: PackageIdSet+     }++-- | Work out which packages are out of date or invalid after a build.+--+postBuildProjectStatus :: ElaboratedInstallPlan+                       -> PackagesUpToDate+                       -> BuildStatusMap+                       -> BuildOutcomes+                       -> PostBuildProjectStatus+postBuildProjectStatus plan previousPackagesUpToDate+                       pkgBuildStatus buildOutcomes =+    PostBuildProjectStatus {+      packagesDefinitelyUpToDate,+      packagesProbablyUpToDate,+      packagesOutOfDate,+      packagesInvalidByChangedLibDeps,+      packagesInvalidByFailedBuild,+      -- convenience stuff+      packagesLibDepGraph,+      packagesBuildLocal,+      packagesBuildInplace,+      packagesAlreadyInStore+    }+  where+    packagesDefinitelyUpToDate =+       packagesUpToDatePreBuild+        `Set.union`+       packagesSuccessfulPostBuild++    packagesProbablyUpToDate =+      packagesDefinitelyUpToDate+        `Set.union`+      (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild)++    packagesOutOfDate =+      packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild++    packagesInvalidByChangedLibDeps =+      packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild++    packagesInvalidByFailedBuild =+      packagesFailurePostBuild++    -- Note: if any of the intermediate values below turn out to be useful in+    -- their own right then we can simply promote them to the result record++    -- The previous set of up-to-date packages will contain bogus package ids+    -- when the solver plan or config contributing to the hash changes.+    -- So keep only the ones where the package id (i.e. hash) is the same.+    previousPackagesUpToDate' =+      Set.intersection+        previousPackagesUpToDate+        (InstallPlan.keysSet plan)++    packagesUpToDatePreBuild =+      Set.filter+        (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid))+        -- For packages not in the plan subset we did the dry-run on we don't+        -- know anything about their status, so not known to be /up to date/.+        (InstallPlan.keysSet plan)++    packagesOutOfDatePreBuild =+      Set.fromList . map installedUnitId $+      InstallPlan.reverseDependencyClosure plan+        [ ipkgid+        | pkg <- InstallPlan.toList plan+        , let ipkgid = installedUnitId pkg+        , lookupBuildStatusRequiresBuild False ipkgid+        -- For packages not in the plan subset we did the dry-run on we don't+        -- know anything about their status, so not known to be /out of date/.+        ]++    packagesSuccessfulPostBuild =+      Set.fromList+        [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ]++    -- direct failures, not failures due to deps+    packagesFailurePostBuild =+      Set.fromList+        [ ikgid+        | (ikgid, Left failure) <- Map.toList buildOutcomes+        , case buildFailureReason failure of+            DependentFailed _ -> False+            _                 -> True+        ]++    -- Packages that have a library dependency on a package for which a build+    -- was attempted+    packagesDepOnChangedLib =+      Set.fromList . map Graph.nodeKey $+      fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $+      Graph.revClosure packagesLibDepGraph+        ( Map.keys+        . Map.filter (uncurry buildAttempted)+        $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes +        )++    -- The plan graph but only counting dependency-on-library edges+    packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)+    packagesLibDepGraph =+      Graph.fromList+        [ Graph.N pkg (installedUnitId pkg) libdeps+        | pkg <- InstallPlan.toList plan+        , let libdeps = case pkg of+                InstallPlan.PreExisting ipkg  -> installedDepends ipkg+                InstallPlan.Configured srcpkg -> elabLibDeps srcpkg+                InstallPlan.Installed  srcpkg -> elabLibDeps srcpkg+        ]+    elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies++    -- Was a build was attempted for this package?+    -- If it doesn't have both a build status and outcome then the answer is no.+    buildAttempted :: BuildStatus -> BuildOutcome -> Bool+    -- And not if it didn't need rebuilding in the first place.+    buildAttempted buildStatus _buildOutcome+      | not (buildStatusRequiresBuild buildStatus)+      = False++    -- And not if it was skipped due to a dep failing first.+    buildAttempted _ (Left BuildFailure {buildFailureReason})+      | DependentFailed _ <- buildFailureReason+      = False++    -- Otherwise, succeeded or failed, yes the build was tried.+    buildAttempted _ (Left BuildFailure {}) = True+    buildAttempted _ (Right _)              = True++    lookupBuildStatusRequiresBuild def ipkgid =+      case Map.lookup ipkgid pkgBuildStatus of+        Nothing          -> def -- Not in the plan subset we did the dry-run on+        Just buildStatus -> buildStatusRequiresBuild buildStatus++    packagesBuildLocal =+      selectPlanPackageIdSet $ \pkg ->+        case pkg of+          InstallPlan.PreExisting _     -> False+          InstallPlan.Installed   _     -> False+          InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg++    packagesBuildInplace =+      selectPlanPackageIdSet $ \pkg ->+        case pkg of+          InstallPlan.PreExisting _     -> False+          InstallPlan.Installed   _     -> False+          InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg+                                        == BuildInplaceOnly++    packagesAlreadyInStore =+      selectPlanPackageIdSet $ \pkg ->+        case pkg of+          InstallPlan.PreExisting _ -> True+          InstallPlan.Installed   _ -> True+          InstallPlan.Configured  _ -> False++    selectPlanPackageIdSet p = Map.keysSet+                             . Map.filter p+                             $ InstallPlan.toMap plan++++updatePostBuildProjectStatus :: Verbosity+                             -> DistDirLayout+                             -> ElaboratedInstallPlan+                             -> BuildStatusMap+                             -> BuildOutcomes+                             -> IO PostBuildProjectStatus+updatePostBuildProjectStatus verbosity distDirLayout+                             elaboratedInstallPlan+                             pkgsBuildStatus buildOutcomes = do++    -- Read the previous up-to-date set, update it and write it back+    previousUpToDate   <- readPackagesUpToDateCacheFile distDirLayout+    let currentBuildStatus@PostBuildProjectStatus{..}+                        = postBuildProjectStatus+                            elaboratedInstallPlan+                            previousUpToDate+                            pkgsBuildStatus+                            buildOutcomes+    let currentUpToDate = packagesProbablyUpToDate+    writePackagesUpToDateCacheFile distDirLayout currentUpToDate++    -- Report various possibly interesting things+    -- We additionally intersect with the packagesBuildInplace so that+    -- we don't show huge numbers of boring packages from the store.+    debugNoWrap verbosity $+        "packages definitely up to date: "+     ++ displayPackageIdSet (packagesDefinitelyUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages previously probably up to date: "+     ++ displayPackageIdSet (previousUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages now probably up to date: "+     ++ displayPackageIdSet (packagesProbablyUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages newly up to date: "+     ++ displayPackageIdSet (packagesDefinitelyUpToDate+            `Set.difference` previousUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages out to date: "+     ++ displayPackageIdSet (packagesOutOfDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages invalid due to dep change: "+     ++ displayPackageIdSet packagesInvalidByChangedLibDeps++    debugNoWrap verbosity $+        "packages invalid due to build failure: "+     ++ displayPackageIdSet packagesInvalidByFailedBuild++    return currentBuildStatus+  where+    displayPackageIdSet = intercalate ", " . map display . Set.toList++-- | Helper for reading the cache file.+--+-- This determines the type and format of the binary cache file.+--+readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate+readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =+    handleDoesNotExist Set.empty $+    handleDecodeFailure $+      withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd ->+        fmap (fmap unPackagesUpToDateG) .+            Binary.decodeWithFingerprintOrFailIO =<< BS.hGetContents hnd+  where+    handleDecodeFailure = fmap (either (const Set.empty) id)++-- | Helper for writing the package up-to-date cache file.+--+-- This determines the type and format of the binary cache file.+--+writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()+writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate =+    writeFileAtomic (distProjectCacheFile "up-to-date") $+      Binary.encodeWithFingerprint (PackagesUpToDateG upToDate)++-- Writing .ghc.environment files+--++writePlanGhcEnvironment :: FilePath+                        -> ElaboratedInstallPlan+                        -> ElaboratedSharedConfig+                        -> PostBuildProjectStatus+                        -> IO ()+writePlanGhcEnvironment projectRootDir+                        elaboratedInstallPlan+                        ElaboratedSharedConfig {+                          pkgConfigCompiler = compiler,+                          pkgConfigPlatform = platform+                        }+                        postBuildStatus+  | compilerFlavor compiler == GHC+  , supportsPkgEnvFiles (getImplInfo compiler)+  --TODO: check ghcjs compat+  = writeGhcEnvironmentFile+      projectRootDir+      platform (compilerVersion compiler)+      (renderGhcEnviromentFile projectRootDir+                               elaboratedInstallPlan+                               postBuildStatus)+    --TODO: [required eventually] support for writing user-wide package+    -- environments, e.g. like a global project, but we would not put the+    -- env file in the home dir, rather it lives under ~/.ghc/++writePlanGhcEnvironment _ _ _ _ = return ()++renderGhcEnviromentFile :: FilePath+                        -> ElaboratedInstallPlan+                        -> PostBuildProjectStatus+                        -> [GhcEnvironmentFileEntry]+renderGhcEnviromentFile projectRootDir elaboratedInstallPlan+                        postBuildStatus =+    headerComment+  : simpleGhcEnvironmentFile packageDBs unitIds+  where+    headerComment =+        GhcEnvFileComment+      $ "This is a GHC environment file written by cabal. This means you can\n"+     ++ "run ghc or ghci and get the environment of the project as a whole.\n"+     ++ "But you still need to use cabal repl $target to get the environment\n"+     ++ "of specific components (libs, exes, tests etc) because each one can\n"+     ++ "have its own source dirs, cpp flags etc.\n\n"+    unitIds    = selectGhcEnviromentFileLibraries postBuildStatus+    packageDBs = relativePackageDBPaths projectRootDir $+                 selectGhcEnviromentFilePackageDbs elaboratedInstallPlan+++-- We're producing an environment for users to use in ghci, so of course+-- that means libraries only (can't put exes into the ghc package env!).+-- The library environment should be /consistent/ with the environment+-- that each of the packages in the project use (ie same lib versions).+-- So that means all the normal library dependencies of all the things+-- in the project (including deps of exes that are local to the project).+-- We do not however want to include the dependencies of Setup.hs scripts,+-- since these are generally uninteresting but also they need not in+-- general be consistent with the library versions that packages local to+-- the project use (recall that Setup.hs script's deps can be picked+-- independently of other packages in the project).+--+-- So, our strategy is as follows:+--+-- produce a dependency graph of all the packages in the install plan,+-- but only consider normal library deps as edges in the graph. Thus we+-- exclude the dependencies on Setup.hs scripts (in the case of+-- per-component granularity) or of Setup.hs scripts (in the case of+-- per-package granularity). Then take a dependency closure, using as+-- roots all the packages/components local to the project. This will+-- exclude Setup scripts and their dependencies.+--+-- Note: this algorithm will have to be adapted if/when the install plan+-- is extended to cover multiple compilers at once, and may also have to+-- change if we start to treat unshared deps of test suites in a similar+-- way to how we treat Setup.hs script deps (ie being able to pick them+-- independently).+--+-- Since we had to use all the local packages, including exes, (as roots+-- to find the libs) then those exes still end up in our list so we have+-- to filter them out at the end.+--+selectGhcEnviromentFileLibraries :: PostBuildProjectStatus -> [UnitId]+selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} =+    case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of+      Nothing    -> error "renderGhcEnviromentFile: broken dep closure"+      Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes+                            , hasUpToDateLib pkg ]+  where+    hasUpToDateLib planpkg = case planpkg of+      -- A pre-existing global lib+      InstallPlan.PreExisting  _ -> True++      -- A package in the store. Check it's a lib.+      InstallPlan.Installed  pkg -> elabRequiresRegistration pkg++      -- A package we were installing this time, either destined for the store+      -- or just locally. Check it's a lib and that it is probably up to date.+      InstallPlan.Configured pkg ->+          elabRequiresRegistration pkg+       && installedUnitId pkg `Set.member` packagesProbablyUpToDate+++selectGhcEnviromentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack+selectGhcEnviromentFilePackageDbs elaboratedInstallPlan =+    -- If we have any inplace packages then their package db stack is the+    -- one we should use since it'll include the store + the local db but+    -- it's certainly possible to have no local inplace packages+    -- e.g. just "extra" packages coming from the store.+    case (inplacePackages, sourcePackages) of+      ([], pkgs) -> checkSamePackageDBs pkgs+      (pkgs, _)  -> checkSamePackageDBs pkgs+  where+    checkSamePackageDBs pkgs =+      case ordNub (map elabBuildPackageDBStack pkgs) of+        [packageDbs] -> packageDbs+        []           -> []+        _            -> error $ "renderGhcEnviromentFile: packages with "+                             ++ "different package db stacks"+        -- This should not happen at the moment but will happen as soon+        -- as we support projects where we build packages with different+        -- compilers, at which point we have to consider how to adapt+        -- this feature, e.g. write out multiple env files, one for each+        -- compiler / project profile.++    inplacePackages =+      [ srcpkg+      | srcpkg <- sourcePackages+      , elabBuildStyle srcpkg == BuildInplaceOnly ]+    sourcePackages =+      [ srcpkg+      | pkg <- InstallPlan.toList elaboratedInstallPlan+      , srcpkg <- maybeToList $ case pkg of+                    InstallPlan.Configured srcpkg -> Just srcpkg+                    InstallPlan.Installed  srcpkg -> Just srcpkg+                    InstallPlan.PreExisting _     -> Nothing+      ]++relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack+relativePackageDBPaths relroot = map (relativePackageDBPath relroot)++relativePackageDBPath :: FilePath -> PackageDB -> PackageDB+relativePackageDBPath relroot pkgdb =+    case pkgdb of+      GlobalPackageDB        -> GlobalPackageDB+      UserPackageDB          -> UserPackageDB+      SpecificPackageDB path -> SpecificPackageDB relpath+        where relpath = makeRelative relroot path+
cabal/cabal-install/Distribution/Client/ProjectPlanning.hs view
@@ -1,2333 +1,2971 @@-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns,-             DeriveGeneric, DeriveDataTypeable,-             RankNTypes, ScopedTypeVariables #-}---- | Planning how to build everything in a project.----module Distribution.Client.ProjectPlanning (-    -- * elaborated install plan types-    ElaboratedInstallPlan,-    ElaboratedConfiguredPackage(..),-    ElaboratedPlanPackage,-    ElaboratedSharedConfig(..),-    ElaboratedReadyPackage,-    BuildStyle(..),-    CabalFileText,--    --TODO: [code cleanup] these types should live with execution, not with-    --      plan definition. Need to better separate InstallPlan definition.-    GenericBuildResult(..),-    BuildResult,-    BuildSuccess(..),-    BuildFailure(..),-    DocsResult(..),-    TestsResult(..),--    -- * Producing the elaborated install plan-    rebuildInstallPlan,--    -- * Build targets-    PackageTarget(..),-    ComponentTarget(..),-    SubComponentTarget(..),-    showComponentTarget,--    -- * Selecting a plan subset-    pruneInstallPlanToTargets,--    -- * Utils required for building-    pkgHasEphemeralBuildTargets,-    pkgBuildTargetWholeComponents,--    -- * Setup.hs CLI flags for building-    setupHsScriptOptions,-    setupHsConfigureFlags,-    setupHsBuildFlags,-    setupHsBuildArgs,-    setupHsReplFlags,-    setupHsReplArgs,-    setupHsCopyFlags,-    setupHsRegisterFlags,-    setupHsHaddockFlags,--    packageHashInputs,--    -- TODO: [code cleanup] utils that should live in some shared place?-    createPackageDBIfMissing-  ) where--import           Distribution.Client.PackageHash-import           Distribution.Client.RebuildMonad-import           Distribution.Client.ProjectConfig--import           Distribution.Client.Types hiding-  (BuildResult,BuildSuccess(..), BuildFailure(..), DocsResult(..)-  ,TestsResult(..))-import           Distribution.Client.InstallPlan-                   ( GenericInstallPlan, InstallPlan, GenericPlanPackage )-import qualified Distribution.Client.InstallPlan as InstallPlan-import           Distribution.Client.Dependency-import           Distribution.Client.Dependency.Types-import qualified Distribution.Client.ComponentDeps as CD-import           Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.IndexUtils as IndexUtils-import qualified Distribution.Client.PackageIndex as SourcePackageIndex-import           Distribution.Client.Targets (userToPackageConstraint)-import           Distribution.Client.DistDirLayout-import           Distribution.Client.SetupWrapper-import           Distribution.Client.JobControl-import           Distribution.Client.FetchUtils-import           Distribution.Client.PkgConfigDb-import           Distribution.Client.Setup hiding (packageName, cabalVersion)-import           Distribution.Utils.NubList (toNubList)--import           Distribution.Package hiding-  (InstalledPackageId, installedPackageId)-import           Distribution.System-import qualified Distribution.PackageDescription as Cabal-import qualified Distribution.PackageDescription as PD-import qualified Distribution.PackageDescription.Configuration as PD-import           Distribution.InstalledPackageInfo (InstalledPackageInfo)-import           Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import           Distribution.Simple.Compiler hiding (Flag)-import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate-import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate-import           Distribution.Simple.Program-import           Distribution.Simple.Program.Db-import           Distribution.Simple.Program.Find-import qualified Distribution.Simple.Setup as Cabal-import           Distribution.Simple.Setup-  (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault)-import qualified Distribution.Simple.Configure as Cabal-import           Distribution.ModuleName (ModuleName)-import qualified Distribution.Simple.LocalBuildInfo as Cabal-import           Distribution.Simple.LocalBuildInfo (ComponentName(..))-import qualified Distribution.Simple.Register as Cabal-import qualified Distribution.Simple.InstallDirs as InstallDirs-import           Distribution.Simple.InstallDirs (PathTemplate)-import qualified Distribution.Simple.BuildTarget as Cabal--import           Distribution.Simple.Utils hiding (matchFileGlob)-import           Distribution.Version-import           Distribution.Verbosity-import           Distribution.Text--import           Data.Map (Map)-import qualified Data.Map as Map-import           Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Graph as Graph-import qualified Data.Tree  as Tree-import qualified Data.ByteString.Lazy as LBS--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif-import           Control.Monad-import           Control.Monad.State as State-import           Control.Exception-import           Data.List-import           Data.Maybe-import           Data.Monoid-import           Data.Function--import           Distribution.Compat.Binary-import           GHC.Generics (Generic)-import           Data.Typeable (Typeable)--import           System.FilePath------------------------------------------------------------------------------------ * Elaborated install plan----------------------------------------------------------------------------------- "Elaborated" -- worked out with great care and nicety of detail;---                 executed with great minuteness: elaborate preparations;---                 elaborate care.------ So here's the idea:------ Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc--- all passed in as separate args and which are then further selected,--- transformed etc during the execution of the build. Instead we construct--- an elaborated install plan that includes everything we will need, and then--- during the execution of the plan we do as little transformation of this--- info as possible.------ So we're trying to split the work into two phases: construction of the--- elaborated install plan (which as far as possible should be pure) and--- then simple execution of that plan without any smarts, just doing what the--- plan says to do.------ So that means we need a representation of this fully elaborated install--- plan. The representation consists of two parts:------ * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a---   representation of source packages that includes a lot more detail about---   that package's individual configuration------ * A 'ElaboratedSharedConfig'. Some package configuration is the same for---   every package in a plan. Rather than duplicate that info every entry in---   the 'GenericInstallPlan' we keep that separately.------ The division between the shared and per-package config is /not set in stone--- for all time/. For example if we wanted to generalise the install plan to--- describe a situation where we want to build some packages with GHC and some--- with GHCJS then the platform and compiler would no longer be shared between--- all packages but would have to be per-package (probably with some sanity--- condition on the graph structure).------- | The combination of an elaborated install plan plus a--- 'ElaboratedSharedConfig' contains all the details necessary to be able--- to execute the plan without having to make further policy decisions.------ It does not include dynamic elements such as resources (such as http--- connections).----type ElaboratedInstallPlan-   = GenericInstallPlan InstalledPackageInfo-                        ElaboratedConfiguredPackage-                        BuildSuccess BuildFailure--type ElaboratedPlanPackage-   = GenericPlanPackage InstalledPackageInfo-                        ElaboratedConfiguredPackage-                        BuildSuccess BuildFailure--type SolverInstallPlan-   = InstallPlan --TODO: [code cleanup] redefine locally or move def to solver interface----TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle---      even platform and compiler could be different if we're building things---      like a server + client with ghc + ghcjs-data ElaboratedSharedConfig-   = ElaboratedSharedConfig {--       pkgConfigPlatform         :: Platform,-       pkgConfigCompiler         :: Compiler, --TODO: [code cleanup] replace with CompilerInfo-       pkgConfigProgramDb        :: ProgramDb --TODO: [code cleanup] no Eq instance-       --TODO: [code cleanup] binary instance does not preserve the prog paths-       --      perhaps should keep the configured progs separately-     }-  deriving (Show, Generic)--instance Binary ElaboratedSharedConfig--data ElaboratedConfiguredPackage-   = ElaboratedConfiguredPackage {--       pkgInstalledId :: InstalledPackageId,-       pkgSourceId    :: PackageId,--       -- | TODO: [code cleanup] we don't need this, just a few bits from it:-       --   build type, spec version-       pkgDescription :: Cabal.PackageDescription,--       -- | A total flag assignment for the package-       pkgFlagAssignment   :: Cabal.FlagAssignment,--       -- | The original default flag assignment, used only for reporting.-       pkgFlagDefaults     :: Cabal.FlagAssignment,--       -- | The exact dependencies (on other plan packages)-       ---       pkgDependencies     :: ComponentDeps [ConfiguredId],--       -- | Which optional stanzas (ie testsuites, benchmarks) can be built.-       -- This means the solver produced a plan that has them available.-       -- This doesn't necessary mean we build them by default.-       pkgStanzasAvailable :: Set OptionalStanza,--       -- | Which optional stanzas the user explicitly asked to enable or-       -- to disable. This tells us which ones we build by default, and-       -- helps with error messages when the user asks to build something-       -- they explicitly disabled.-       pkgStanzasRequested :: Map OptionalStanza Bool,--       -- | Which optional stanzas (ie testsuites, benchmarks) will actually-       -- be enabled during the package configure step.-       pkgStanzasEnabled :: Set OptionalStanza,--       -- | Where the package comes from, e.g. tarball, local dir etc. This-       --   is not the same as where it may be unpacked to for the build.-       pkgSourceLocation :: PackageLocation (Maybe FilePath),--       -- | The hash of the source, e.g. the tarball. We don't have this for-       -- local source dir packages.-       pkgSourceHash     :: Maybe PackageSourceHash,--       --pkgSourceDir ? -- currently passed in later because they can use temp locations-       --pkgBuildDir  ? -- but could in principle still have it here, with optional instr to use temp loc--       pkgBuildStyle             :: BuildStyle,--       pkgSetupPackageDBStack    :: PackageDBStack,-       pkgBuildPackageDBStack    :: PackageDBStack,-       pkgRegisterPackageDBStack :: PackageDBStack,--       -- | The package contains a library and so must be registered-       pkgRequiresRegistration :: Bool,-       pkgDescriptionOverride  :: Maybe CabalFileText,--       pkgVanillaLib           :: Bool,-       pkgSharedLib            :: Bool,-       pkgDynExe               :: Bool,-       pkgGHCiLib              :: Bool,-       pkgProfLib              :: Bool,-       pkgProfExe              :: Bool,-       pkgProfLibDetail        :: ProfDetailLevel,-       pkgProfExeDetail        :: ProfDetailLevel,-       pkgCoverage             :: Bool,-       pkgOptimization         :: OptimisationLevel,-       pkgSplitObjs            :: Bool,-       pkgStripLibs            :: Bool,-       pkgStripExes            :: Bool,-       pkgDebugInfo            :: DebugInfoLevel,--       pkgConfigureScriptArgs   :: [String],-       pkgExtraLibDirs          :: [FilePath],-       pkgExtraFrameworkDirs    :: [FilePath],-       pkgExtraIncludeDirs      :: [FilePath],-       pkgProgPrefix            :: Maybe PathTemplate,-       pkgProgSuffix            :: Maybe PathTemplate,--       pkgInstallDirs           :: InstallDirs.InstallDirs FilePath,--       pkgHaddockHoogle         :: Bool,-       pkgHaddockHtml           :: Bool,-       pkgHaddockHtmlLocation   :: Maybe String,-       pkgHaddockExecutables    :: Bool,-       pkgHaddockTestSuites     :: Bool,-       pkgHaddockBenchmarks     :: Bool,-       pkgHaddockInternal       :: Bool,-       pkgHaddockCss            :: Maybe FilePath,-       pkgHaddockHscolour       :: Bool,-       pkgHaddockHscolourCss    :: Maybe FilePath,-       pkgHaddockContents       :: Maybe PathTemplate,--       -- Setup.hs related things:--       -- | One of four modes for how we build and interact with the Setup.hs-       -- script, based on whether it's a build-type Custom, with or without-       -- explicit deps and the cabal spec version the .cabal file needs.-       pkgSetupScriptStyle      :: SetupScriptStyle,--       -- | The version of the Cabal command line interface that we are using-       -- for this package. This is typically the version of the Cabal lib-       -- that the Setup.hs is built against.-       pkgSetupScriptCliVersion :: Version,--       -- Build time related:-       pkgBuildTargets          :: [ComponentTarget],-       pkgReplTarget            :: Maybe ComponentTarget,-       pkgBuildHaddocks         :: Bool-     }-  deriving (Eq, Show, Generic)--instance Binary ElaboratedConfiguredPackage--instance Package ElaboratedConfiguredPackage where-  packageId = pkgSourceId--instance HasUnitId ElaboratedConfiguredPackage where-  installedUnitId = pkgInstalledId--instance PackageFixedDeps ElaboratedConfiguredPackage where-  depends = fmap (map installedPackageId) . pkgDependencies---- | This is used in the install plan to indicate how the package will be--- built.----data BuildStyle =-    -- | The classic approach where the package is built, then the files-    -- installed into some location and the result registered in a package db.-    ---    -- If the package came from a tarball then it's built in a temp dir and-    -- the results discarded.-    BuildAndInstall--    -- | The package is built, but the files are not installed anywhere,-    -- rather the build dir is kept and the package is registered inplace.-    ---    -- Such packages can still subsequently be installed.-    ---    -- Typically 'BuildAndInstall' packages will only depend on other-    -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones.-    ---  | BuildInplaceOnly-  deriving (Eq, Show, Generic)--instance Binary BuildStyle--type CabalFileText = LBS.ByteString--type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage----TODO: [code cleanup] this duplicates the InstalledPackageInfo quite a bit in an install plan--- because the same ipkg is used by many packages. So the binary file will be big.--- Could we keep just (ipkgid, deps) instead of the whole InstalledPackageInfo?--- or transform to a shared form when serialising / deserialising--data GenericBuildResult ipkg iresult ifailure-                  = BuildFailure ifailure-                  | BuildSuccess (Maybe ipkg) iresult-  deriving (Eq, Show, Generic)--instance (Binary ipkg, Binary iresult, Binary ifailure) =>-         Binary (GenericBuildResult ipkg iresult ifailure)--type BuildResult  = GenericBuildResult InstalledPackageInfo-                                       BuildSuccess BuildFailure--data BuildSuccess = BuildOk DocsResult TestsResult-  deriving (Eq, Show, Generic)--data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk-  deriving (Eq, Show, Generic)--data TestsResult = TestsNotTried | TestsOk-  deriving (Eq, Show, Generic)--data BuildFailure = PlanningFailed              --TODO: [required eventually] not yet used-                  | DependentFailed PackageId-                  | DownloadFailed  String      --TODO: [required eventually] not yet used-                  | UnpackFailed    String      --TODO: [required eventually] not yet used-                  | ConfigureFailed String-                  | BuildFailed     String-                  | TestsFailed     String      --TODO: [required eventually] not yet used-                  | InstallFailed   String-  deriving (Eq, Show, Typeable, Generic)--instance Exception BuildFailure--instance Binary BuildFailure-instance Binary BuildSuccess-instance Binary DocsResult-instance Binary TestsResult---sanityCheckElaboratedConfiguredPackage :: ElaboratedSharedConfig-                                       -> ElaboratedConfiguredPackage-                                       -> Bool-sanityCheckElaboratedConfiguredPackage sharedConfig-                                       pkg@ElaboratedConfiguredPackage{..} =--    pkgStanzasEnabled `Set.isSubsetOf` pkgStanzasAvailable--    -- the stanzas explicitly enabled should be available and enabled- && Map.keysSet (Map.filter id pkgStanzasRequested)-      `Set.isSubsetOf` pkgStanzasEnabled--    -- the stanzas explicitly disabled should not be available- && Set.null (Map.keysSet (Map.filter not pkgStanzasRequested)-                `Set.intersection` pkgStanzasAvailable)-- && (pkgBuildStyle == BuildInplaceOnly ||-     installedPackageId pkg == hashedInstalledPackageId-                                 (packageHashInputs sharedConfig pkg))-- && (pkgBuildStyle == BuildInplaceOnly ||-     Set.null pkgStanzasAvailable)------------------------------------------------------------------------------------ * Deciding what to do: making an 'ElaboratedInstallPlan'---------------------------------------------------------------------------------rebuildInstallPlan :: Verbosity-                   -> FilePath -> DistDirLayout -> CabalDirLayout-                   -> ProjectConfig-                   -> IO ( ElaboratedInstallPlan-                         , ElaboratedSharedConfig-                         , ProjectConfig )-rebuildInstallPlan verbosity-                   projectRootDir-                   distDirLayout@DistDirLayout {-                     distDirectory,-                     distProjectCacheFile,-                     distProjectCacheDirectory-                   }-                   cabalDirLayout@CabalDirLayout {-                     cabalPackageCacheDirectory,-                     cabalStoreDirectory,-                     cabalStorePackageDB-                   }-                   cliConfig =-    runRebuild $ do-    progsearchpath <- liftIO $ getSystemSearchPath-    let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty }--    -- The overall improved plan is cached-    rerunIfChanged verbosity projectRootDir fileMonitorImprovedPlan-                   -- react to changes in command line args and the path-                   (cliConfigPersistent, progsearchpath) $ do--      -- And so is the elaborated plan that the improved plan based on-      (elaboratedPlan, elaboratedShared,-       projectConfig) <--        rerunIfChanged verbosity projectRootDir fileMonitorElaboratedPlan-                       (cliConfigPersistent, progsearchpath) $ do--          (projectConfig, projectConfigTransient) <- phaseReadProjectConfig-          localPackages <- phaseReadLocalPackages projectConfig-          compilerEtc   <- phaseConfigureCompiler projectConfig-          solverPlan    <- phaseRunSolver         projectConfigTransient-                                                  compilerEtc localPackages-          (elaboratedPlan,-           elaboratedShared) <- phaseElaboratePlan projectConfigTransient-                                                   compilerEtc-                                                   solverPlan localPackages--          return (elaboratedPlan, elaboratedShared,-                  projectConfig)--      -- The improved plan changes each time we install something, whereas-      -- the underlying elaborated plan only changes when input config-      -- changes, so it's worth caching them separately.-      improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared-      return (improvedPlan, elaboratedShared, projectConfig)--  where-    fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"-    fileMonitorSolverPlan     = newFileMonitorInCacheDir "solver-plan"-    fileMonitorSourceHashes   = newFileMonitorInCacheDir "source-hashes"-    fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"-    fileMonitorImprovedPlan   = newFileMonitorInCacheDir "improved-plan"--    newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b-    newFileMonitorInCacheDir  = newFileMonitor . distProjectCacheFile--    -- Read the cabal.project (or implicit config) and combine it with-    -- arguments from the command line-    ---    phaseReadProjectConfig :: Rebuild (ProjectConfig, ProjectConfig)-    phaseReadProjectConfig = do-      liftIO $ do-        info verbosity "Project settings changed, reconfiguring..."-        createDirectoryIfMissingVerbose verbosity False distDirectory-        createDirectoryIfMissingVerbose verbosity False distProjectCacheDirectory--      projectConfig <- readProjectConfig verbosity projectRootDir--      -- The project config comming from the command line includes "build only"-      -- flags that we don't cache persistently (because like all "build only"-      -- flags they do not affect the value of the outcome) but that we do-      -- sometimes using during planning (in particular the http transport)-      let projectConfigTransient  = projectConfig <> cliConfig-          projectConfigPersistent = projectConfig-                                 <> cliConfig {-                                      projectConfigBuildOnly = mempty-                                    }-      liftIO $ writeProjectConfigFile (distProjectCacheFile "config")-                                      projectConfigPersistent-      return (projectConfigPersistent, projectConfigTransient)--    -- Look for all the cabal packages in the project-    -- some of which may be local src dirs, tarballs etc-    ---    phaseReadLocalPackages :: ProjectConfig-                           -> Rebuild [UnresolvedSourcePackage]-    phaseReadLocalPackages projectConfig = do--      localCabalFiles <- findProjectPackages projectRootDir projectConfig-      mapM (readSourcePackage verbosity) localCabalFiles---    -- Configure the compiler we're using.-    ---    -- This is moderately expensive and doesn't change that often so we cache-    -- it independently.-    ---    phaseConfigureCompiler :: ProjectConfig-                           -> Rebuild (Compiler, Platform, ProgramDb)-    phaseConfigureCompiler ProjectConfig{projectConfigShared} = do-        progsearchpath <- liftIO $ getSystemSearchPath-        rerunIfChanged verbosity projectRootDir fileMonitorCompiler-                       (hcFlavor, hcPath, hcPkg, progsearchpath) $ do--          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."-          result@(_, _, progdb) <- liftIO $-            Cabal.configCompilerEx-              hcFlavor hcPath hcPkg-              defaultProgramDb verbosity--          monitorFiles (programsMonitorFiles progdb)--          return result-      where-        hcFlavor = flagToMaybe projectConfigHcFlavor-        hcPath   = flagToMaybe projectConfigHcPath-        hcPkg    = flagToMaybe projectConfigHcPkg-        ProjectConfigShared {-          projectConfigHcFlavor,-          projectConfigHcPath,-          projectConfigHcPkg-        }        = projectConfigShared---    -- Run the solver to get the initial install plan.-    -- This is expensive so we cache it independently.-    ---    phaseRunSolver :: ProjectConfig-                   -> (Compiler, Platform, ProgramDb)-                   -> [UnresolvedSourcePackage]-                   -> Rebuild (SolverInstallPlan, PackagesImplicitSetupDeps)-    phaseRunSolver projectConfig@ProjectConfig {-                     projectConfigShared,-                     projectConfigBuildOnly-                   }-                   (compiler, platform, progdb)-                   localPackages =-        rerunIfChanged verbosity projectRootDir fileMonitorSolverPlan-                       (solverSettings, cabalPackageCacheDirectory,-                        localPackages, localPackagesEnabledStanzas,-                        compiler, platform, programsDbSignature progdb) $ do--          installedPkgIndex <- getInstalledPackages verbosity-                                                    compiler progdb platform-                                                    corePackageDbs-          sourcePkgDb       <- getSourcePackages    verbosity withRepoCtx-          pkgConfigDB       <- liftIO $-                               readPkgConfigDb      verbosity progdb--          liftIO $ do-            solver <- chooseSolver verbosity-                                   (solverSettingSolver solverSettings)-                                   (compilerInfo compiler)--            notice verbosity "Resolving dependencies..."-            foldProgress logMsg die return $-              planPackages compiler platform solver solverSettings-                           installedPkgIndex sourcePkgDb pkgConfigDB-                           localPackages localPackagesEnabledStanzas-      where-        corePackageDbs = [GlobalPackageDB]-        withRepoCtx    = projectConfigWithSolverRepoContext verbosity-                           cabalPackageCacheDirectory-                           projectConfigShared-                           projectConfigBuildOnly-        solverSettings = resolveSolverSettings projectConfigShared-        logMsg message rest = debugNoWrap verbosity message >> rest--        localPackagesEnabledStanzas =-          Map.fromList-            [ (pkgname, stanzas)-            | pkg <- localPackages-            , let pkgname            = packageName pkg-                  testsEnabled       = lookupLocalPackageConfig-                                         packageConfigTests-                                         projectConfig pkgname-                  benchmarksEnabled  = lookupLocalPackageConfig-                                         packageConfigBenchmarks-                                         projectConfig pkgname-                  stanzas =-                    Map.fromList $-                      [ (TestStanzas, enabled)-                      | enabled <- flagToList testsEnabled ]-                   ++ [ (BenchStanzas , enabled)-                      | enabled <- flagToList benchmarksEnabled ]-            ]--    -- Elaborate the solver's install plan to get a fully detailed plan. This-    -- version of the plan has the final nix-style hashed ids.-    ---    phaseElaboratePlan :: ProjectConfig-                       -> (Compiler, Platform, ProgramDb)-                       -> (SolverInstallPlan, PackagesImplicitSetupDeps)-                       -> [SourcePackage loc]-                       -> Rebuild ( ElaboratedInstallPlan-                                  , ElaboratedSharedConfig )-    phaseElaboratePlan ProjectConfig {-                         projectConfigShared,-                         projectConfigLocalPackages,-                         projectConfigSpecificPackage,-                         projectConfigBuildOnly-                       }-                       (compiler, platform, progdb)-                       (solverPlan, pkgsImplicitSetupDeps)-                       localPackages = do--        liftIO $ debug verbosity "Elaborating the install plan..."--        sourcePackageHashes <--          rerunIfChanged verbosity projectRootDir fileMonitorSourceHashes-                         (map packageId $ InstallPlan.toList solverPlan) $-            getPackageSourceHashes verbosity withRepoCtx solverPlan--        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler-        return $-          elaborateInstallPlan-            platform compiler progdb-            distDirLayout-            cabalDirLayout-            solverPlan-            pkgsImplicitSetupDeps-            localPackages-            sourcePackageHashes-            defaultInstallDirs-            projectConfigShared-            projectConfigLocalPackages-            projectConfigSpecificPackage-      where-        withRepoCtx = projectConfigWithSolverRepoContext verbosity-                        cabalPackageCacheDirectory-                        projectConfigShared-                        projectConfigBuildOnly---    -- Improve the elaborated install plan. The elaborated plan consists-    -- mostly of source packages (with full nix-style hashed ids). Where-    -- corresponding installed packages already exist in the store, replace-    -- them in the plan.-    ---    -- Note that we do monitor the store's package db here, so we will redo-    -- this improvement phase when the db changes -- including as a result of-    -- executing a plan and installing things.-    ---    phaseImprovePlan :: ElaboratedInstallPlan-                     -> ElaboratedSharedConfig-                     -> Rebuild ElaboratedInstallPlan-    phaseImprovePlan elaboratedPlan elaboratedShared = do--        liftIO $ debug verbosity "Improving the install plan..."-        recreateDirectory verbosity True storeDirectory-        storePkgIndex <- getPackageDBContents verbosity-                                              compiler progdb platform-                                              storePackageDb-        let improvedPlan = improveInstallPlanWithPreExistingPackages-                             storePkgIndex-                             elaboratedPlan-        return improvedPlan--      where-        storeDirectory  = cabalStoreDirectory (compilerId compiler)-        storePackageDb  = cabalStorePackageDB (compilerId compiler)-        ElaboratedSharedConfig {-          pkgConfigCompiler  = compiler,-          pkgConfigPlatform  = platform,-          pkgConfigProgramDb = progdb-        } = elaboratedShared---programsMonitorFiles :: ProgramDb -> [MonitorFilePath]-programsMonitorFiles progdb =-    [ monitor-    | prog    <- configuredPrograms progdb-    , monitor <- monitorFileSearchPath (programMonitorFiles prog)-                                       (programPath prog)-    ]---- | Select the bits of a 'ProgramDb' to monitor for value changes.--- Use 'programsMonitorFiles' for the files to monitor.----programsDbSignature :: ProgramDb -> [ConfiguredProgram]-programsDbSignature progdb =-    [ prog { programMonitorFiles = []-           , programOverrideEnv  = filter ((/="PATH") . fst)-                                          (programOverrideEnv prog) }-    | prog <- configuredPrograms progdb ]--getInstalledPackages :: Verbosity-                     -> Compiler -> ProgramDb -> Platform-                     -> PackageDBStack-                     -> Rebuild InstalledPackageIndex-getInstalledPackages verbosity compiler progdb platform packagedbs = do-    monitorFiles . map monitorFileOrDirectory-      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles-                    verbosity compiler-                    packagedbs progdb platform)-    liftIO $ IndexUtils.getInstalledPackages-               verbosity compiler-               packagedbs progdb--getPackageDBContents :: Verbosity-                     -> Compiler -> ProgramDb -> Platform-                     -> PackageDB-                     -> Rebuild InstalledPackageIndex-getPackageDBContents verbosity compiler progdb platform packagedb = do-    monitorFiles . map monitorFileOrDirectory-      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles-                    verbosity compiler-                    [packagedb] progdb platform)-    liftIO $ do-      createPackageDBIfMissing verbosity compiler-                               progdb [packagedb]-      Cabal.getPackageDBContents verbosity compiler-                                 packagedb progdb--getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)-                  -> Rebuild SourcePackageDb-getSourcePackages verbosity withRepoCtx = do-    (sourcePkgDb, repos) <--      liftIO $-        withRepoCtx $ \repoctx -> do-          sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoctx-          return (sourcePkgDb, repoContextRepos repoctx)--    monitorFiles . map monitorFile-                 . IndexUtils.getSourcePackagesMonitorFiles-                 $ repos-    return sourcePkgDb--createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb-                         -> PackageDBStack -> IO ()-createPackageDBIfMissing verbosity compiler progdb packageDbs =-  case reverse packageDbs of-    SpecificPackageDB dbPath : _ -> do-      exists <- liftIO $ Cabal.doesPackageDBExist dbPath-      unless exists $ do-        createDirectoryIfMissingVerbose verbosity False (takeDirectory dbPath)-        Cabal.createPackageDB verbosity compiler progdb False dbPath-    _ -> return ()---recreateDirectory :: Verbosity -> Bool -> FilePath -> Rebuild ()-recreateDirectory verbosity createParents dir = do-    liftIO $ createDirectoryIfMissingVerbose verbosity createParents dir-    monitorFiles [monitorDirectoryExistence dir]----- | Get the 'HashValue' for all the source packages where we use hashes,--- and download any packages required to do so.------ Note that we don't get hashes for local unpacked packages.----getPackageSourceHashes :: Verbosity-                       -> (forall a. (RepoContext -> IO a) -> IO a)-                       -> SolverInstallPlan-                       -> Rebuild (Map PackageId PackageSourceHash)-getPackageSourceHashes verbosity withRepoCtx installPlan = do--    -- Determine which packages need fetching, and which are present already-    ---    pkgslocs <- liftIO $ sequence-      [ do let locm = packageSource pkg-           mloc <- checkFetched locm-           return (pkg, locm, mloc)-      | InstallPlan.Configured-          (ConfiguredPackage pkg _ _ _) <- InstallPlan.toList installPlan ]--    let requireDownloading = [ (pkg, locm) | (pkg, locm, Nothing) <- pkgslocs ]-        alreadyDownloaded  = [ (pkg, loc)  | (pkg, _, Just loc)   <- pkgslocs ]--    -- Download the ones we need-    ---    newlyDownloaded <--      if null requireDownloading-        then return []-        else liftIO $-              withRepoCtx $ \repoctx ->-                sequence-                  [ do loc <- fetchPackage verbosity repoctx locm-                       return (pkg, loc)-                  | (pkg, locm) <- requireDownloading ]--    -- Get the hashes of all the tarball packages (i.e. not local dir pkgs)-    ---    let pkgsTarballs =-          [ (packageId pkg, tarball)-          | (pkg, srcloc) <- newlyDownloaded ++ alreadyDownloaded-          , tarball <- maybeToList (tarballFileLocation srcloc) ]--    monitorFiles [ monitorFile tarball | (_pkgid, tarball) <- pkgsTarballs ]--    liftM Map.fromList $ liftIO $-      sequence-        [ do srchash <- readFileHashValue tarball-             return (pkgid, srchash)-        | (pkgid, tarball) <- pkgsTarballs ]-  where-    tarballFileLocation (LocalUnpackedPackage _dir)      = Nothing-    tarballFileLocation (LocalTarballPackage    tarball) = Just tarball-    tarballFileLocation (RemoteTarballPackage _ tarball) = Just tarball-    tarballFileLocation (RepoTarballPackage _ _ tarball) = Just tarball----- --------------------------------------------------------------- * Installation planning--- --------------------------------------------------------------planPackages :: Compiler-             -> Platform-             -> Solver -> SolverSettings-             -> InstalledPackageIndex-             -> SourcePackageDb-             -> PkgConfigDb-             -> [UnresolvedSourcePackage]-             -> Map PackageName (Map OptionalStanza Bool)-             -> Progress String String-                         (SolverInstallPlan, PackagesImplicitSetupDeps)-planPackages comp platform solver SolverSettings{..}-             installedPkgIndex sourcePkgDb pkgConfigDB-             localPackages pkgStanzasEnable =--    rememberImplicitSetupDeps (depResolverSourcePkgIndex stdResolverParams) <$>--    resolveDependencies-      platform (compilerInfo comp)-      pkgConfigDB solver-      resolverParams--  where--    --TODO: [nice to have] disable multiple instances restriction in the solver, but then-    -- make sure we can cope with that in the output.-    resolverParams =--        setMaxBackjumps solverSettingMaxBackjumps--        --TODO: [required eventually] should only be configurable for custom installs-   -- . setIndependentGoals solverSettingIndependentGoals--      . setReorderGoals solverSettingReorderGoals--        --TODO: [required eventually] should only be configurable for custom installs-   -- . setAvoidReinstalls solverSettingAvoidReinstalls--        --TODO: [required eventually] should only be configurable for custom installs-   -- . setShadowPkgs solverSettingShadowPkgs--      . setStrongFlags solverSettingStrongFlags--        --TODO: [required eventually] decide if we need to prefer installed for-        -- global packages, or prefer latest even for global packages. Perhaps-        -- should be configurable but with a different name than "upgrade-dependencies".-      . setPreferenceDefault PreferLatestForSelected-                           {-(if solverSettingUpgradeDeps-                                then PreferAllLatest-                                else PreferLatestForSelected)-}--      . removeUpperBounds solverSettingAllowNewer--      . addDefaultSetupDependencies (defaultSetupDeps platform-                                   . PD.packageDescription-                                   . packageDescription)--      . addPreferences-          -- preferences from the config file or command line-          [ PackageVersionPreference name ver-          | Dependency name ver <- solverSettingPreferences ]--      . addConstraints-          -- version constraints from the config file or command line-            [ LabeledPackageConstraint (userToPackageConstraint pc) src-            | (pc, src) <- solverSettingConstraints ]--      . addPreferences-          -- enable stanza preference where the user did not specify-          [ PackageStanzasPreference pkgname stanzas-          | pkg <- localPackages-          , let pkgname = packageName pkg-                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable-                stanzas = [ stanza | stanza <- [minBound..maxBound]-                          , Map.lookup stanza stanzaM == Nothing ]-          , not (null stanzas)-          ]--      . addConstraints-          -- enable stanza constraints where the user asked to enable-          [ LabeledPackageConstraint-              (PackageConstraintStanzas pkgname stanzas)-              ConstraintSourceConfigFlagOrTarget-          | pkg <- localPackages-          , let pkgname = packageName pkg-                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable-                stanzas = [ stanza | stanza <- [minBound..maxBound]-                          , Map.lookup stanza stanzaM == Just True ]-          , not (null stanzas)-          ]--      . addConstraints-          --TODO: [nice to have] this just applies all flags to all targets which-          -- is silly. We should check if the flags are appropriate-          [ LabeledPackageConstraint-              (PackageConstraintFlags pkgname flags)-              ConstraintSourceConfigFlagOrTarget-          | let flags = solverSettingFlagAssignment-          , not (null flags)-          , pkg <- localPackages-          , let pkgname = packageName pkg ]--      $ stdResolverParams--    stdResolverParams =-      standardInstallPolicy-        installedPkgIndex sourcePkgDb-        (map SpecificSourcePackage localPackages)------------------------------------------------------------------------------------ * Install plan post-processing----------------------------------------------------------------------------------- This phase goes from the InstallPlan we get from the solver and has to--- make an elaborated install plan.------ We go in two steps:------  1. elaborate all the source packages that the solver has chosen.---  2. swap source packages for pre-existing installed packages wherever---     possible.------ We do it in this order, elaborating and then replacing, because the easiest--- way to calculate the installed package ids used for the replacement step is--- from the elaborated configuration for each package.-------------------------------------------------------------------------------------- * Install plan elaboration----------------------------------------------------------------------------------- | Produce an elaborated install plan using the policy for local builds with--- a nix-style shared store.------ In theory should be able to make an elaborated install plan with a policy--- matching that of the classic @cabal install --user@ or @--global@----elaborateInstallPlan-  :: Platform -> Compiler -> ProgramDb-  -> DistDirLayout-  -> CabalDirLayout-  -> SolverInstallPlan-  -> PackagesImplicitSetupDeps-  -> [SourcePackage loc]-  -> Map PackageId PackageSourceHash-  -> InstallDirs.InstallDirTemplates-  -> ProjectConfigShared-  -> PackageConfig-  -> Map PackageName PackageConfig-  -> (ElaboratedInstallPlan, ElaboratedSharedConfig)-elaborateInstallPlan platform compiler progdb-                     DistDirLayout{..}-                     cabalDirLayout@CabalDirLayout{cabalStorePackageDB}-                     solverPlan pkgsImplicitSetupDeps localPackages-                     sourcePackageHashes-                     defaultInstallDirs-                     _sharedPackageConfig-                     localPackagesConfig-                     perPackageConfig =-    (elaboratedInstallPlan, elaboratedSharedConfig)-  where-    elaboratedSharedConfig =-      ElaboratedSharedConfig {-        pkgConfigPlatform         = platform,-        pkgConfigCompiler         = compiler,-        pkgConfigProgramDb        = progdb-      }--    elaboratedInstallPlan =-      flip InstallPlan.mapPreservingGraph solverPlan $ \mapDep planpkg ->-        case planpkg of-          InstallPlan.PreExisting pkg ->-            InstallPlan.PreExisting pkg--          InstallPlan.Configured  pkg ->-            InstallPlan.Configured-              (elaborateConfiguredPackage (fixupDependencies mapDep pkg))--          _ -> error "elaborateInstallPlan: unexpected package state"--    -- remap the installed package ids of the direct deps, since we're-    -- changing the installed package ids of all the packages to use the-    -- final nix-style hashed ids.-    fixupDependencies mapDep-       (ConfiguredPackage pkg flags stanzas deps) =-        ConfiguredPackage pkg flags stanzas deps'-      where-        deps' = fmap (map (\d -> d { confInstId = mapDep (confInstId d) })) deps--    elaborateConfiguredPackage :: ConfiguredPackage UnresolvedPkgLoc-                               -> ElaboratedConfiguredPackage-    elaborateConfiguredPackage-        pkg@(ConfiguredPackage (SourcePackage pkgid gdesc srcloc descOverride)-                               flags stanzas deps) =-        elaboratedPackage-      where-        -- Knot tying: the final elaboratedPackage includes the-        -- pkgInstalledId, which is calculated by hashing many-        -- of the other fields of the elaboratedPackage.-        ---        elaboratedPackage = ElaboratedConfiguredPackage {..}--        pkgInstalledId-          | shouldBuildInplaceOnly pkg-          = mkUnitId (display pkgid ++ "-inplace")--          | otherwise-          = assert (isJust pkgSourceHash) $-            hashedInstalledPackageId-              (packageHashInputs-                elaboratedSharedConfig-                elaboratedPackage)  -- recursive use of elaboratedPackage--          | otherwise-          = error $ "elaborateInstallPlan: non-inplace package "-                 ++ " is missing a source hash: " ++ display pkgid--        -- All the other fields of the ElaboratedConfiguredPackage-        ---        pkgSourceId         = pkgid-        pkgDescription      = let Right (desc, _) =-                                    PD.finalizePackageDescription-                                    flags (const True)-                                    platform (compilerInfo compiler)-                                    [] gdesc-                               in desc-        pkgFlagAssignment   = flags-        pkgFlagDefaults     = [ (Cabal.flagName flag, Cabal.flagDefault flag)-                              | flag <- PD.genPackageFlags gdesc ]-        pkgDependencies     = deps-        pkgStanzasAvailable = Set.fromList stanzas-        pkgStanzasRequested =-            Map.fromList $ [ (TestStanzas,  v) | v <- maybeToList tests ]-                        ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks ]-          where-            tests, benchmarks :: Maybe Bool-            tests      = perPkgOptionMaybe pkgid packageConfigTests-            benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks--        -- These sometimes get adjusted later-        pkgStanzasEnabled   = Set.empty-        pkgBuildTargets     = []-        pkgReplTarget       = Nothing-        pkgBuildHaddocks    = False--        pkgSourceLocation   = srcloc-        pkgSourceHash       = Map.lookup pkgid sourcePackageHashes-        pkgBuildStyle       = if shouldBuildInplaceOnly pkg-                                then BuildInplaceOnly else BuildAndInstall-        pkgBuildPackageDBStack    = buildAndRegisterDbs-        pkgRegisterPackageDBStack = buildAndRegisterDbs-        pkgRequiresRegistration   = PD.hasPublicLib (PD.packageDescription gdesc)--        pkgSetupScriptStyle       = packageSetupScriptStylePostSolver-                                      pkgsImplicitSetupDeps pkg pkgDescription-        pkgSetupScriptCliVersion  = packageSetupScriptSpecVersion-                                      pkgSetupScriptStyle pkgDescription deps-        pkgSetupPackageDBStack    = buildAndRegisterDbs--        buildAndRegisterDbs-          | shouldBuildInplaceOnly pkg = inplacePackageDbs-          | otherwise                  = storePackageDbs--        pkgDescriptionOverride    = descOverride--        pkgVanillaLib    = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively-        pkgSharedLib     = pkgid `Set.member` pkgsUseSharedLibrary-        pkgDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe-        pkgGHCiLib       = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still--        pkgProfExe       = perPkgOptionFlag pkgid False packageConfigProf-        pkgProfLib       = pkgid `Set.member` pkgsUseProfilingLibrary--        (pkgProfExeDetail,-         pkgProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault-                               packageConfigProfDetail-                               packageConfigProfLibDetail-        pkgCoverage      = perPkgOptionFlag pkgid False packageConfigCoverage--        pkgOptimization  = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization-        pkgSplitObjs     = perPkgOptionFlag pkgid False packageConfigSplitObjs-        pkgStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs-        pkgStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes-        pkgDebugInfo     = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo--        pkgConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs-        pkgExtraLibDirs        = perPkgOptionList pkgid packageConfigExtraLibDirs-        pkgExtraFrameworkDirs  = perPkgOptionList pkgid packageConfigExtraFrameworkDirs-        pkgExtraIncludeDirs    = perPkgOptionList pkgid packageConfigExtraIncludeDirs-        pkgProgPrefix          = perPkgOptionMaybe pkgid packageConfigProgPrefix-        pkgProgSuffix          = perPkgOptionMaybe pkgid packageConfigProgSuffix--        pkgInstallDirs-          | shouldBuildInplaceOnly pkg-          -- use the ordinary default install dirs-          = (InstallDirs.absoluteInstallDirs-               pkgid-               (installedUnitId pkg)-               (compilerInfo compiler)-               InstallDirs.NoCopyDest-               platform-               defaultInstallDirs) {--              InstallDirs.libsubdir  = "", -- absoluteInstallDirs sets these as-              InstallDirs.datasubdir = ""  -- 'undefined' but we have to use-            }                              -- them as "Setup.hs configure" args--          | otherwise-          -- use special simplified install dirs-          = storePackageInstallDirs-              cabalDirLayout-              (compilerId compiler)-              pkgInstalledId--        pkgHaddockHoogle       = perPkgOptionFlag pkgid False packageConfigHaddockHoogle-        pkgHaddockHtml         = perPkgOptionFlag pkgid False packageConfigHaddockHtml-        pkgHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation-        pkgHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables-        pkgHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites-        pkgHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks-        pkgHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal-        pkgHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss-        pkgHaddockHscolour     = perPkgOptionFlag pkgid False packageConfigHaddockHscolour-        pkgHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss-        pkgHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents--    perPkgOptionFlag  :: PackageId -> a ->  (PackageConfig -> Flag a) -> a-    perPkgOptionMaybe :: PackageId ->       (PackageConfig -> Flag a) -> Maybe a-    perPkgOptionList  :: PackageId ->       (PackageConfig -> [a])    -> [a]--    perPkgOptionFlag  pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f)-    perPkgOptionMaybe pkgid     f = flagToMaybe (lookupPerPkgOption pkgid f)-    perPkgOptionList  pkgid     f = lookupPerPkgOption pkgid f--    perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib)-      where-        exe = fromFlagOrDefault def bothflag-        lib = fromFlagOrDefault def (bothflag <> libflag)--        bothflag = lookupPerPkgOption pkgid fboth-        libflag  = lookupPerPkgOption pkgid flib--    lookupPerPkgOption :: (Package pkg, Monoid m)-                       => pkg -> (PackageConfig -> m) -> m-    lookupPerPkgOption pkg f-      -- the project config specifies values that apply to packages local to-      -- but by default non-local packages get all default config values-      -- the project, and can specify per-package values for any package,-      | isLocalToProject pkg = local <> perpkg-      | otherwise            =          perpkg-      where-        local  = f localPackagesConfig-        perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)--    inplacePackageDbs = storePackageDbs-                     ++ [ distPackageDB (compilerId compiler) ]--    storePackageDbs   = [ GlobalPackageDB-                        , cabalStorePackageDB (compilerId compiler) ]--    -- For this local build policy, every package that lives in a local source-    -- dir (as opposed to a tarball), or depends on such a package, will be-    -- built inplace into a shared dist dir. Tarball packages that depend on-    -- source dir packages will also get unpacked locally.-    shouldBuildInplaceOnly :: HasUnitId pkg => pkg -> Bool-    shouldBuildInplaceOnly pkg = Set.member (installedPackageId pkg)-                                            pkgsToBuildInplaceOnly--    pkgsToBuildInplaceOnly :: Set InstalledPackageId-    pkgsToBuildInplaceOnly =-        Set.fromList-      $ map installedPackageId-      $ InstallPlan.reverseDependencyClosure-          solverPlan-          [ fakeUnitId (packageId pkg)-          | pkg <- localPackages ]--    isLocalToProject :: Package pkg => pkg -> Bool-    isLocalToProject pkg = Set.member (packageId pkg)-                                      pkgsLocalToProject--    pkgsLocalToProject :: Set PackageId-    pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ]--    pkgsUseSharedLibrary :: Set PackageId-    pkgsUseSharedLibrary =-        packagesWithDownwardClosedProperty needsSharedLib-      where-        needsSharedLib pkg =-            fromMaybe compilerShouldUseSharedLibByDefault-                      (liftM2 (||) pkgSharedLib pkgDynExe)-          where-            pkgid        = packageId pkg-            pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib-            pkgDynExe    = perPkgOptionMaybe pkgid packageConfigDynExe--    --TODO: [code cleanup] move this into the Cabal lib. It's currently open-    -- coded in Distribution.Simple.Configure, but should be made a proper-    -- function of the Compiler or CompilerInfo.-    compilerShouldUseSharedLibByDefault =-      case compilerFlavor compiler of-        GHC   -> GHC.isDynamic compiler-        GHCJS -> GHCJS.isDynamic compiler-        _     -> False--    pkgsUseProfilingLibrary :: Set PackageId-    pkgsUseProfilingLibrary =-        packagesWithDownwardClosedProperty needsProfilingLib-      where-        needsProfilingLib pkg =-            fromFlagOrDefault False (profBothFlag <> profLibFlag)-          where-            pkgid        = packageId pkg-            profBothFlag = lookupPerPkgOption pkgid packageConfigProf-            profLibFlag  = lookupPerPkgOption pkgid packageConfigProfLib-            --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe--    packagesWithDownwardClosedProperty property =-        Set.fromList-      $ map packageId-      $ InstallPlan.dependencyClosure-          solverPlan-          [ installedPackageId pkg-          | pkg <- InstallPlan.toList solverPlan-          , property pkg ] -- just the packages that satisfy the propety-      --TODO: [nice to have] this does not check the config consistency,-      -- e.g. a package explicitly turning off profiling, but something-      -- depending on it that needs profiling. This really needs a separate-      -- package config validation/resolution pass.--      --TODO: [nice to have] config consistency checking:-      -- * profiling libs & exes, exe needs lib, recursive-      -- * shared libs & exes, exe needs lib, recursive-      -- * vanilla libs & exes, exe needs lib, recursive-      -- * ghci or shared lib needed by TH, recursive, ghc version dependent--------------------------------- Build targets------- | The various targets within a package. This is more of a high level--- specification than a elaborated prescription.----data PackageTarget =-     -- | Build the default components in this package. This usually means-     -- just the lib and exes, but it can also mean the testsuites and-     -- benchmarks if the user explicitly requested them.-     BuildDefaultComponents-     -- | Build a specific component in this package.-   | BuildSpecificComponent ComponentTarget-   | ReplDefaultComponent-   | ReplSpecificComponent  ComponentTarget-   | HaddockDefaultComponents-  deriving (Eq, Show, Generic)--data ComponentTarget = ComponentTarget ComponentName SubComponentTarget-  deriving (Eq, Show, Generic)--data SubComponentTarget = WholeComponent-                        | ModuleTarget ModuleName-                        | FileTarget   FilePath-  deriving (Eq, Show, Generic)--instance Binary PackageTarget-instance Binary ComponentTarget-instance Binary SubComponentTarget-----TODO: this needs to report some user target/config errors-elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget]-                        -> ([ComponentTarget], Maybe ComponentTarget, Bool)-elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =-    let buildTargets  = nubComponentTargets-                      . map compatSubComponentTargets-                      . concatMap elaborateBuildTarget-                      $ targets-        --TODO: instead of listToMaybe we should be reporting an error here-        replTargets   = listToMaybe-                      . nubComponentTargets-                      . map compatSubComponentTargets-                      . concatMap elaborateReplTarget-                      $ targets-        buildHaddocks = HaddockDefaultComponents `elem` targets--     in (buildTargets, replTargets, buildHaddocks)-  where-    --TODO: need to report an error here if defaultComponents is empty-    elaborateBuildTarget  BuildDefaultComponents    = pkgDefaultComponents-    elaborateBuildTarget (BuildSpecificComponent t) = [t]-    elaborateBuildTarget  _                         = []--    --TODO: need to report an error here if defaultComponents is empty-    elaborateReplTarget  ReplDefaultComponent     = take 1 pkgDefaultComponents-    elaborateReplTarget (ReplSpecificComponent t) = [t]-    elaborateReplTarget  _                        = []--    pkgDefaultComponents =-        [ ComponentTarget cname WholeComponent-        | c <- Cabal.pkgComponents pkgDescription-        , PD.buildable (Cabal.componentBuildInfo c)-        , let cname = Cabal.componentName c-        , enabledOptionalStanza cname-        ]-      where-        enabledOptionalStanza cname =-          case componentOptionalStanza cname of-            Nothing     -> True-            Just stanza -> Map.lookup stanza pkgStanzasRequested-                        == Just True--    -- Not all Cabal Setup.hs versions support sub-component targets, so switch-    -- them over to the whole component-    compatSubComponentTargets :: ComponentTarget -> ComponentTarget-    compatSubComponentTargets target@(ComponentTarget cname _subtarget)-      | not setupHsSupportsSubComponentTargets-                  = ComponentTarget cname WholeComponent-      | otherwise = target--    -- Actually the reality is that no current version of Cabal's Setup.hs-    -- build command actually support building specific files or modules.-    setupHsSupportsSubComponentTargets = False-    -- TODO: when that changes, adjust this test, e.g.-    -- | pkgSetupScriptCliVersion >= Version [x,y] []--    nubComponentTargets :: [ComponentTarget] -> [ComponentTarget]-    nubComponentTargets =-        concatMap (wholeComponentOverrides . map snd)-      . groupBy ((==)    `on` fst)-      . sortBy  (compare `on` fst)-      . map (\t@(ComponentTarget cname _) -> (cname, t))--    -- If we're building the whole component then that the only target all we-    -- need, otherwise we can have several targets within the component.-    wholeComponentOverrides :: [ComponentTarget] -> [ComponentTarget]-    wholeComponentOverrides ts =-      case [ t | t@(ComponentTarget _ WholeComponent) <- ts ] of-        (t:_) -> [t]-        []    -> ts---pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool-pkgHasEphemeralBuildTargets pkg =-    isJust (pkgReplTarget pkg)- || (not . null) [ () | ComponentTarget _ subtarget <- pkgBuildTargets pkg-                      , subtarget /= WholeComponent ]---- | The components that we'll build all of, meaning that after they're built--- we can skip building them again (unlike with building just some modules or--- other files within a component).----pkgBuildTargetWholeComponents :: ElaboratedConfiguredPackage-                              -> Set ComponentName-pkgBuildTargetWholeComponents pkg =-    Set.fromList-      [ cname | ComponentTarget cname WholeComponent <- pkgBuildTargets pkg ]------------------------------------------------------------------------------------ * Install plan pruning----------------------------------------------------------------------------------- | Given a set of package targets (and optionally component targets within--- those packages), take the subset of the install plan needed to build those--- targets. Also, update the package config to specify which optional stanzas--- to enable, and which targets within each package to build.----pruneInstallPlanToTargets :: Map InstalledPackageId [PackageTarget]-                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan-pruneInstallPlanToTargets perPkgTargetsMap =-    either (\_ -> assert False undefined) id-  . InstallPlan.new False-  . PackageIndex.fromList-    -- We have to do this in two passes-  . pruneInstallPlanPass2-  . pruneInstallPlanPass1 perPkgTargetsMap-  . InstallPlan.toList---- The first pass does three things:------ * Set the build targets based on the user targets (but not rev deps yet).--- * A first go at determining which optional stanzas (testsuites, benchmarks)---   are needed. We have a second go in the next pass.--- * Take the dependency closure using pruned dependencies. We prune deps that---   are used only by unneeded optional stanzas. These pruned deps are only---   used for the dependency closure and are not persisted in this pass.----pruneInstallPlanPass1 :: Map InstalledPackageId [PackageTarget]-                      -> [ElaboratedPlanPackage]-                      -> [ElaboratedPlanPackage]-pruneInstallPlanPass1 perPkgTargetsMap pkgs =-    map fst $-    dependencyClosure-      (installedPackageId . fst)  -- the pkg id-      snd                         -- the pruned deps-      [ (pkg', pruneOptionalDependencies pkg')-      | pkg <- pkgs-      , let pkg' = mapConfiguredPackage-                     (pruneOptionalStanzas . setBuildTargets) pkg-      ]-      (Map.keys perPkgTargetsMap)-  where-    -- Elaborate and set the targets we'll build for this package. This is just-    -- based on the targets from the user, not targets implied by reverse-    -- depencencies. Those comes in the second pass once we know the rev deps.-    ---    setBuildTargets pkg =-        pkg {-          pkgBuildTargets   = buildTargets,-          pkgReplTarget     = replTarget,-          pkgBuildHaddocks  = buildHaddocks-        }-      where-        (buildTargets, replTarget, buildHaddocks)-                = elaboratePackageTargets pkg targets-        targets = fromMaybe []-                $ Map.lookup (installedPackageId pkg) perPkgTargetsMap--    -- Decide whether or not to enable testsuites and benchmarks-    ---    -- The testsuite and benchmark targets are somewhat special in that we need-    -- to configure the packages with them enabled, and we need to do that even-    -- if we only want to build one of several testsuites.-    ---    -- There are two cases in which we will enable the testsuites (or-    -- benchmarks): if one of the targets is a testsuite, or if all of the-    -- testsuite depencencies are already cached in the store. The rationale-    -- for the latter is to minimise how often we have to reconfigure due to-    -- the particular targets we choose to build. Otherwise choosing to build-    -- a testsuite target, and then later choosing to build an exe target-    -- would involve unnecessarily reconfiguring the package with testsuites-    -- disabled. Technically this introduces a little bit of stateful-    -- behaviour to make this "sticky", but it should be benign.-    ---    pruneOptionalStanzas pkg = pkg { pkgStanzasEnabled = stanzas }-      where-        stanzas :: Set OptionalStanza-        stanzas = optionalStanzasRequiredByTargets  pkg-               <> optionalStanzasRequestedByDefault pkg-               <> optionalStanzasWithDepsAvailable availablePkgs pkg--    -- Calculate package depencencies but cut out those needed only by-    -- optional stanzas that we've determined we will not enable.-    -- These pruned deps are not persisted in this pass since they're based on-    -- the optional stanzas and we'll make further tweaks to the optional-    -- stanzas in the next pass.-    ---    pruneOptionalDependencies :: ElaboratedPlanPackage -> [InstalledPackageId]-    pruneOptionalDependencies (InstallPlan.Configured pkg) =-        (CD.flatDeps . CD.filterDeps keepNeeded) (depends pkg)-      where-        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas-        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas-        keepNeeded _                     _ = True-        stanzas = pkgStanzasEnabled pkg-    pruneOptionalDependencies pkg =-        CD.flatDeps (depends pkg)--    optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage-                                     -> Set OptionalStanza-    optionalStanzasRequiredByTargets pkg =-      Set.fromList-        [ stanza-        | ComponentTarget cname _ <- pkgBuildTargets pkg-                                  ++ maybeToList (pkgReplTarget pkg)-        , stanza <- maybeToList (componentOptionalStanza cname)-        ]--    optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage-                                      -> Set OptionalStanza-    optionalStanzasRequestedByDefault =-        Map.keysSet-      . Map.filter (id :: Bool -> Bool)-      . pkgStanzasRequested--    availablePkgs =-      Set.fromList-        [ installedPackageId pkg-        | InstallPlan.PreExisting pkg <- pkgs ]--optionalStanzasWithDepsAvailable :: Set InstalledPackageId-                                 -> ElaboratedConfiguredPackage-                                 -> Set OptionalStanza-optionalStanzasWithDepsAvailable availablePkgs pkg =-    Set.fromList-      [ stanza-      | stanza <- Set.toList (pkgStanzasAvailable pkg)-      , let deps :: [InstalledPackageId]-            deps = map installedPackageId-                 $ CD.select (optionalStanzaDeps stanza)-                             (pkgDependencies pkg)-      , all (`Set.member` availablePkgs) deps-      ]-  where-    optionalStanzaDeps TestStanzas  (CD.ComponentTest  _) = True-    optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True-    optionalStanzaDeps _            _                     = False----- The second pass does three things:------ * A second go at deciding which optional stanzas to enable.--- * Prune the depencencies based on the final choice of optional stanzas.--- * Extend the targets within each package to build, now we know the reverse---   depencencies, ie we know which libs are needed as deps by other packages.------ Achieving sticky behaviour with enabling\/disabling optional stanzas is--- tricky. The first approximation was handled by the first pass above, but--- it's not quite enough. That pass will enable stanzas if all of the deps--- of the optional stanza are already instaled /in the store/. That's important--- but it does not account for depencencies that get built inplace as part of--- the project. We cannot take those inplace build deps into account in the--- pruning pass however because we don't yet know which ones we're going to--- build. Once we do know, we can have another go and enable stanzas that have--- all their deps available. Now we can consider all packages in the pruned--- plan to be available, including ones we already decided to build from--- source.------ Deciding which targets to build depends on knowing which packages have--- reverse dependencies (ie are needed). This requires the result of first--- pass, which is another reason we have to split it into two passes.------ Note that just because we might enable testsuites or benchmarks (in the--- first or second pass) doesn't mean that we build all (or even any) of them.--- That depends on which targets we picked in the first pass.----pruneInstallPlanPass2 :: [ElaboratedPlanPackage]-                      -> [ElaboratedPlanPackage]-pruneInstallPlanPass2 pkgs =-    map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs-  where-    setStanzasDepsAndTargets pkg =-        pkg {-          pkgStanzasEnabled = stanzas,-          pkgDependencies   = CD.filterDeps keepNeeded (pkgDependencies pkg),-          pkgBuildTargets   = pkgBuildTargets pkg ++ targetsRequiredForRevDeps-        }-      where-        stanzas :: Set OptionalStanza-        stanzas = pkgStanzasEnabled pkg-               <> optionalStanzasWithDepsAvailable availablePkgs pkg--        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas-        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas-        keepNeeded _                     _ = True--        targetsRequiredForRevDeps =-          [ ComponentTarget (Cabal.defaultLibName (pkgSourceId pkg)) WholeComponent-          -- if anything needs this pkg, build the library component-          | installedPackageId pkg `Set.member` hasReverseLibDeps-          ]-        --TODO: also need to track build-tool rev-deps for exes--    availablePkgs :: Set InstalledPackageId-    availablePkgs = Set.fromList (map installedPackageId pkgs)--    hasReverseLibDeps :: Set InstalledPackageId-    hasReverseLibDeps =-      Set.fromList [ depid | pkg <- pkgs-                           , depid <- CD.flatDeps (depends pkg) ]---mapConfiguredPackage :: (ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage)-                     -> ElaboratedPlanPackage-                     -> ElaboratedPlanPackage-mapConfiguredPackage f (InstallPlan.Configured pkg) =-  InstallPlan.Configured (f pkg)-mapConfiguredPackage _ pkg = pkg--componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza-componentOptionalStanza (Cabal.CTestName  _) = Just TestStanzas-componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas-componentOptionalStanza _                    = Nothing---dependencyClosure :: (pkg -> InstalledPackageId)-                  -> (pkg -> [InstalledPackageId])-                  -> [pkg]-                  -> [InstalledPackageId]-                  -> [pkg]-dependencyClosure pkgid deps allpkgs =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs graph-  . map pkgidToVertex-  where-    (graph, vertexToPkg, pkgidToVertex) = dependencyGraph pkgid deps allpkgs--dependencyGraph :: (pkg -> InstalledPackageId)-                -> (pkg -> [InstalledPackageId])-                -> [pkg]-                -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    InstalledPackageId -> Graph.Vertex)-dependencyGraph pkgid deps pkgs =-    (graph, vertexToPkg', pkgidToVertex')-  where-    (graph, vertexToPkg, pkgidToVertex) =-      Graph.graphFromEdges [ ( pkg, pkgid pkg, deps pkg )-                           | pkg <- pkgs ]-    vertexToPkg'   = (\(pkg,_,_) -> pkg)-                   . vertexToPkg-    pkgidToVertex' = fromMaybe (error "dependencyGraph: lookup failure")-                   . pkgidToVertex--------------------------------- Setup.hs script policy------- Handling for Setup.hs scripts is a bit tricky, part of it lives in the--- solver phase, and part in the elaboration phase. We keep the helper--- functions for both phases together here so at least you can see all of it--- in one place.---- | There are four major cases for Setup.hs handling:------  1. @build-type@ Custom with a @custom-setup@ section---  2. @build-type@ Custom without a @custom-setup@ section---  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@---  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@------ It's also worth noting that packages specifying @cabal-version: >= 1.23@--- or later that have @build-type@ Custom will always have a @custom-setup@--- section. Therefore in case 2, the specified @cabal-version@ will always be--- less than 1.23.------ In cases 1 and 2 we obviously have to build an external Setup.hs script,--- while in case 4 we can use the internal library API. In case 3 we also have--- to build an external Setup.hs script because the package needs a later--- Cabal lib version than we can support internally.----data SetupScriptStyle = SetupCustomExplicitDeps-                      | SetupCustomImplicitDeps-                      | SetupNonCustomExternalLib-                      | SetupNonCustomInternalLib-  deriving (Eq, Show, Generic)--instance Binary SetupScriptStyle----- | Work out the 'SetupScriptStyle' given the package description.------ This only works on original packages before we give them to the solver,--- since after the solver some implicit setup deps are made explicit.------ See 'rememberImplicitSetupDeps' and 'packageSetupScriptStylePostSolver'.----packageSetupScriptStylePreSolver :: PD.PackageDescription -> SetupScriptStyle-packageSetupScriptStylePreSolver pkg-  | buildType == PD.Custom-  , isJust (PD.setupBuildInfo pkg)-  = SetupCustomExplicitDeps--  | buildType == PD.Custom-  = SetupCustomImplicitDeps--  | PD.specVersion pkg > cabalVersion -- one cabal-install is built against-  = SetupNonCustomExternalLib--  | otherwise-  = SetupNonCustomInternalLib-  where-    buildType = fromMaybe PD.Custom (PD.buildType pkg)----- | Part of our Setup.hs handling policy is implemented by getting the solver--- to work out setup dependencies for packages. The solver already handles--- packages that explicitly specify setup dependencies, but we can also tell--- the solver to treat other packages as if they had setup dependencies.--- That's what this function does, it gets called by the solver for all--- packages that don't already have setup dependencies.------ The dependencies we want to add is different for each 'SetupScriptStyle'.------ Note that adding default deps means these deps are actually /added/ to the--- packages that we get out of the solver in the 'SolverInstallPlan'. Making--- implicit setup deps explicit is a problem in the post-solver stages because--- we still need to distinguish the case of explicit and implict setup deps.--- See 'rememberImplicitSetupDeps'.----defaultSetupDeps :: Platform -> PD.PackageDescription -> [Dependency]-defaultSetupDeps platform pkg =-    case packageSetupScriptStylePreSolver pkg of--      -- For packages with build type custom that do not specify explicit-      -- setup dependencies, we add a dependency on Cabal and a number-      -- of other packages.-      SetupCustomImplicitDeps ->-        [ Dependency depPkgname anyVersion-        | depPkgname <- legacyCustomSetupPkgs platform ] ++-        -- The Cabal dep is slightly special:-        --  * we omit the dep for the Cabal lib itself (since it bootstraps),-        --  * we constrain it to be less than 1.23 since all packages-        --    relying on later Cabal spec versions are supposed to use-        --    explit setup deps. Having this constraint also allows later-        --    Cabal lib versions to make breaking API changes without breaking-        --    all old Setup.hs scripts.-        [ Dependency cabalPkgname cabalConstraint-        | packageName pkg /= cabalPkgname ]-        where-          cabalConstraint   = orLaterVersion (PD.specVersion pkg)-                                `intersectVersionRanges`-                              earlierVersion cabalCompatMaxVer-        -- TODO/FIXME: turns out that constraining to less than 1.23 causes-        --             problems with GHC8 as there's too many important packages-        --             with Custom build-type, for which there wouldn't be any-        --             install-plan (as GHC8 requires Cabal-1.24+). So let's-        --             set an implicit upper bound `Cabal < 2` instead.-          cabalCompatMaxVer = Version [2] []--      -- For other build types (like Simple) if we still need to compile an-      -- external Setup.hs, it'll be one of the simple ones that only depends-      -- on Cabal and base.-      SetupNonCustomExternalLib ->-        [ Dependency cabalPkgname cabalConstraint-        , Dependency basePkgname  anyVersion ]-        where-          cabalConstraint = orLaterVersion (PD.specVersion pkg)--      -- The internal setup wrapper method has no deps at all.-      SetupNonCustomInternalLib -> []--      SetupCustomExplicitDeps ->-        error $ "defaultSetupDeps: called for a package with explicit "-             ++ "setup deps: " ++ display (packageId pkg)----- | See 'rememberImplicitSetupDeps' for details.-type PackagesImplicitSetupDeps = Set InstalledPackageId---- | A consequence of using 'defaultSetupDeps' in 'planPackages' is that by--- making implicit setup deps explicit we loose track of which packages--- originally had implicit setup deps. That's important because we do still--- have different behaviour based on the setup style (in particular whether to--- compile a Setup.hs script with version macros).------ So we remember the necessary information in an auxilliary set and use it--- in 'packageSetupScriptStylePreSolver' to recover the full info.----rememberImplicitSetupDeps :: SourcePackageIndex.PackageIndex (SourcePackage loc)-                          -> SolverInstallPlan-                          -> (SolverInstallPlan, PackagesImplicitSetupDeps)-rememberImplicitSetupDeps sourcePkgIndex plan =-    (plan, pkgsImplicitSetupDeps)-  where-    pkgsImplicitSetupDeps =-      Set.fromList-        [ installedPackageId pkg-        | InstallPlan.Configured-            pkg@(ConfiguredPackage newpkg _ _ _) <- InstallPlan.toList plan-          -- has explicit setup deps now-        , hasExplicitSetupDeps newpkg-          -- but originally had no setup deps-        , let Just origpkg = SourcePackageIndex.lookupPackageId-                               sourcePkgIndex (packageId pkg)-        , not (hasExplicitSetupDeps origpkg)-        ]--    hasExplicitSetupDeps =-        (SetupCustomExplicitDeps==)-      . packageSetupScriptStylePreSolver-      . PD.packageDescription . packageDescription----- | Use the extra info saved by 'rememberImplicitSetupDeps' to let us work--- out the correct 'SetupScriptStyle'. This should give the same result as--- 'packageSetupScriptStylePreSolver' gave prior to munging the package info--- through the solver.----packageSetupScriptStylePostSolver :: Set InstalledPackageId-                                  -> ConfiguredPackage loc-                                  -> PD.PackageDescription-                                  -> SetupScriptStyle-packageSetupScriptStylePostSolver pkgsImplicitSetupDeps pkg pkgDescription =-    case packageSetupScriptStylePreSolver pkgDescription of-      SetupCustomExplicitDeps-        | Set.member (installedPackageId pkg) pkgsImplicitSetupDeps-            -> SetupCustomImplicitDeps-      other -> other----- | Work out which version of the Cabal spec we will be using to talk to the--- Setup.hs interface for this package.------ This depends somewhat on the 'SetupScriptStyle' but most cases are a result--- of what the solver picked for us, based on the explicit setup deps or the--- ones added implicitly by 'defaultSetupDeps'.----packageSetupScriptSpecVersion :: Package pkg-                              => SetupScriptStyle-                              -> PD.PackageDescription-                              -> ComponentDeps [pkg]-                              -> Version---- We're going to be using the internal Cabal library, so the spec version of--- that is simply the version of the Cabal library that cabal-install has been--- built with.-packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ =-    cabalVersion---- If we happen to be building the Cabal lib itself then because that--- bootstraps itself then we use the version of the lib we're building.-packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _-  | packageName pkg == cabalPkgname-  = packageVersion pkg---- In all other cases we have a look at what version of the Cabal lib the--- solver picked. Or if it didn't depend on Cabal at all (which is very rare)--- then we look at the .cabal file to see what spec version it declares.-packageSetupScriptSpecVersion _ pkg deps =-    case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of-      Just dep -> packageVersion dep-      Nothing  -> PD.specVersion pkg---cabalPkgname, basePkgname :: PackageName-cabalPkgname = PackageName "Cabal"-basePkgname  = PackageName "base"---legacyCustomSetupPkgs :: Platform -> [PackageName]-legacyCustomSetupPkgs (Platform _ os) =-    map PackageName $-        [ "array", "base", "binary", "bytestring", "containers"-        , "deepseq", "directory", "filepath", "pretty"-        , "process", "time" ]-     ++ [ "Win32" | os == Windows ]-     ++ [ "unix"  | os /= Windows ]---- The other aspects of our Setup.hs policy lives here where we decide on--- the 'SetupScriptOptions'.------ Our current policy for the 'SetupCustomImplicitDeps' case is that we--- try to make the implicit deps cover everything, and we don't allow the--- compiler to pick up other deps. This may or may not be sustainable, and--- we might have to allow the deps to be non-exclusive, but that itself would--- be tricky since we would have to allow the Setup access to all the packages--- in the store and local dbs.--setupHsScriptOptions :: ElaboratedReadyPackage-                     -> ElaboratedSharedConfig-                     -> FilePath-                     -> FilePath-                     -> Bool-                     -> Lock-                     -> SetupScriptOptions-setupHsScriptOptions (ReadyPackage ElaboratedConfiguredPackage{..})-                     ElaboratedSharedConfig{..} srcdir builddir-                     isParallelBuild cacheLock =-    SetupScriptOptions {-      useCabalVersion          = thisVersion pkgSetupScriptCliVersion,-      useCabalSpecVersion      = Just pkgSetupScriptCliVersion,-      useCompiler              = Just pkgConfigCompiler,-      usePlatform              = Just pkgConfigPlatform,-      usePackageDB             = pkgSetupPackageDBStack,-      usePackageIndex          = Nothing,-      useDependencies          = [ (uid, srcid)-                                 | ConfiguredId srcid uid <- CD.setupDeps pkgDependencies ],-      useDependenciesExclusive = True,-      useVersionMacros         = pkgSetupScriptStyle == SetupCustomExplicitDeps,-      useProgramConfig         = pkgConfigProgramDb,-      useDistPref              = builddir,-      useLoggingHandle         = Nothing, -- this gets set later-      useWorkingDir            = Just srcdir,-      useWin32CleanHack        = False,   --TODO: [required eventually]-      forceExternalSetupMethod = isParallelBuild,-      setupCacheLock           = Just cacheLock-    }----- | To be used for the input for elaborateInstallPlan.------ TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure.----userInstallDirTemplates :: Compiler-                        -> IO InstallDirs.InstallDirTemplates-userInstallDirTemplates compiler = do-    InstallDirs.defaultInstallDirs-                  (compilerFlavor compiler)-                  True  -- user install-                  False -- unused--storePackageInstallDirs :: CabalDirLayout-                        -> CompilerId-                        -> InstalledPackageId-                        -> InstallDirs.InstallDirs FilePath-storePackageInstallDirs CabalDirLayout{cabalStorePackageDirectory}-                        compid ipkgid =-    InstallDirs.InstallDirs {..}-  where-    prefix       = cabalStorePackageDirectory compid ipkgid-    bindir       = prefix </> "bin"-    libdir       = prefix </> "lib"-    libsubdir    = ""-    dynlibdir    = libdir-    libexecdir   = prefix </> "libexec"-    includedir   = libdir </> "include"-    datadir      = prefix </> "share"-    datasubdir   = ""-    docdir       = datadir </> "doc"-    mandir       = datadir </> "man"-    htmldir      = docdir  </> "html"-    haddockdir   = htmldir-    sysconfdir   = prefix </> "etc"-----TODO: [code cleanup] perhaps reorder this code--- based on the ElaboratedInstallPlan + ElaboratedSharedConfig,--- make the various Setup.hs {configure,build,copy} flags---setupHsConfigureFlags :: ElaboratedReadyPackage-                      -> ElaboratedSharedConfig-                      -> Verbosity-                      -> FilePath-                      -> Cabal.ConfigFlags-setupHsConfigureFlags (ReadyPackage-                         pkg@ElaboratedConfiguredPackage{..})-                      sharedConfig@ElaboratedSharedConfig{..}-                      verbosity builddir =-    assert (sanityCheckElaboratedConfiguredPackage sharedConfig pkg)-    Cabal.ConfigFlags {..}-  where-    configDistPref            = toFlag builddir-    configVerbosity           = toFlag verbosity--    configIPID                = toFlag (display (installedUnitId pkg))--    configProgramPaths        = programDbProgramPaths pkgConfigProgramDb-    configProgramArgs         = programDbProgramArgs  pkgConfigProgramDb-    configProgramPathExtra    = programDbPathExtra    pkgConfigProgramDb-    configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)-    configHcPath              = mempty -- use configProgramPaths instead-    configHcPkg               = mempty -- use configProgramPaths instead--    configVanillaLib          = toFlag pkgVanillaLib-    configSharedLib           = toFlag pkgSharedLib-    configDynExe              = toFlag pkgDynExe-    configGHCiLib             = toFlag pkgGHCiLib-    configProfExe             = mempty-    configProfLib             = toFlag pkgProfLib-    configProf                = toFlag pkgProfExe--    -- configProfDetail is for exe+lib, but overridden by configProfLibDetail-    -- so we specify both so we can specify independently-    configProfDetail          = toFlag pkgProfExeDetail-    configProfLibDetail       = toFlag pkgProfLibDetail--    configCoverage            = toFlag pkgCoverage-    configLibCoverage         = mempty--    configOptimization        = toFlag pkgOptimization-    configSplitObjs           = toFlag pkgSplitObjs-    configStripExes           = toFlag pkgStripExes-    configStripLibs           = toFlag pkgStripLibs-    configDebugInfo           = toFlag pkgDebugInfo-    configAllowNewer          = mempty -- we use configExactConfiguration True--    configConfigurationsFlags = pkgFlagAssignment-    configConfigureArgs       = pkgConfigureScriptArgs-    configExtraLibDirs        = pkgExtraLibDirs-    configExtraFrameworkDirs  = pkgExtraFrameworkDirs-    configExtraIncludeDirs    = pkgExtraIncludeDirs-    configProgPrefix          = maybe mempty toFlag pkgProgPrefix-    configProgSuffix          = maybe mempty toFlag pkgProgSuffix--    configInstallDirs         = fmap (toFlag . InstallDirs.toPathTemplate)-                                     pkgInstallDirs--    -- we only use configDependencies, unless we're talking to an old Cabal-    -- in which case we use configConstraints-    configDependencies        = [ (packageName srcid, uid)-                                | ConfiguredId srcid uid <- CD.nonSetupDeps pkgDependencies ]-    configConstraints         = [ thisPackageVersion srcid-                                | ConfiguredId srcid _uid <- CD.nonSetupDeps pkgDependencies ]--    -- explicitly clear, then our package db stack-    -- TODO: [required eventually] have to do this differently for older Cabal versions-    configPackageDBs          = Nothing : map Just pkgBuildPackageDBStack--    configTests               = toFlag (TestStanzas  `Set.member` pkgStanzasEnabled)-    configBenchmarks          = toFlag (BenchStanzas `Set.member` pkgStanzasEnabled)--    configExactConfiguration  = toFlag True-    configFlagError           = mempty --TODO: [research required] appears not to be implemented-    configRelocatable         = mempty --TODO: [research required] ???-    configScratchDir          = mempty -- never use-    configUserInstall         = mempty -- don't rely on defaults-    configPrograms_           = mempty -- never use, shouldn't exist--    programDbProgramPaths db =-      [ (programId prog, programPath prog)-      | prog <- configuredPrograms db ]--    programDbProgramArgs db =-      [ (programId prog, programOverrideArgs prog)-      | prog <- configuredPrograms db ]--    programDbPathExtra db =-      case getProgramSearchPath db of-        ProgramSearchPathDefault : extra ->-          toNubList [ dir | ProgramSearchPathDir dir <- extra ]-        _ -> error $ "setupHsConfigureFlags: we cannot currently cope with a "-                  ++ "search path that does not start with the system path"-                  -- the Setup.hs interface only has --extra-prog-path-                  -- so we cannot put things before the $PATH, only after---setupHsBuildFlags :: ElaboratedConfiguredPackage-                  -> ElaboratedSharedConfig-                  -> Verbosity-                  -> FilePath-                  -> Cabal.BuildFlags-setupHsBuildFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =-    Cabal.BuildFlags {-      buildProgramPaths = mempty, --unused, set at configure time-      buildProgramArgs  = mempty, --unused, set at configure time-      buildVerbosity    = toFlag verbosity,-      buildDistPref     = toFlag builddir,-      buildNumJobs      = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),-      buildArgs         = mempty  -- unused, passed via args not flags-    }---setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]-setupHsBuildArgs pkg =-    map (showComponentTarget pkg) (pkgBuildTargets pkg)---showComponentTarget :: ElaboratedConfiguredPackage -> ComponentTarget -> String-showComponentTarget _pkg =-    showBuildTarget . toBuildTarget-  where-    showBuildTarget t =-      Cabal.showBuildTarget (qlBuildTarget t) t--    qlBuildTarget Cabal.BuildTargetComponent{} = Cabal.QL2-    qlBuildTarget _                            = Cabal.QL3--    toBuildTarget :: ComponentTarget -> Cabal.BuildTarget-    toBuildTarget (ComponentTarget cname subtarget) =-      case subtarget of-        WholeComponent     -> Cabal.BuildTargetComponent cname-        ModuleTarget mname -> Cabal.BuildTargetModule    cname mname-        FileTarget   fname -> Cabal.BuildTargetFile      cname fname---setupHsReplFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.ReplFlags-setupHsReplFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =-    Cabal.ReplFlags {-      replProgramPaths = mempty, --unused, set at configure time-      replProgramArgs  = mempty, --unused, set at configure time-      replVerbosity    = toFlag verbosity,-      replDistPref     = toFlag builddir,-      replReload       = mempty  --only used as callback from repl-    }---setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]-setupHsReplArgs pkg =-    maybe [] (\t -> [showComponentTarget pkg t]) (pkgReplTarget pkg)-    --TODO: should be able to give multiple modules in one component---setupHsCopyFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.CopyFlags-setupHsCopyFlags _ _ verbosity builddir =-    Cabal.CopyFlags {-      --TODO: [nice to have] we currently just rely on Setup.hs copy to always do the right-      -- thing, but perhaps we ought really to copy into an image dir and do-      -- some sanity checks and move into the final location ourselves-      copyArgs      = [], -- TODO: could use this to only copy what we enabled-      copyDest      = toFlag InstallDirs.NoCopyDest,-      copyDistPref  = toFlag builddir,-      copyVerbosity = toFlag verbosity-    }--setupHsRegisterFlags :: ElaboratedConfiguredPackage-                     -> ElaboratedSharedConfig-                     -> Verbosity-                     -> FilePath-                     -> FilePath-                     -> Cabal.RegisterFlags-setupHsRegisterFlags ElaboratedConfiguredPackage {pkgBuildStyle} _-                     verbosity builddir pkgConfFile =-    Cabal.RegisterFlags {-      regPackageDB   = mempty,  -- misfeature-      regGenScript   = mempty,  -- never use-      regGenPkgConf  = toFlag (Just pkgConfFile),-      regInPlace     = case pkgBuildStyle of-                         BuildInplaceOnly -> toFlag True-                         _                -> toFlag False,-      regPrintId     = mempty,  -- never use-      regDistPref    = toFlag builddir,-      regVerbosity   = toFlag verbosity-    }--setupHsHaddockFlags :: ElaboratedConfiguredPackage-                    -> ElaboratedSharedConfig-                    -> Verbosity-                    -> FilePath-                    -> Cabal.HaddockFlags-setupHsHaddockFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =-    Cabal.HaddockFlags {-      haddockProgramPaths  = mempty, --unused, set at configure time-      haddockProgramArgs   = mempty, --unused, set at configure time-      haddockHoogle        = toFlag pkgHaddockHoogle,-      haddockHtml          = toFlag pkgHaddockHtml,-      haddockHtmlLocation  = maybe mempty toFlag pkgHaddockHtmlLocation,-      haddockForHackage    = mempty, --TODO: new flag-      haddockExecutables   = toFlag pkgHaddockExecutables,-      haddockTestSuites    = toFlag pkgHaddockTestSuites,-      haddockBenchmarks    = toFlag pkgHaddockBenchmarks,-      haddockInternal      = toFlag pkgHaddockInternal,-      haddockCss           = maybe mempty toFlag pkgHaddockCss,-      haddockHscolour      = toFlag pkgHaddockHscolour,-      haddockHscolourCss   = maybe mempty toFlag pkgHaddockHscolourCss,-      haddockContents      = maybe mempty toFlag pkgHaddockContents,-      haddockDistPref      = toFlag builddir,-      haddockKeepTempFiles = mempty, --TODO: from build settings-      haddockVerbosity     = toFlag verbosity-    }--{--setupHsTestFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.TestFlags-setupHsTestFlags _ _ verbosity builddir =-    Cabal.TestFlags {-    }--}----------------------------------------------------------------------------------- * Sharing installed packages-------------------------------------------------------------------------------------- Nix style store management for tarball packages------ So here's our strategy:------ We use a per-user nix-style hashed store, but /only/ for tarball packages.--- So that includes packages from hackage repos (and other http and local--- tarballs). For packages in local directories we do not register them into--- the shared store by default, we just build them locally inplace.------ The reason we do it like this is that it's easy to make stable hashes for--- tarball packages, and these packages benefit most from sharing. By contrast--- unpacked dir packages are harder to hash and they tend to change more--- frequently so there's less benefit to sharing them.------ When using the nix store approach we have to run the solver *without*--- looking at the packages installed in the store, just at the source packages--- (plus core\/global installed packages). Then we do a post-processing pass--- to replace configured packages in the plan with pre-existing ones, where--- possible. Where possible of course means where the nix-style package hash--- equals one that's already in the store.------ One extra wrinkle is that unless we know package tarball hashes upfront, we--- will have to download the tarballs to find their hashes. So we have two--- options: delay replacing source with pre-existing installed packages until--- the point during the execution of the install plan where we have the--- tarball, or try to do as much up-front as possible and then check again--- during plan execution. The former isn't great because we would end up--- telling users we're going to re-install loads of packages when in fact we--- would just share them. It'd be better to give as accurate a prediction as--- we can. The latter is better for users, but we do still have to check--- during plan execution because it's important that we don't replace existing--- installed packages even if they have the same package hash, because we--- don't guarantee ABI stability.---- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but--- not replace installed packages with ghc-pkg.--packageHashInputs :: ElaboratedSharedConfig-                  -> ElaboratedConfiguredPackage-                  -> PackageHashInputs-packageHashInputs-    pkgshared-    pkg@ElaboratedConfiguredPackage{-      pkgSourceId,-      pkgSourceHash = Just srchash,-      pkgDependencies-    } =-    PackageHashInputs {-      pkgHashPkgId       = pkgSourceId,-      pkgHashSourceHash  = srchash,-      pkgHashDirectDeps  = Set.fromList-                             [ installedPackageId dep-                             | dep <- CD.select relevantDeps pkgDependencies ],-      pkgHashOtherConfig = packageHashConfigInputs pkgshared pkg-    }-  where-    -- Obviously the main deps are relevant-    relevantDeps (CD.ComponentLib _)   = True-    relevantDeps (CD.ComponentExe _)   = True-    -- Setup deps can affect the Setup.hs behaviour and thus what is built-    relevantDeps  CD.ComponentSetup    = True-    -- However testsuites and benchmarks do not get installed and should not-    -- affect the result, so we do not include them.-    relevantDeps (CD.ComponentTest  _) = False-    relevantDeps (CD.ComponentBench _) = False--packageHashInputs _ pkg =-    error $ "packageHashInputs: only for packages with source hashes. "-         ++ display (packageId pkg)--packageHashConfigInputs :: ElaboratedSharedConfig-                        -> ElaboratedConfiguredPackage-                        -> PackageHashConfigInputs-packageHashConfigInputs-    ElaboratedSharedConfig{..}-    ElaboratedConfiguredPackage{..} =--    PackageHashConfigInputs {-      pkgHashCompilerId          = compilerId pkgConfigCompiler,-      pkgHashPlatform            = pkgConfigPlatform,-      pkgHashFlagAssignment      = pkgFlagAssignment,-      pkgHashConfigureScriptArgs = pkgConfigureScriptArgs,-      pkgHashVanillaLib          = pkgVanillaLib,-      pkgHashSharedLib           = pkgSharedLib,-      pkgHashDynExe              = pkgDynExe,-      pkgHashGHCiLib             = pkgGHCiLib,-      pkgHashProfLib             = pkgProfLib,-      pkgHashProfExe             = pkgProfExe,-      pkgHashProfLibDetail       = pkgProfLibDetail,-      pkgHashProfExeDetail       = pkgProfExeDetail,-      pkgHashCoverage            = pkgCoverage,-      pkgHashOptimization        = pkgOptimization,-      pkgHashSplitObjs           = pkgSplitObjs,-      pkgHashStripLibs           = pkgStripLibs,-      pkgHashStripExes           = pkgStripExes,-      pkgHashDebugInfo           = pkgDebugInfo,-      pkgHashExtraLibDirs        = pkgExtraLibDirs,-      pkgHashExtraFrameworkDirs  = pkgExtraFrameworkDirs,-      pkgHashExtraIncludeDirs    = pkgExtraIncludeDirs,-      pkgHashProgPrefix          = pkgProgPrefix,-      pkgHashProgSuffix          = pkgProgSuffix-    }----- | Given the 'InstalledPackageIndex' for a nix-style package store, and an--- 'ElaboratedInstallPlan', replace configured source packages by pre-existing--- installed packages whenever they exist.----improveInstallPlanWithPreExistingPackages :: InstalledPackageIndex-                                          -> ElaboratedInstallPlan-                                          -> ElaboratedInstallPlan-improveInstallPlanWithPreExistingPackages installedPkgIndex installPlan =-    replaceWithPreExisting installPlan-      [ ipkg-      | InstallPlan.Configured pkg-          <- InstallPlan.reverseTopologicalOrder installPlan-      , ipkg <- maybeToList (canPackageBeImproved pkg) ]-  where-    --TODO: sanity checks:-    -- * the installed package must have the expected deps etc-    -- * the installed package must not be broken, valid dep closure--    --TODO: decide what to do if we encounter broken installed packages,-    -- since overwriting is never safe.--    canPackageBeImproved pkg =-      PackageIndex.lookupUnitId-        installedPkgIndex (installedPackageId pkg)--    replaceWithPreExisting =-      foldl' (\plan ipkg -> InstallPlan.preexisting-                              (installedPackageId ipkg) ipkg plan)+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Planning how to build everything in a project.+--+module Distribution.Client.ProjectPlanning (+    -- * elaborated install plan types+    ElaboratedInstallPlan,+    ElaboratedConfiguredPackage(..),+    ElaboratedPlanPackage,+    ElaboratedSharedConfig(..),+    ElaboratedReadyPackage,+    BuildStyle(..),+    CabalFileText,++    -- * Producing the elaborated install plan+    rebuildInstallPlan,++    -- * Build targets+    PackageTarget(..),+    ComponentTarget(..),+    SubComponentTarget(..),+    showComponentTarget,++    -- * Selecting a plan subset+    pruneInstallPlanToTargets,+    pruneInstallPlanToDependencies,++    -- * Utils required for building+    pkgHasEphemeralBuildTargets,+    elabBuildTargetWholeComponents,++    -- * Setup.hs CLI flags for building+    setupHsScriptOptions,+    setupHsConfigureFlags,+    setupHsConfigureArgs,+    setupHsBuildFlags,+    setupHsBuildArgs,+    setupHsReplFlags,+    setupHsReplArgs,+    setupHsCopyFlags,+    setupHsRegisterFlags,+    setupHsHaddockFlags,++    packageHashInputs,++    -- TODO: [code cleanup] utils that should live in some shared place?+    createPackageDBIfMissing+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import           Distribution.Client.ProjectPlanning.Types+import           Distribution.Client.PackageHash+import           Distribution.Client.RebuildMonad+import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectPlanOutput++import           Distribution.Client.Types+import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import           Distribution.Client.Dependency+import           Distribution.Client.Dependency.Types+import qualified Distribution.Client.IndexUtils as IndexUtils+import           Distribution.Client.Targets (userToPackageConstraint)+import           Distribution.Client.DistDirLayout+import           Distribution.Client.SetupWrapper+import           Distribution.Client.JobControl+import           Distribution.Client.FetchUtils+import qualified Hackage.Security.Client as Sec+import           Distribution.Client.Setup hiding (packageName, cabalVersion)+import           Distribution.Utils.NubList+import           Distribution.Utils.LogProgress+import           Distribution.Utils.Progress (failProgress)+import           Distribution.Utils.MapAccum++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PkgConfigDb+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.InstSolverPackage+import           Distribution.Solver.Types.SourcePackage+import           Distribution.Solver.Types.Settings++import           Distribution.ModuleName+import           Distribution.Package hiding+  (InstalledPackageId, installedPackageId)+import           Distribution.System+import qualified Distribution.PackageDescription as Cabal+import qualified Distribution.PackageDescription as PD+import qualified Distribution.PackageDescription.Configuration as PD+import           Distribution.Simple.PackageIndex (InstalledPackageIndex)+import           Distribution.Simple.Compiler hiding (Flag)+import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate+import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate+import           Distribution.Simple.Program+import           Distribution.Simple.Program.Db+import           Distribution.Simple.Program.Find+import qualified Distribution.Simple.Setup as Cabal+import           Distribution.Simple.Setup+  (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault)+import qualified Distribution.Simple.Configure as Cabal+import qualified Distribution.Simple.LocalBuildInfo as Cabal+import           Distribution.Simple.LocalBuildInfo (ComponentName(..))+import qualified Distribution.Simple.Register as Cabal+import qualified Distribution.Simple.InstallDirs as InstallDirs+import qualified Distribution.InstalledPackageInfo as IPI++import           Distribution.Backpack.ConfiguredComponent+import           Distribution.Backpack.LinkedComponent+import           Distribution.Backpack.ComponentsGraph+import           Distribution.Backpack.ModuleShape+import           Distribution.Backpack.FullUnitId+import           Distribution.Backpack++import           Distribution.Simple.Utils hiding (matchFileGlob)+import           Distribution.Version+import           Distribution.Verbosity+import           Distribution.Text++import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph(IsNode(..))++import           Text.PrettyPrint hiding ((<>))+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import           Control.Monad+import qualified Data.Traversable as T+import           Control.Monad.State as State+import           Control.Exception+import           Data.List (groupBy)+import           Data.Either+import           Data.Function+import           System.FilePath++------------------------------------------------------------------------------+-- * Elaborated install plan+------------------------------------------------------------------------------++-- "Elaborated" -- worked out with great care and nicety of detail;+--                 executed with great minuteness: elaborate preparations;+--                 elaborate care.+--+-- So here's the idea:+--+-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc+-- all passed in as separate args and which are then further selected,+-- transformed etc during the execution of the build. Instead we construct+-- an elaborated install plan that includes everything we will need, and then+-- during the execution of the plan we do as little transformation of this+-- info as possible.+--+-- So we're trying to split the work into two phases: construction of the+-- elaborated install plan (which as far as possible should be pure) and+-- then simple execution of that plan without any smarts, just doing what the+-- plan says to do.+--+-- So that means we need a representation of this fully elaborated install+-- plan. The representation consists of two parts:+--+-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a+--   representation of source packages that includes a lot more detail about+--   that package's individual configuration+--+-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for+--   every package in a plan. Rather than duplicate that info every entry in+--   the 'GenericInstallPlan' we keep that separately.+--+-- The division between the shared and per-package config is /not set in stone+-- for all time/. For example if we wanted to generalise the install plan to+-- describe a situation where we want to build some packages with GHC and some+-- with GHCJS then the platform and compiler would no longer be shared between+-- all packages but would have to be per-package (probably with some sanity+-- condition on the graph structure).+--++-- Refer to ProjectPlanning.Types for details of these important types:++-- type ElaboratedInstallPlan = ...+-- type ElaboratedPlanPackage = ...+-- data ElaboratedSharedConfig = ...+-- data ElaboratedConfiguredPackage = ...+-- data BuildStyle =+++-- | Check that an 'ElaboratedConfiguredPackage' actually makes+-- sense under some 'ElaboratedSharedConfig'.+sanityCheckElaboratedConfiguredPackage+    :: ElaboratedSharedConfig+    -> ElaboratedConfiguredPackage+    -> a+    -> a+sanityCheckElaboratedConfiguredPackage sharedConfig+                             elab@ElaboratedConfiguredPackage{..} =+    (case elabPkgOrComp of+        ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg+        ElabComponent comp -> sanityCheckElaboratedComponent elab comp)++    -- either a package is being built inplace, or the+    -- 'installedPackageId' we assigned is consistent with+    -- the 'hashedInstalledPackageId' we would compute from+    -- the elaborated configured package+  . assert (elabBuildStyle == BuildInplaceOnly ||+     elabComponentId == hashedInstalledPackageId+                            (packageHashInputs sharedConfig elab))++    -- the stanzas explicitly disabled should not be available+  . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested)+                `Set.intersection` elabStanzasAvailable))++    -- either a package is built inplace, or we are not attempting to+    -- build any test suites or benchmarks (we never build these+    -- for remote packages!)+  . assert (elabBuildStyle == BuildInplaceOnly ||+     Set.null elabStanzasAvailable)++sanityCheckElaboratedComponent+    :: ElaboratedConfiguredPackage+    -> ElaboratedComponent+    -> a+    -> a+sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..}+                               ElaboratedComponent{..} =++    -- Should not be building bench or test if not inplace.+    assert (elabBuildStyle == BuildInplaceOnly ||+     case compComponentName of+        Nothing              -> True+        Just CLibName        -> True+        Just (CSubLibName _) -> True+        Just (CExeName _)    -> True+        -- This is interesting: there's no way to declare a dependency+        -- on a foreign library at the moment, but you may still want+        -- to install these to the store+        Just (CFLibName _)   -> True+        Just (CBenchName _)  -> False+        Just (CTestName _)   -> False)+++sanityCheckElaboratedPackage+    :: ElaboratedConfiguredPackage+    -> ElaboratedPackage+    -> a+    -> a+sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..}+                             ElaboratedPackage{..} =+    -- we should only have enabled stanzas that actually can be built+    -- (according to the solver)+    assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable)++    -- the stanzas that the user explicitly requested should be+    -- enabled (by the previous test, they are also available)+  . assert (Map.keysSet (Map.filter id elabStanzasRequested)+                `Set.isSubsetOf` pkgStanzasEnabled)++------------------------------------------------------------------------------+-- * Deciding what to do: making an 'ElaboratedInstallPlan'+------------------------------------------------------------------------------++-- | Return an up-to-date elaborated install plan and associated config.+--+-- Two variants of the install plan are returned: with and without packages+-- from the store. That is, the \"improved\" plan where source packages are+-- replaced by pre-existing installed packages from the store (when their ids+-- match), and also the original elaborated plan which uses primarily source+-- packages.++-- The improved plan is what we use for building, but the original elaborated+-- plan is useful for reporting and configuration. For example the @freeze@+-- command needs the source package info to know about flag choices and+-- dependencies of executables and setup scripts.+--+rebuildInstallPlan :: Verbosity+                   -> FilePath -> DistDirLayout -> CabalDirLayout+                   -> ProjectConfig+                   -> IO ( ElaboratedInstallPlan  -- with store packages+                         , ElaboratedInstallPlan  -- with source packages+                         , ElaboratedSharedConfig+                         , ProjectConfig )+                      -- ^ @(improvedPlan, elaboratedPlan, _, _)@+rebuildInstallPlan verbosity+                   projectRootDir+                   distDirLayout@DistDirLayout {+                     distDirectory,+                     distProjectCacheFile,+                     distProjectCacheDirectory+                   }+                   cabalDirLayout@CabalDirLayout {+                     cabalStoreDirectory,+                     cabalStorePackageDB+                   }+                   cliConfig =+    runRebuild projectRootDir $ do+    progsearchpath <- liftIO $ getSystemSearchPath+    let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty }++    -- The overall improved plan is cached+    rerunIfChanged verbosity fileMonitorImprovedPlan+                   -- react to changes in command line args and the path+                   (cliConfigPersistent, progsearchpath) $ do++      -- And so is the elaborated plan that the improved plan based on+      (elaboratedPlan, elaboratedShared,+       projectConfig) <-+        rerunIfChanged verbosity fileMonitorElaboratedPlan+                       (cliConfigPersistent, progsearchpath) $ do++          (projectConfig, projectConfigTransient) <- phaseReadProjectConfig+          localPackages <- phaseReadLocalPackages projectConfig+          compilerEtc   <- phaseConfigureCompiler projectConfig+          _             <- phaseConfigurePrograms projectConfig compilerEtc+          (solverPlan, pkgConfigDB)+                        <- phaseRunSolver         projectConfigTransient+                                                  compilerEtc+                                                  localPackages+          (elaboratedPlan,+           elaboratedShared) <- phaseElaboratePlan projectConfigTransient+                                                   compilerEtc pkgConfigDB+                                                   solverPlan+                                                   localPackages++          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared+          let instantiatedPlan = phaseInstantiatePlan elaboratedPlan+          liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)++          return (instantiatedPlan, elaboratedShared, projectConfig)++      -- The improved plan changes each time we install something, whereas+      -- the underlying elaborated plan only changes when input config+      -- changes, so it's worth caching them separately.+      improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared++      return (improvedPlan, elaboratedPlan, elaboratedShared, projectConfig)++  where+    fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"+    fileMonitorSolverPlan     = newFileMonitorInCacheDir "solver-plan"+    fileMonitorSourceHashes   = newFileMonitorInCacheDir "source-hashes"+    fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"+    fileMonitorImprovedPlan   = newFileMonitorInCacheDir "improved-plan"++    newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b+    newFileMonitorInCacheDir  = newFileMonitor . distProjectCacheFile++    -- Read the cabal.project (or implicit config) and combine it with+    -- arguments from the command line+    --+    phaseReadProjectConfig :: Rebuild (ProjectConfig, ProjectConfig)+    phaseReadProjectConfig = do+      liftIO $ do+        info verbosity "Project settings changed, reconfiguring..."+        createDirectoryIfMissingVerbose verbosity True distDirectory+        createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory++      projectConfig <- readProjectConfig verbosity projectRootDir++      -- The project config comming from the command line includes "build only"+      -- flags that we don't cache persistently (because like all "build only"+      -- flags they do not affect the value of the outcome) but that we do+      -- sometimes using during planning (in particular the http transport)+      let projectConfigTransient  = projectConfig <> cliConfig+          projectConfigPersistent = projectConfig+                                 <> cliConfig {+                                      projectConfigBuildOnly = mempty+                                    }+      liftIO $ writeProjectConfigFile (distProjectCacheFile "config")+                                      projectConfigPersistent+      return (projectConfigPersistent, projectConfigTransient)++    -- Look for all the cabal packages in the project+    -- some of which may be local src dirs, tarballs etc+    --+    phaseReadLocalPackages :: ProjectConfig+                           -> Rebuild [UnresolvedSourcePackage]+    phaseReadLocalPackages projectConfig = do++      localCabalFiles <- findProjectPackages projectRootDir projectConfig+      mapM (readSourcePackage verbosity) localCabalFiles+++    -- Configure the compiler we're using.+    --+    -- This is moderately expensive and doesn't change that often so we cache+    -- it independently.+    --+    phaseConfigureCompiler :: ProjectConfig+                           -> Rebuild (Compiler, Platform, ProgramDb)+    phaseConfigureCompiler ProjectConfig {+                             projectConfigShared = ProjectConfigShared {+                               projectConfigHcFlavor,+                               projectConfigHcPath,+                               projectConfigHcPkg+                             },+                             projectConfigLocalPackages = PackageConfig {+                               packageConfigProgramPaths,+                               packageConfigProgramArgs,+                               packageConfigProgramPathExtra+                             }+                           } = do+        progsearchpath <- liftIO $ getSystemSearchPath+        rerunIfChanged verbosity fileMonitorCompiler+                       (hcFlavor, hcPath, hcPkg, progsearchpath,+                        packageConfigProgramPaths,+                        packageConfigProgramArgs,+                        packageConfigProgramPathExtra) $ do++          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."+          result@(_, _, progdb') <- liftIO $+            Cabal.configCompilerEx+              hcFlavor hcPath hcPkg+              progdb verbosity++        -- Note that we added the user-supplied program locations and args+        -- for /all/ programs, not just those for the compiler prog and+        -- compiler-related utils. In principle we don't know which programs+        -- the compiler will configure (and it does vary between compilers).+        -- We do know however that the compiler will only configure the+        -- programs it cares about, and those are the ones we monitor here.+          monitorFiles (programsMonitorFiles progdb')++          return result+      where+        hcFlavor = flagToMaybe projectConfigHcFlavor+        hcPath   = flagToMaybe projectConfigHcPath+        hcPkg    = flagToMaybe projectConfigHcPkg+        progdb   =+            userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))+          . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))+          . modifyProgramSearchPath+              (++ [ ProgramSearchPathDir dir+                  | dir <- fromNubList packageConfigProgramPathExtra ])+          $ defaultProgramDb+++    -- Configuring other programs.+    --+    -- Having configred the compiler, now we configure all the remaining+    -- programs. This is to check we can find them, and to monitor them for+    -- changes.+    --+    -- TODO: [required eventually] we don't actually do this yet.+    --+    -- We rely on the fact that the previous phase added the program config for+    -- all local packages, but that all the programs configured so far are the+    -- compiler program or related util programs.+    --+    phaseConfigurePrograms :: ProjectConfig+                           -> (Compiler, Platform, ProgramDb)+                           -> Rebuild ()+    phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do+        -- Users are allowed to specify program locations independently for+        -- each package (e.g. to use a particular version of a pre-processor+        -- for some packages). However they cannot do this for the compiler+        -- itself as that's just not going to work. So we check for this.+        liftIO $ checkBadPerPackageCompilerPaths+          (configuredPrograms compilerprogdb)+          (getMapMappend (projectConfigSpecificPackage projectConfig))++        --TODO: [required eventually] find/configure other programs that the+        -- user specifies.++        --TODO: [required eventually] find/configure all build-tools+        -- but note that some of them may be built as part of the plan.+++    -- Run the solver to get the initial install plan.+    -- This is expensive so we cache it independently.+    --+    phaseRunSolver :: ProjectConfig+                   -> (Compiler, Platform, ProgramDb)+                   -> [UnresolvedSourcePackage]+                   -> Rebuild (SolverInstallPlan, PkgConfigDb)+    phaseRunSolver projectConfig@ProjectConfig {+                     projectConfigShared,+                     projectConfigBuildOnly+                   }+                   (compiler, platform, progdb)+                   localPackages =+        rerunIfChanged verbosity fileMonitorSolverPlan+                       (solverSettings,+                        localPackages, localPackagesEnabledStanzas,+                        compiler, platform, programDbSignature progdb) $ do++          installedPkgIndex <- getInstalledPackages verbosity+                                                    compiler progdb platform+                                                    corePackageDbs+          sourcePkgDb       <- getSourcePackages verbosity withRepoCtx+                                 (solverSettingIndexState solverSettings)+          pkgConfigDB       <- getPkgConfigDb verbosity progdb++          --TODO: [code cleanup] it'd be better if the Compiler contained the+          -- ConfiguredPrograms that it needs, rather than relying on the progdb+          -- since we don't need to depend on all the programs here, just the+          -- ones relevant for the compiler.++          liftIO $ do+            solver <- chooseSolver verbosity+                                   (solverSettingSolver solverSettings)+                                   (compilerInfo compiler)++            notice verbosity "Resolving dependencies..."+            plan <- foldProgress logMsg die return $+              planPackages compiler platform solver solverSettings+                           installedPkgIndex sourcePkgDb pkgConfigDB+                           localPackages localPackagesEnabledStanzas+            return (plan, pkgConfigDB)+      where+        corePackageDbs = [GlobalPackageDB]+        withRepoCtx    = projectConfigWithSolverRepoContext verbosity+                           projectConfigShared+                           projectConfigBuildOnly+        solverSettings = resolveSolverSettings projectConfig+        logMsg message rest = debugNoWrap verbosity message >> rest++        localPackagesEnabledStanzas =+          Map.fromList+            [ (pkgname, stanzas)+            | pkg <- localPackages+            , let pkgname            = packageName pkg+                  testsEnabled       = lookupLocalPackageConfig+                                         packageConfigTests+                                         projectConfig pkgname+                  benchmarksEnabled  = lookupLocalPackageConfig+                                         packageConfigBenchmarks+                                         projectConfig pkgname+                  stanzas =+                    Map.fromList $+                      [ (TestStanzas, enabled)+                      | enabled <- flagToList testsEnabled ]+                   ++ [ (BenchStanzas , enabled)+                      | enabled <- flagToList benchmarksEnabled ]+            ]++    -- Elaborate the solver's install plan to get a fully detailed plan. This+    -- version of the plan has the final nix-style hashed ids.+    --+    phaseElaboratePlan :: ProjectConfig+                       -> (Compiler, Platform, ProgramDb)+                       -> PkgConfigDb+                       -> SolverInstallPlan+                       -> [SourcePackage loc]+                       -> Rebuild ( ElaboratedInstallPlan+                                  , ElaboratedSharedConfig )+    phaseElaboratePlan ProjectConfig {+                         projectConfigShared,+                         projectConfigLocalPackages,+                         projectConfigSpecificPackage,+                         projectConfigBuildOnly+                       }+                       (compiler, platform, progdb) pkgConfigDB+                       solverPlan localPackages = do++        liftIO $ debug verbosity "Elaborating the install plan..."++        sourcePackageHashes <-+          rerunIfChanged verbosity fileMonitorSourceHashes+                         (packageLocationsSignature solverPlan) $+            getPackageSourceHashes verbosity withRepoCtx solverPlan++        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler+        (elaboratedPlan, elaboratedShared)+          <- liftIO . runLogProgress verbosity $+              elaborateInstallPlan+                verbosity+                platform compiler progdb pkgConfigDB+                distDirLayout+                cabalDirLayout+                solverPlan+                localPackages+                sourcePackageHashes+                defaultInstallDirs+                projectConfigShared+                projectConfigLocalPackages+                (getMapMappend projectConfigSpecificPackage)+        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan)+        return (elaboratedPlan, elaboratedShared)+      where+        withRepoCtx = projectConfigWithSolverRepoContext verbosity+                        projectConfigShared+                        projectConfigBuildOnly++    phaseInstantiatePlan :: ElaboratedInstallPlan+                         -> ElaboratedInstallPlan+    phaseInstantiatePlan plan = instantiateInstallPlan plan++    -- Update the files we maintain that reflect our current build environment.+    -- In particular we maintain a JSON representation of the elaborated+    -- install plan (but not the improved plan since that reflects the state+    -- of the build rather than just the input environment).+    --+    phaseMaintainPlanOutputs :: ElaboratedInstallPlan+                             -> ElaboratedSharedConfig+                             -> Rebuild ()+    phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do+        debug verbosity "Updating plan.json"+        writePlanExternalRepresentation+          distDirLayout+          elaboratedPlan+          elaboratedShared+++    -- Improve the elaborated install plan. The elaborated plan consists+    -- mostly of source packages (with full nix-style hashed ids). Where+    -- corresponding installed packages already exist in the store, replace+    -- them in the plan.+    --+    -- Note that we do monitor the store's package db here, so we will redo+    -- this improvement phase when the db changes -- including as a result of+    -- executing a plan and installing things.+    --+    phaseImprovePlan :: ElaboratedInstallPlan+                     -> ElaboratedSharedConfig+                     -> Rebuild ElaboratedInstallPlan+    phaseImprovePlan elaboratedPlan elaboratedShared = do++        liftIO $ debug verbosity "Improving the install plan..."+        createDirectoryMonitored True storeDirectory+        liftIO $ createPackageDBIfMissing verbosity+                                          compiler progdb+                                          storePackageDb+        storePkgIdSet <- getInstalledStorePackages storeDirectory+        let improvedPlan = improveInstallPlanWithInstalledPackages+                             storePkgIdSet+                             elaboratedPlan+        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)+        -- TODO: [nice to have] having checked which packages from the store+        -- we're using, it may be sensible to sanity check those packages+        -- by loading up the compiler package db and checking everything+        -- matches up as expected, e.g. no dangling deps, files deleted.+        return improvedPlan+      where+        storeDirectory  = cabalStoreDirectory (compilerId compiler)+        storePackageDb  = cabalStorePackageDB (compilerId compiler)+        ElaboratedSharedConfig {+          pkgConfigCompiler      = compiler,+          pkgConfigCompilerProgs = progdb+        } = elaboratedShared+++programsMonitorFiles :: ProgramDb -> [MonitorFilePath]+programsMonitorFiles progdb =+    [ monitor+    | prog    <- configuredPrograms progdb+    , monitor <- monitorFileSearchPath (programMonitorFiles prog)+                                       (programPath prog)+    ]++-- | Select the bits of a 'ProgramDb' to monitor for value changes.+-- Use 'programsMonitorFiles' for the files to monitor.+--+programDbSignature :: ProgramDb -> [ConfiguredProgram]+programDbSignature progdb =+    [ prog { programMonitorFiles = []+           , programOverrideEnv  = filter ((/="PATH") . fst)+                                          (programOverrideEnv prog) }+    | prog <- configuredPrograms progdb ]++getInstalledPackages :: Verbosity+                     -> Compiler -> ProgramDb -> Platform+                     -> PackageDBStack+                     -> Rebuild InstalledPackageIndex+getInstalledPackages verbosity compiler progdb platform packagedbs = do+    monitorFiles . map monitorFileOrDirectory+      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles+                    verbosity compiler+                    packagedbs progdb platform)+    liftIO $ IndexUtils.getInstalledPackages+               verbosity compiler+               packagedbs progdb++{-+--TODO: [nice to have] use this but for sanity / consistency checking+getPackageDBContents :: Verbosity+                     -> Compiler -> ProgramDb -> Platform+                     -> PackageDB+                     -> Rebuild InstalledPackageIndex+getPackageDBContents verbosity compiler progdb platform packagedb = do+    monitorFiles . map monitorFileOrDirectory+      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles+                    verbosity compiler+                    [packagedb] progdb platform)+    liftIO $ do+      createPackageDBIfMissing verbosity compiler progdb packagedb+      Cabal.getPackageDBContents verbosity compiler+                                 packagedb progdb+-}++-- | Return the 'UnitId's of all packages\/components already installed in the+-- store.+--+getInstalledStorePackages :: FilePath -- ^ store directory+                          -> Rebuild (Set UnitId)+getInstalledStorePackages storeDirectory = do+    paths <- getDirectoryContentsMonitored storeDirectory+    return $ Set.fromList [ newSimpleUnitId (mkComponentId path)+                          | path <- paths, valid path ]+  where+    valid ('.':_)      = False+    valid "package.db" = False+    valid _            = True++getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)+                  -> IndexUtils.IndexState -> Rebuild SourcePackageDb+getSourcePackages verbosity withRepoCtx idxState = do+    (sourcePkgDb, repos) <-+      liftIO $+        withRepoCtx $ \repoctx -> do+          sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity+                                                                  repoctx idxState+          return (sourcePkgDb, repoContextRepos repoctx)++    monitorFiles . map monitorFile+                 . IndexUtils.getSourcePackagesMonitorFiles+                 $ repos+    return sourcePkgDb+++-- | Create a package DB if it does not currently exist. Note that this action+-- is /not/ safe to run concurrently.+--+createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb+                         -> PackageDB -> IO ()+createPackageDBIfMissing verbosity compiler progdb+                         (SpecificPackageDB dbPath) = do+    exists <- liftIO $ Cabal.doesPackageDBExist dbPath+    unless exists $ do+      createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)+      Cabal.createPackageDB verbosity compiler progdb False dbPath+createPackageDBIfMissing _ _ _ _ = return ()+++getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb+getPkgConfigDb verbosity progdb = do+    dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb+    -- Just monitor the dirs so we'll notice new .pc files.+    -- Alternatively we could monitor all the .pc files too.+    mapM_ monitorDirectoryStatus dirs+    liftIO $ readPkgConfigDb verbosity progdb+++-- | Select the config values to monitor for changes package source hashes.+packageLocationsSignature :: SolverInstallPlan+                          -> [(PackageId, PackageLocation (Maybe FilePath))]+packageLocationsSignature solverPlan =+    [ (packageId pkg, packageSource pkg)+    | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})+        <- SolverInstallPlan.toList solverPlan+    ]+++-- | Get the 'HashValue' for all the source packages where we use hashes,+-- and download any packages required to do so.+--+-- Note that we don't get hashes for local unpacked packages.+--+getPackageSourceHashes :: Verbosity+                       -> (forall a. (RepoContext -> IO a) -> IO a)+                       -> SolverInstallPlan+                       -> Rebuild (Map PackageId PackageSourceHash)+getPackageSourceHashes verbosity withRepoCtx solverPlan = do++    -- Determine if and where to get the package's source hash from.+    --+    let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]+        allPkgLocations =+          [ (packageId pkg, packageSource pkg)+          | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})+              <- SolverInstallPlan.toList solverPlan ]++        -- Tarballs that were local in the first place.+        -- We'll hash these tarball files directly.+        localTarballPkgs :: [(PackageId, FilePath)]+        localTarballPkgs =+          [ (pkgid, tarball)+          | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ]++        -- Tarballs from remote URLs. We must have downloaded these already+        -- (since we extracted the .cabal file earlier)+        --TODO: [required eventually] finish remote tarball functionality+--        allRemoteTarballPkgs =+--          [ (pkgid, )+--          | (pkgid, RemoteTarballPackage ) <- allPkgLocations ]++        -- Tarballs from repositories, either where the repository provides+        -- hashes as part of the repo metadata, or where we will have to+        -- download and hash the tarball.+        repoTarballPkgsWithMetadata    :: [(PackageId, Repo)]+        repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)]+        (repoTarballPkgsWithMetadata,+         repoTarballPkgsWithoutMetadata) =+          partitionEithers+          [ case repo of+              RepoSecure{} -> Left  (pkgid, repo)+              _            -> Right (pkgid, repo)+          | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ]++    -- For tarballs from repos that do not have hashes available we now have+    -- to check if the packages were downloaded already.+    --+    (repoTarballPkgsToDownload,+     repoTarballPkgsDownloaded)+      <- fmap partitionEithers $+         liftIO $ sequence+           [ do mtarball <- checkRepoTarballFetched repo pkgid+                case mtarball of+                  Nothing      -> return (Left  (pkgid, repo))+                  Just tarball -> return (Right (pkgid, tarball))+           | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ]++    (hashesFromRepoMetadata,+     repoTarballPkgsNewlyDownloaded) <-+      -- Avoid having to initialise the repository (ie 'withRepoCtx') if we+      -- don't have to. (The main cost is configuring the http client.)+      if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata+      then return (Map.empty, [])+      else liftIO $ withRepoCtx $ \repoctx -> do++      -- For tarballs from repos that do have hashes available as part of the+      -- repo metadata we now load up the index for each repo and retrieve+      -- the hashes for the packages+      --+      hashesFromRepoMetadata <-+        Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions+        fmap (Map.fromList . concat) $+        sequence+          -- Reading the repo index is expensive so we group the packages by repo+          [ repoContextWithSecureRepo repoctx repo $ \secureRepo ->+              Sec.withIndex secureRepo $ \repoIndex ->+                sequence+                  [ do hash <- Sec.trusted <$> -- strip off Trusted tag+                               Sec.indexLookupHash repoIndex pkgid+                       -- Note that hackage-security currently uses SHA256+                       -- but this API could in principle give us some other+                       -- choice in future.+                       return (pkgid, hashFromTUF hash)+                  | pkgid <- pkgids ]+          | (repo, pkgids) <-+                map (\grp@((_,repo):_) -> (repo, map fst grp))+              . groupBy ((==)    `on` (remoteRepoName . repoRemote . snd))+              . sortBy  (compare `on` (remoteRepoName . repoRemote . snd))+              $ repoTarballPkgsWithMetadata+          ]++      -- For tarballs from repos that do not have hashes available, download+      -- the ones we previously determined we need.+      --+      repoTarballPkgsNewlyDownloaded <-+        sequence+          [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid+               return (pkgid, tarball)+          | (pkgid, repo) <- repoTarballPkgsToDownload ]++      return (hashesFromRepoMetadata,+              repoTarballPkgsNewlyDownloaded)++    -- Hash tarball files for packages where we have to do that. This includes+    -- tarballs that were local in the first place, plus tarballs from repos,+    -- either previously cached or freshly downloaded.+    --+    let allTarballFilePkgs :: [(PackageId, FilePath)]+        allTarballFilePkgs = localTarballPkgs+                          ++ repoTarballPkgsDownloaded+                          ++ repoTarballPkgsNewlyDownloaded+    hashesFromTarballFiles <- liftIO $+      fmap Map.fromList $+      sequence+        [ do srchash <- readFileHashValue tarball+             return (pkgid, srchash)+        | (pkgid, tarball) <- allTarballFilePkgs+        ]+    monitorFiles [ monitorFile tarball+                 | (_pkgid, tarball) <- allTarballFilePkgs ]++    -- Return the combination+    return $! hashesFromRepoMetadata+           <> hashesFromTarballFiles+++-- ------------------------------------------------------------+-- * Installation planning+-- ------------------------------------------------------------++planPackages :: Compiler+             -> Platform+             -> Solver -> SolverSettings+             -> InstalledPackageIndex+             -> SourcePackageDb+             -> PkgConfigDb+             -> [UnresolvedSourcePackage]+             -> Map PackageName (Map OptionalStanza Bool)+             -> Progress String String SolverInstallPlan+planPackages comp platform solver SolverSettings{..}+             installedPkgIndex sourcePkgDb pkgConfigDB+             localPackages pkgStanzasEnable =++    resolveDependencies+      platform (compilerInfo comp)+      pkgConfigDB solver+      resolverParams++  where++    --TODO: [nice to have] disable multiple instances restriction in the solver, but then+    -- make sure we can cope with that in the output.+    resolverParams =++        setMaxBackjumps solverSettingMaxBackjumps++        --TODO: [required eventually] should only be configurable for custom installs+   -- . setIndependentGoals solverSettingIndependentGoals++      . setReorderGoals solverSettingReorderGoals++      . setCountConflicts solverSettingCountConflicts++        --TODO: [required eventually] should only be configurable for custom installs+   -- . setAvoidReinstalls solverSettingAvoidReinstalls++        --TODO: [required eventually] should only be configurable for custom installs+   -- . setShadowPkgs solverSettingShadowPkgs++      . setStrongFlags solverSettingStrongFlags++        --TODO: [required eventually] decide if we need to prefer installed for+        -- global packages, or prefer latest even for global packages. Perhaps+        -- should be configurable but with a different name than "upgrade-dependencies".+      . setPreferenceDefault PreferLatestForSelected+                           {-(if solverSettingUpgradeDeps+                                then PreferAllLatest+                                else PreferLatestForSelected)-}++      . removeLowerBounds solverSettingAllowOlder+      . removeUpperBounds solverSettingAllowNewer++      . addDefaultSetupDependencies (defaultSetupDeps comp platform+                                   . PD.packageDescription+                                   . packageDescription)++      . addPreferences+          -- preferences from the config file or command line+          [ PackageVersionPreference name ver+          | Dependency name ver <- solverSettingPreferences ]++      . addConstraints++          -- If a package has a custom setup then we need to add a setup-depends+          -- on Cabal. For now it's easier to add this unconditionally.  Once+          -- qualified constraints land we can turn this into a custom setup+          -- only constraint.+          --+          -- TODO: use a qualified constraint+            [ LabeledPackageConstraint (PackageConstraintVersion cabalPkgname+                                       (orLaterVersion (mkVersion [1,20])))+                                       ConstraintNewBuildCustomSetupLowerBoundCabal+                                       ] . addConstraints+          -- version constraints from the config file or command line+            [ LabeledPackageConstraint (userToPackageConstraint pc) src+            | (pc, src) <- solverSettingConstraints ]++      . addPreferences+          -- enable stanza preference where the user did not specify+          [ PackageStanzasPreference pkgname stanzas+          | pkg <- localPackages+          , let pkgname = packageName pkg+                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable+                stanzas = [ stanza | stanza <- [minBound..maxBound]+                          , Map.lookup stanza stanzaM == Nothing ]+          , not (null stanzas)+          ]++      . addConstraints+          -- enable stanza constraints where the user asked to enable+          [ LabeledPackageConstraint+              (PackageConstraintStanzas pkgname stanzas)+              ConstraintSourceConfigFlagOrTarget+          | pkg <- localPackages+          , let pkgname = packageName pkg+                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable+                stanzas = [ stanza | stanza <- [minBound..maxBound]+                          , Map.lookup stanza stanzaM == Just True ]+          , not (null stanzas)+          ]++      . addConstraints+          --TODO: [nice to have] should have checked at some point that the+          -- package in question actually has these flags.+          [ LabeledPackageConstraint+              (PackageConstraintFlags pkgname flags)+              ConstraintSourceConfigFlagOrTarget+          | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]++      . addConstraints+          --TODO: [nice to have] we have user-supplied flags for unspecified+          -- local packages (as well as specific per-package flags). For the+          -- former we just apply all these flags to all local targets which+          -- is silly. We should check if the flags are appropriate.+          [ LabeledPackageConstraint+              (PackageConstraintFlags pkgname flags)+              ConstraintSourceConfigFlagOrTarget+          | let flags = solverSettingFlagAssignment+          , not (null flags)+          , pkg <- localPackages+          , let pkgname = packageName pkg ]++      $ stdResolverParams++    stdResolverParams =+      -- Note: we don't use the standardInstallPolicy here, since that uses+      -- its own addDefaultSetupDependencies that is not appropriate for us.+      basicInstallPolicy+        installedPkgIndex sourcePkgDb+        (map SpecificSourcePackage localPackages)+++------------------------------------------------------------------------------+-- * Install plan post-processing+------------------------------------------------------------------------------++-- This phase goes from the InstallPlan we get from the solver and has to+-- make an elaborated install plan.+--+-- We go in two steps:+--+--  1. elaborate all the source packages that the solver has chosen.+--  2. swap source packages for pre-existing installed packages wherever+--     possible.+--+-- We do it in this order, elaborating and then replacing, because the easiest+-- way to calculate the installed package ids used for the replacement step is+-- from the elaborated configuration for each package.+++++------------------------------------------------------------------------------+-- * Install plan elaboration+------------------------------------------------------------------------------++-- | Produce an elaborated install plan using the policy for local builds with+-- a nix-style shared store.+--+-- In theory should be able to make an elaborated install plan with a policy+-- matching that of the classic @cabal install --user@ or @--global@+--+elaborateInstallPlan+  :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb+  -> DistDirLayout+  -> CabalDirLayout+  -> SolverInstallPlan+  -> [SourcePackage loc]+  -> Map PackageId PackageSourceHash+  -> InstallDirs.InstallDirTemplates+  -> ProjectConfigShared+  -> PackageConfig+  -> Map PackageName PackageConfig+  -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)+elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB+                     DistDirLayout{..}+                     cabalDirLayout@CabalDirLayout{cabalStorePackageDB}+                     solverPlan localPackages+                     sourcePackageHashes+                     defaultInstallDirs+                     _sharedPackageConfig+                     localPackagesConfig+                     perPackageConfig = do+    x <- elaboratedInstallPlan+    return (x, elaboratedSharedConfig)+  where+    elaboratedSharedConfig =+      ElaboratedSharedConfig {+        pkgConfigPlatform      = platform,+        pkgConfigCompiler      = compiler,+        pkgConfigCompilerProgs = compilerprogdb+      }++    preexistingInstantiatedPkgs =+        Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan))+      where+        f (SolverInstallPlan.PreExisting inst)+            | not (IPI.indefinite ipkg)+            = Just (IPI.installedUnitId ipkg,+                     (FullUnitId (IPI.installedComponentId ipkg)+                                 (Map.fromList (IPI.instantiatedWith ipkg))))+         where ipkg = instSolverPkgIPI inst+        f _ = Nothing++    elaboratedInstallPlan =+      flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->+        case planpkg of+          SolverInstallPlan.PreExisting pkg ->+            return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]++          SolverInstallPlan.Configured  pkg ->+            map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg++    -- NB: We don't INSTANTIATE packages at this point.  That's+    -- a post-pass.  This makes it simpler to compute dependencies.+    elaborateSolverToComponents+        :: (SolverId -> [ElaboratedPlanPackage])+        -> SolverPackage UnresolvedPkgLoc+        -> LogProgress [ElaboratedConfiguredPackage]+    elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0)+        | Right g <- toComponentsGraph (elabEnabledSpec elab0) pd = do+            infoProgress $ hang (text "Component graph for" <+> disp pkgid <<>> colon)+                            4 (dispComponentsGraph g)+            (_, comps) <- mapAccumM buildComponent+                            ((Map.empty, Map.empty), Map.empty, Map.empty)+                            (map fst g)+            let is_public_lib ElaboratedConfiguredPackage{..} =+                    case elabPkgOrComp of+                        ElabComponent comp -> compSolverName comp == CD.ComponentLib+                        _ -> False+                modShape = case find is_public_lib comps of+                            Nothing -> emptyModuleShape+                            Just ElaboratedConfiguredPackage{..} -> elabModuleShape+            return $ if eligible+                then comps+                else [(elaborateSolverToPackage mapDep spkg) {+                        elabModuleShape = modShape+                     }]+        | otherwise = failProgress (text "component cycle in" <+> disp pkgid)+      where+        eligible+            -- At this point in time, only non-Custom setup scripts+            -- are supported.  Implementing per-component builds with+            -- Custom would require us to create a new 'ElabSetup'+            -- type, and teach all of the code paths how to handle it.+            -- Once you've implemented this, swap it for the code below.+            = fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) /= PD.Custom+            {-+            -- Only non-Custom or sufficiently recent Custom+            -- scripts can be build per-component.+            = (fromMaybe PD.Custom (PD.buildType pd) /= PD.Custom)+                || PD.specVersion pd >= mkVersion [1,25,0]+            -}++        elab0 = elaborateSolverToCommon mapDep spkg+        pkgid = elabPkgSourceId    elab0+        pd    = elabPkgDescription elab0++        buildComponent+            :: (ConfiguredComponentMap,+                LinkedComponentMap,+                Map ComponentId FilePath)+            -> Cabal.Component+            -> LogProgress+                ((ConfiguredComponentMap,+                  LinkedComponentMap,+                  Map ComponentId FilePath),+                ElaboratedConfiguredPackage)+        buildComponent (cc_map, lc_map, exe_map) comp = do+            -- Before we get too far, check if we depended on something+            -- unbuildable.  If we did, give a good error.  (If we don't+            -- check, the 'toConfiguredComponent' will assert fail, see #3978).+            case unbuildable_external_lib_deps of+                [] -> return ()+                deps -> failProgress $+                            text "The package" <+> disp pkgid <+>+                            text "depends on unbuildable libraries:" <+>+                            hsep (punctuate comma (map (disp.solverSrcId) deps))+            case unbuildable_external_exe_deps of+                [] -> return ()+                deps -> failProgress $+                            text "The package" <+> disp pkgid <+>+                            text "depends on unbuildable executables:" <+>+                            hsep (punctuate comma (map (disp.solverSrcId) deps))+            infoProgress $ dispConfiguredComponent cc+            let -- Use of invariant: DefUnitId indicates that if+                -- there is no hash, it must have an empty+                -- instantiation.+                lookup_uid def_uid =+                    case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of+                        Just full -> full+                        Nothing -> error ("lookup_uid: " ++ display def_uid)+            lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0)+                        (Map.union external_lc_map lc_map) cc+            let lc_map' = extendLinkedComponentMap lc lc_map+            infoProgress $ dispLinkedComponent lc+            -- NB: For inplace NOT InstallPaths.bindir installDirs; for an+            -- inplace build those values are utter nonsense.  So we+            -- have to guess where the directory is going to be.+            -- Fortunately this is "stable" part of Cabal API.+            -- But the way we get the build directory is A HORRIBLE+            -- HACK.+            let elab = elab1 {+                    elabModuleShape = lc_shape lc,+                    elabUnitId      = abstractUnitId (lc_uid lc),+                    elabComponentId = lc_cid lc,+                    elabLinkedInstantiatedWith = Map.fromList (lc_insts lc),+                    elabPkgOrComp = ElabComponent $ elab_comp {+                        compLinkedLibDependencies = map fst (lc_depends lc),+                        compNonSetupDependencies =+                            ordNub (map (abstractUnitId . fst) (lc_depends lc))+                      }+                   }+                inplace_bin_dir+                  | shouldBuildInplaceOnly spkg+                  = distBuildDirectory+                        (elabDistDirParams elaboratedSharedConfig elab) </>+                        "build" </> case Cabal.componentNameString cname of+                                        Just n -> display n+                                        Nothing -> ""+                  | otherwise+                  = InstallDirs.bindir install_dirs+                exe_map' = Map.insert cid inplace_bin_dir exe_map+            return ((cc_map', lc_map', exe_map'), elab)+          where+            elab1 = elab0 {+                    elabInstallDirs = install_dirs,+                    elabRequiresRegistration = requires_reg,+                    elabPkgOrComp = ElabComponent $ elab_comp+                 }+            elab_comp = ElaboratedComponent {..}+            compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies"+            compNonSetupDependencies = error "buildComponent: compNonSetupDependencies"++            cc = toConfiguredComponent pd cid external_cc_map cc_map comp+            cc_map' = extendConfiguredComponentMap cc cc_map++            cid :: ComponentId+            cid = case elabBuildStyle elab0 of+                    BuildInplaceOnly ->+                      mkComponentId $+                        display pkgid ++ "-inplace" +++                          (case Cabal.componentNameString cname of+                              Nothing -> ""+                              Just s -> "-" ++ display s)+                    BuildAndInstall ->+                      hashedInstalledPackageId+                        (packageHashInputs+                            elaboratedSharedConfig+                            elab1) -- knot tied++            cname = Cabal.componentName comp+            requires_reg = case cname of+                CLibName -> True+                CSubLibName _ -> True+                _ -> False+            compComponentName = Just cname+            compSolverName = CD.componentNameToComponent cname+            -- NB: compLinkedLibDependencies and+            -- compNonSetupDependencies are defined when we define+            -- 'elab'.+            compLibDependencies =+                concatMap (elaborateLibSolverId mapDep) external_lib_dep_sids+            compExeDependencies =+                map confInstId+                    (concatMap (elaborateExeSolverId mapDep) external_exe_dep_sids) +++                cc_internal_build_tools cc+            compExeDependencyPaths =+                concatMap (elaborateExePath mapDep)+                          (CD.select (== compSolverName) exe_deps0) +++                [ path+                | cid' <- compExeDependencies+                , Just path <- [Map.lookup cid' exe_map]]++            bi = Cabal.componentBuildInfo comp+            compPkgConfigDependencies =+                [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! "+                                            ++ display pn ++ " from "+                                            ++ display (elabPkgSourceId elab1))+                                 (pkgConfigDbPkgVersion pkgConfigDB pn))+                | PkgconfigDependency pn _ <- PD.pkgconfigDepends bi ]++            compSetupDependencies = concatMap (elaborateLibSolverId mapDep) (CD.setupDeps deps0)++            install_dirs+              | shouldBuildInplaceOnly spkg+              -- use the ordinary default install dirs+              = (InstallDirs.absoluteInstallDirs+                   pkgid+                   (newSimpleUnitId cid)+                   (compilerInfo compiler)+                   InstallDirs.NoCopyDest+                   platform+                   defaultInstallDirs) {++                  InstallDirs.libsubdir  = "", -- absoluteInstallDirs sets these as+                  InstallDirs.datasubdir = ""  -- 'undefined' but we have to use+                }                              -- them as "Setup.hs configure" args++              | otherwise+              -- use special simplified install dirs+              = storePackageInstallDirs+                  cabalDirLayout+                  (compilerId compiler)+                  cid++            external_lib_dep_sids = CD.select (== compSolverName) deps0+            external_lib_dep_pkgs = concatMap (elaborateLibSolverId' mapDep) external_lib_dep_sids+            external_exe_dep_sids = CD.select (== compSolverName) exe_deps0+            external_cc_map = Map.fromList (map mkPkgNameMapping external_lib_dep_pkgs)+            external_lc_map = Map.fromList (map mkShapeMapping external_lib_dep_pkgs)++            unbuildable_external_lib_deps =+                filter (null . elaborateLibSolverId mapDep) external_lib_dep_sids+            unbuildable_external_exe_deps =+                filter (null . elaborateExeSolverId mapDep) external_exe_dep_sids++            mkPkgNameMapping :: ElaboratedPlanPackage+                             -> (PackageName, (ComponentId, PackageId))+            mkPkgNameMapping dpkg =+                (packageName dpkg, (getComponentId dpkg, packageId dpkg))++            mkShapeMapping :: ElaboratedPlanPackage+                           -> (ComponentId, (OpenUnitId, ModuleShape))+            mkShapeMapping dpkg =+                (getComponentId dpkg, (indef_uid, shape))+              where+                (dcid, shape) = case dpkg of+                    InstallPlan.PreExisting dipkg ->+                        (IPI.installedComponentId dipkg, shapeInstalledPackage dipkg)+                    InstallPlan.Configured elab' ->+                        (elabComponentId elab', elabModuleShape elab')+                    InstallPlan.Installed elab' ->+                        (elabComponentId elab', elabModuleShape elab')+                indef_uid =+                    IndefFullUnitId dcid+                        (Map.fromList [ (req, OpenModuleVar req)+                                      | req <- Set.toList (modShapeRequires shape)])++    elaborateLibSolverId' :: (SolverId -> [ElaboratedPlanPackage])+                      -> SolverId -> [ElaboratedPlanPackage]+    elaborateLibSolverId' mapDep = filter is_lib . mapDep+      where is_lib (InstallPlan.PreExisting _) = True+            is_lib (InstallPlan.Configured elab) =+                case elabPkgOrComp elab of+                    ElabPackage _ -> True+                    ElabComponent comp -> compSolverName comp == CD.ComponentLib+            is_lib (InstallPlan.Installed _) = unexpectedState++    elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage])+                      -> SolverId -> [ConfiguredId]+    elaborateLibSolverId mapDep = map configuredId . elaborateLibSolverId' mapDep++    elaborateExeSolverId :: (SolverId -> [ElaboratedPlanPackage])+                      -> SolverId -> [ConfiguredId]+    elaborateExeSolverId mapDep = map configuredId . filter is_exe . mapDep+      where is_exe (InstallPlan.PreExisting _) = False+            is_exe (InstallPlan.Configured elab) =+                case elabPkgOrComp elab of+                    ElabPackage _ -> True+                    ElabComponent comp ->+                        case compSolverName comp of+                            CD.ComponentExe _ -> True+                            _ -> False+            is_exe (InstallPlan.Installed _) = unexpectedState++    elaborateExePath :: (SolverId -> [ElaboratedPlanPackage])+                     -> SolverId -> [FilePath]+    elaborateExePath mapDep = concatMap get_exe_path . mapDep+      where+        -- Pre-existing executables are assumed to be in PATH+        -- already.  In fact, this should be impossible.+        -- Modest duplication with 'inplace_bin_dir'+        get_exe_path (InstallPlan.PreExisting _) = []+        get_exe_path (InstallPlan.Configured elab) =+            [if elabBuildStyle elab == BuildInplaceOnly+              then distBuildDirectory+                    (elabDistDirParams elaboratedSharedConfig elab) </>+                    "build" </>+                        case elabPkgOrComp elab of+                            ElabPackage _ -> ""+                            ElabComponent comp ->+                                case fmap Cabal.componentNameString+                                          (compComponentName comp) of+                                    Just (Just n) -> display n+                                    _ -> ""+              else InstallDirs.bindir (elabInstallDirs elab)]+        get_exe_path (InstallPlan.Installed _) = unexpectedState++    unexpectedState = error "elaborateInstallPlan: unexpected Installed state"++    elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage])+                             -> SolverPackage UnresolvedPkgLoc+                             -> ElaboratedConfiguredPackage+    elaborateSolverToPackage+        mapDep+        pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride)+                           _flags _stanzas deps0 exe_deps0) =+        -- Knot tying: the final elab includes the+        -- pkgInstalledId, which is calculated by hashing many+        -- of the other fields of the elaboratedPackage.+        elab+      where+        elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg+        elab = elab0 {+                elabUnitId = newSimpleUnitId pkgInstalledId,+                elabComponentId = pkgInstalledId,+                elabLinkedInstantiatedWith = Map.empty,+                elabInstallDirs = install_dirs,+                elabRequiresRegistration = requires_reg,+                elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}+            }++        deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0++        requires_reg = PD.hasPublicLib elabPkgDescription+        pkgInstalledId+          | shouldBuildInplaceOnly pkg+          = mkComponentId (display pkgid ++ "-inplace")++          | otherwise+          = assert (isJust elabPkgSourceHash) $+            hashedInstalledPackageId+              (packageHashInputs+                elaboratedSharedConfig+                elab)  -- recursive use of elab++          | otherwise+          = error $ "elaborateInstallPlan: non-inplace package "+                 ++ " is missing a source hash: " ++ display pkgid++        pkgLibDependencies  = deps+        pkgExeDependencies  = fmap (concatMap (elaborateExeSolverId mapDep)) exe_deps0+        pkgExeDependencyPaths = fmap (concatMap (elaborateExePath mapDep)) exe_deps0+        pkgPkgConfigDependencies =+              ordNub+            $ [ (pn, fromMaybe (error $ "pkgPkgConfigDependencies: impossible! "+                                          ++ display pn ++ " from " ++ display pkgid)+                               (pkgConfigDbPkgVersion pkgConfigDB pn))+              | PkgconfigDependency pn _ <- concatMap PD.pkgconfigDepends+                                                (PD.allBuildInfo elabPkgDescription)+              ]++        -- Filled in later+        pkgStanzasEnabled  = Set.empty++        install_dirs+          | shouldBuildInplaceOnly pkg+          -- use the ordinary default install dirs+          = (InstallDirs.absoluteInstallDirs+               pkgid+               (newSimpleUnitId pkgInstalledId)+               (compilerInfo compiler)+               InstallDirs.NoCopyDest+               platform+               defaultInstallDirs) {++              InstallDirs.libsubdir  = "", -- absoluteInstallDirs sets these as+              InstallDirs.datasubdir = ""  -- 'undefined' but we have to use+            }                              -- them as "Setup.hs configure" args++          | otherwise+          -- use special simplified install dirs+          = storePackageInstallDirs+              cabalDirLayout+              (compilerId compiler)+              pkgInstalledId++    elaborateSolverToCommon :: (SolverId -> [ElaboratedPlanPackage])+                            -> SolverPackage UnresolvedPkgLoc+                            -> ElaboratedConfiguredPackage+    elaborateSolverToCommon mapDep+        pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride)+                           flags stanzas deps0 _exe_deps0) =+        elaboratedPackage+      where+        elaboratedPackage = ElaboratedConfiguredPackage {..}++        -- These get filled in later+        elabUnitId          = error "elaborateSolverToCommon: elabUnitId"+        elabComponentId     = error "elaborateSolverToCommon: elabComponentId"+        elabInstantiatedWith = Map.empty+        elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith"+        elabPkgOrComp       = error "elaborateSolverToCommon: elabPkgOrComp"+        elabInstallDirs     = error "elaborateSolverToCommon: elabInstallDirs"+        elabRequiresRegistration = error "elaborateSolverToCommon: elabRequiresRegistration"+        elabModuleShape     = error "elaborateSolverToCommon: elabModuleShape"++        elabPkgSourceId     = pkgid+        elabPkgDescription  = let Right (desc, _) =+                                    PD.finalizePD+                                    flags elabEnabledSpec (const True)+                                    platform (compilerInfo compiler)+                                    [] gdesc+                               in desc+        elabInternalPackages = Cabal.getInternalPackages gdesc+        elabFlagAssignment  = flags+        elabFlagDefaults    = [ (Cabal.flagName flag, Cabal.flagDefault flag)+                              | flag <- PD.genPackageFlags gdesc ]++        elabEnabledSpec      = enableStanzas stanzas+        elabStanzasAvailable = Set.fromList stanzas+        elabStanzasRequested =+            -- NB: even if a package stanza is requested, if the package+            -- doesn't actually have any of that stanza we omit it from+            -- the request, to ensure that we don't decide that this+            -- package needs to be rebuilt.  (It needs to be done here,+            -- because the ElaboratedConfiguredPackage is where we test+            -- whether or not there have been changes.)+            Map.fromList $ [ (TestStanzas,  v) | v <- maybeToList tests+                                               , _ <- PD.testSuites elabPkgDescription ]+                        ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks+                                               , _ <- PD.benchmarks elabPkgDescription ]+          where+            tests, benchmarks :: Maybe Bool+            tests      = perPkgOptionMaybe pkgid packageConfigTests+            benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks++        -- This is a placeholder which will get updated by 'pruneInstallPlanPass1'+        -- and 'pruneInstallPlanPass2'.  We can't populate it here+        -- because whether or not tests/benchmarks should be enabled+        -- is heuristically calculated based on whether or not the+        -- dependencies of the test suite have already been installed,+        -- but this function doesn't know what is installed (since+        -- we haven't improved the plan yet), so we do it in another pass.+        -- Check the comments of those functions for more details.+        elabBuildTargets    = []+        elabReplTarget      = Nothing+        elabBuildHaddocks   = False++        elabPkgSourceLocation = srcloc+        elabPkgSourceHash   = Map.lookup pkgid sourcePackageHashes+        elabLocalToProject  = isLocalToProject pkg+        elabBuildStyle      = if shouldBuildInplaceOnly pkg+                                then BuildInplaceOnly else BuildAndInstall+        elabBuildPackageDBStack    = buildAndRegisterDbs+        elabRegisterPackageDBStack = buildAndRegisterDbs++        elabSetupScriptStyle       = packageSetupScriptStyle elabPkgDescription+        -- Computing the deps here is a little awful+        deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0+        elabSetupScriptCliVersion  = packageSetupScriptSpecVersion+                                      elabSetupScriptStyle elabPkgDescription deps+        elabSetupPackageDBStack    = buildAndRegisterDbs++        buildAndRegisterDbs+          | shouldBuildInplaceOnly pkg = inplacePackageDbs+          | otherwise                  = storePackageDbs++        elabPkgDescriptionOverride = descOverride++        elabVanillaLib    = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively+        elabSharedLib     = pkgid `Set.member` pkgsUseSharedLibrary+        elabDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe+        elabGHCiLib       = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still++        elabProfExe       = perPkgOptionFlag pkgid False packageConfigProf+        elabProfLib       = pkgid `Set.member` pkgsUseProfilingLibrary++        (elabProfExeDetail,+         elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault+                               packageConfigProfDetail+                               packageConfigProfLibDetail+        elabCoverage      = perPkgOptionFlag pkgid False packageConfigCoverage++        elabOptimization  = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization+        elabSplitObjs     = perPkgOptionFlag pkgid False packageConfigSplitObjs+        elabStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs+        elabStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes+        elabDebugInfo     = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo++        -- Combine the configured compiler prog settings with the user-supplied+        -- config. For the compiler progs any user-supplied config was taken+        -- into account earlier when configuring the compiler so its ok that+        -- our configured settings for the compiler override the user-supplied+        -- config here.+        elabProgramPaths  = Map.fromList+                             [ (programId prog, programPath prog)+                             | prog <- configuredPrograms compilerprogdb ]+                        <> perPkgOptionMapLast pkgid packageConfigProgramPaths+        elabProgramArgs   = Map.fromList+                             [ (programId prog, args)+                             | prog <- configuredPrograms compilerprogdb+                             , let args = programOverrideArgs prog+                             , not (null args)+                             ]+                        <> perPkgOptionMapMappend pkgid packageConfigProgramArgs+        elabProgramPathExtra    = perPkgOptionNubList pkgid packageConfigProgramPathExtra+        elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs+        elabExtraLibDirs        = perPkgOptionList pkgid packageConfigExtraLibDirs+        elabExtraFrameworkDirs  = perPkgOptionList pkgid packageConfigExtraFrameworkDirs+        elabExtraIncludeDirs    = perPkgOptionList pkgid packageConfigExtraIncludeDirs+        elabProgPrefix          = perPkgOptionMaybe pkgid packageConfigProgPrefix+        elabProgSuffix          = perPkgOptionMaybe pkgid packageConfigProgSuffix+++        elabHaddockHoogle       = perPkgOptionFlag pkgid False packageConfigHaddockHoogle+        elabHaddockHtml         = perPkgOptionFlag pkgid False packageConfigHaddockHtml+        elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation+        elabHaddockForeignLibs  = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs+        elabHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables+        elabHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites+        elabHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks+        elabHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal+        elabHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss+        elabHaddockHscolour     = perPkgOptionFlag pkgid False packageConfigHaddockHscolour+        elabHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss+        elabHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents++    perPkgOptionFlag  :: PackageId -> a ->  (PackageConfig -> Flag a) -> a+    perPkgOptionMaybe :: PackageId ->       (PackageConfig -> Flag a) -> Maybe a+    perPkgOptionList  :: PackageId ->       (PackageConfig -> [a])    -> [a]++    perPkgOptionFlag  pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f)+    perPkgOptionMaybe pkgid     f = flagToMaybe (lookupPerPkgOption pkgid f)+    perPkgOptionList  pkgid     f = lookupPerPkgOption pkgid f+    perPkgOptionNubList    pkgid f = fromNubList   (lookupPerPkgOption pkgid f)+    perPkgOptionMapLast    pkgid f = getMapLast    (lookupPerPkgOption pkgid f)+    perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f)++    perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib)+      where+        exe = fromFlagOrDefault def bothflag+        lib = fromFlagOrDefault def (bothflag <> libflag)++        bothflag = lookupPerPkgOption pkgid fboth+        libflag  = lookupPerPkgOption pkgid flib++    lookupPerPkgOption :: (Package pkg, Monoid m)+                       => pkg -> (PackageConfig -> m) -> m+    lookupPerPkgOption pkg f+      -- the project config specifies values that apply to packages local to+      -- but by default non-local packages get all default config values+      -- the project, and can specify per-package values for any package,+      | isLocalToProject pkg = local `mappend` perpkg+      | otherwise            =                 perpkg+      where+        local  = f localPackagesConfig+        perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)++    inplacePackageDbs = storePackageDbs+                     ++ [ distPackageDB (compilerId compiler) ]++    storePackageDbs   = [ GlobalPackageDB+                        , cabalStorePackageDB (compilerId compiler) ]++    -- For this local build policy, every package that lives in a local source+    -- dir (as opposed to a tarball), or depends on such a package, will be+    -- built inplace into a shared dist dir. Tarball packages that depend on+    -- source dir packages will also get unpacked locally.+    shouldBuildInplaceOnly :: SolverPackage loc -> Bool+    shouldBuildInplaceOnly pkg = Set.member (packageId pkg)+                                            pkgsToBuildInplaceOnly++    pkgsToBuildInplaceOnly :: Set PackageId+    pkgsToBuildInplaceOnly =+        Set.fromList+      $ map packageId+      $ SolverInstallPlan.reverseDependencyClosure+          solverPlan+          [ PlannedId (packageId pkg)+          | pkg <- localPackages ]++    isLocalToProject :: Package pkg => pkg -> Bool+    isLocalToProject pkg = Set.member (packageId pkg)+                                      pkgsLocalToProject++    pkgsLocalToProject :: Set PackageId+    pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ]++    pkgsUseSharedLibrary :: Set PackageId+    pkgsUseSharedLibrary =+        packagesWithLibDepsDownwardClosedProperty needsSharedLib+      where+        needsSharedLib pkg =+            fromMaybe compilerShouldUseSharedLibByDefault+                      (liftM2 (||) pkgSharedLib pkgDynExe)+          where+            pkgid        = packageId pkg+            pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib+            pkgDynExe    = perPkgOptionMaybe pkgid packageConfigDynExe++    --TODO: [code cleanup] move this into the Cabal lib. It's currently open+    -- coded in Distribution.Simple.Configure, but should be made a proper+    -- function of the Compiler or CompilerInfo.+    compilerShouldUseSharedLibByDefault =+      case compilerFlavor compiler of+        GHC   -> GHC.isDynamic compiler+        GHCJS -> GHCJS.isDynamic compiler+        _     -> False++    pkgsUseProfilingLibrary :: Set PackageId+    pkgsUseProfilingLibrary =+        packagesWithLibDepsDownwardClosedProperty needsProfilingLib+      where+        needsProfilingLib pkg =+            fromFlagOrDefault False (profBothFlag <> profLibFlag)+          where+            pkgid        = packageId pkg+            profBothFlag = lookupPerPkgOption pkgid packageConfigProf+            profLibFlag  = lookupPerPkgOption pkgid packageConfigProfLib+            --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe++    libDepGraph = Graph.fromList (map NonSetupLibDepSolverPlanPackage+                                      (SolverInstallPlan.toList solverPlan))++    packagesWithLibDepsDownwardClosedProperty property =+        Set.fromList+      . map packageId+      . fromMaybe []+      $ Graph.closure+          libDepGraph+          [ Graph.nodeKey pkg+          | pkg <- SolverInstallPlan.toList solverPlan+          , property pkg ] -- just the packages that satisfy the propety+      --TODO: [nice to have] this does not check the config consistency,+      -- e.g. a package explicitly turning off profiling, but something+      -- depending on it that needs profiling. This really needs a separate+      -- package config validation/resolution pass.++      --TODO: [nice to have] config consistency checking:+      -- + profiling libs & exes, exe needs lib, recursive+      -- + shared libs & exes, exe needs lib, recursive+      -- + vanilla libs & exes, exe needs lib, recursive+      -- + ghci or shared lib needed by TH, recursive, ghc version dependent++-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the+-- dependency graph considers only dependencies on libraries which are+-- NOT from setup dependencies.  Used to compute the set+-- of packages needed for profiling and dynamic libraries.+newtype NonSetupLibDepSolverPlanPackage+    = NonSetupLibDepSolverPlanPackage+    { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage }++instance Package NonSetupLibDepSolverPlanPackage where+    packageId = packageId . unNonSetupLibDepSolverPlanPackage++instance IsNode NonSetupLibDepSolverPlanPackage where+    type Key NonSetupLibDepSolverPlanPackage = SolverId+    nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage+    nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg)+        = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg)++type InstS = Map UnitId ElaboratedPlanPackage+type InstM a = State InstS a++getComponentId :: ElaboratedPlanPackage+               -> ComponentId+getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg+getComponentId (InstallPlan.Configured elab) = elabComponentId elab+getComponentId (InstallPlan.Installed elab) = elabComponentId elab++instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan+instantiateInstallPlan plan =+    InstallPlan.new (IndependentGoals False) (Graph.fromList (Map.elems ready_map))+  where+    pkgs = InstallPlan.toList plan++    cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ]++    instantiateUnitId :: ComponentId -> Map ModuleName Module+                      -> InstM DefUnitId+    instantiateUnitId cid insts = state $ \s ->+        case Map.lookup uid s of+            Nothing ->+                -- Knot tied+                let (r, s') = runState (instantiateComponent uid cid insts)+                                       (Map.insert uid r s)+                in (def_uid, Map.insert uid r s')+            Just _ -> (def_uid, s)+      where+        def_uid = mkDefUnitId cid insts+        uid = unDefUnitId def_uid++    instantiateComponent+        :: UnitId -> ComponentId -> Map ModuleName Module+        -> InstM ElaboratedPlanPackage+    instantiateComponent uid cid insts+      | Just planpkg <- Map.lookup cid cmap+      = case planpkg of+          InstallPlan.Configured (elab@ElaboratedConfiguredPackage+                                    { elabPkgOrComp = ElabComponent comp }) -> do+            deps <- mapM (substUnitId insts)+                         (compLinkedLibDependencies comp)+            let getDep (Module dep_uid _) = [dep_uid]+            return $ InstallPlan.Configured elab {+                    elabUnitId = uid,+                    elabComponentId = cid,+                    elabInstantiatedWith = insts,+                    elabPkgOrComp = ElabComponent comp {+                        compNonSetupDependencies =+                            (if Map.null insts then [] else [newSimpleUnitId cid]) +++                            ordNub (map unDefUnitId+                                (deps ++ concatMap getDep (Map.elems insts)))+                    }+                }+          _ -> return planpkg+      | otherwise = error ("instantiateComponent: " ++ display cid)++    substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId+    substUnitId _ (DefiniteUnitId uid) =+        return uid+    substUnitId subst (IndefFullUnitId cid insts) = do+        insts' <- substSubst subst insts+        instantiateUnitId cid insts'++    -- NB: NOT composition+    substSubst :: Map ModuleName Module+               -> Map ModuleName OpenModule+               -> InstM (Map ModuleName Module)+    substSubst subst insts = T.mapM (substModule subst) insts++    substModule :: Map ModuleName Module -> OpenModule -> InstM Module+    substModule subst (OpenModuleVar mod_name)+        | Just m <- Map.lookup mod_name subst = return m+        | otherwise = error "substModule: non-closing substitution"+    substModule subst (OpenModule uid mod_name) = do+        uid' <- substUnitId subst uid+        return (Module uid' mod_name)++    indefiniteUnitId :: ComponentId -> InstM UnitId+    indefiniteUnitId cid = do+        let uid = newSimpleUnitId cid+        r <- indefiniteComponent uid cid+        state $ \s -> (uid, Map.insert uid r s)++    indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage+    indefiniteComponent _uid cid+      | Just planpkg <- Map.lookup cid cmap+      = case planpkg of+          InstallPlan.Configured elab@ElaboratedConfiguredPackage+                { elabPkgOrComp = ElabComponent comp } ->+            return $ InstallPlan.Configured elab {+                    elabPkgOrComp = ElabComponent comp {+                            compNonSetupDependencies =+                                ordNub (map abstractUnitId (compLinkedLibDependencies comp))+                        }+                }+          _ -> return planpkg -- shouldn't happen+      | otherwise = error ("indefiniteComponent: " ++ display cid)++    ready_map = execState work Map.empty++    work = forM_ pkgs $ \pkg ->+            case pkg of+                InstallPlan.Configured elab+                    | not (Map.null (elabLinkedInstantiatedWith elab))+                    -> indefiniteUnitId (elabComponentId elab)+                        >> return ()+                _ -> instantiateUnitId (getComponentId pkg) Map.empty+                        >> return ()++---------------------------+-- Build targets+--++-- Refer to ProjectPlanning.Types for details of these important types:++-- data PackageTarget = ...+-- data ComponentTarget = ...+-- data SubComponentTarget = ...+++--TODO: this needs to report some user target/config errors+elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget]+                        -> ([ComponentTarget], Maybe ComponentTarget, Bool)+elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =+    let buildTargets  = nubComponentTargets+                      . map compatSubComponentTargets+                      . concatMap elaborateBuildTarget+                      $ targets+        --TODO: instead of listToMaybe we should be reporting an error here+        replTargets   = listToMaybe+                      . nubComponentTargets+                      . map compatSubComponentTargets+                      . concatMap elaborateReplTarget+                      $ targets+        buildHaddocks = HaddockDefaultComponents `elem` targets++     in (buildTargets, replTargets, buildHaddocks)+  where+    --TODO: need to report an error here if defaultComponents is empty+    elaborateBuildTarget  BuildDefaultComponents    = pkgDefaultComponents+    elaborateBuildTarget (BuildSpecificComponent t) = [t]+    elaborateBuildTarget  _                         = []++    --TODO: need to report an error here if defaultComponents is empty+    elaborateReplTarget  ReplDefaultComponent     = take 1 pkgDefaultComponents+    elaborateReplTarget (ReplSpecificComponent t) = [t]+    elaborateReplTarget  _                        = []++    pkgDefaultComponents =+        [ ComponentTarget cname WholeComponent+        | c <- Cabal.pkgComponents elabPkgDescription+        , PD.buildable (Cabal.componentBuildInfo c)+        , let cname = Cabal.componentName c+        , enabledOptionalStanza cname+        ]+      where+        enabledOptionalStanza cname =+          case componentOptionalStanza cname of+            Nothing     -> True+            Just stanza -> Map.lookup stanza elabStanzasRequested+                        == Just True++    -- Not all Cabal Setup.hs versions support sub-component targets, so switch+    -- them over to the whole component+    compatSubComponentTargets :: ComponentTarget -> ComponentTarget+    compatSubComponentTargets target@(ComponentTarget cname _subtarget)+      | not setupHsSupportsSubComponentTargets+                  = ComponentTarget cname WholeComponent+      | otherwise = target++    -- Actually the reality is that no current version of Cabal's Setup.hs+    -- build command actually support building specific files or modules.+    setupHsSupportsSubComponentTargets = False+    -- TODO: when that changes, adjust this test, e.g.+    -- | pkgSetupScriptCliVersion >= Version [x,y] []++    nubComponentTargets :: [ComponentTarget] -> [ComponentTarget]+    nubComponentTargets =+        concatMap (wholeComponentOverrides . map snd)+      . groupBy ((==)    `on` fst)+      . sortBy  (compare `on` fst)+      . map (\t@(ComponentTarget cname _) -> (cname, t))++    -- If we're building the whole component then that the only target all we+    -- need, otherwise we can have several targets within the component.+    wholeComponentOverrides :: [ComponentTarget] -> [ComponentTarget]+    wholeComponentOverrides ts =+      case [ t | t@(ComponentTarget _ WholeComponent) <- ts ] of+        (t:_) -> [t]+        []    -> ts++pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool+pkgHasEphemeralBuildTargets elab =+    isJust (elabReplTarget elab)+ || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab+                      , subtarget /= WholeComponent ]++-- | The components that we'll build all of, meaning that after they're built+-- we can skip building them again (unlike with building just some modules or+-- other files within a component).+--+elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage+                              -> Set ComponentName+elabBuildTargetWholeComponents elab =+    Set.fromList+      [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ]++++------------------------------------------------------------------------------+-- * Install plan pruning+------------------------------------------------------------------------------++-- | Given a set of package targets (and optionally component targets within+-- those packages), take the subset of the install plan needed to build those+-- targets. Also, update the package config to specify which optional stanzas+-- to enable, and which targets within each package to build.+--+pruneInstallPlanToTargets :: Map UnitId [PackageTarget]+                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan+pruneInstallPlanToTargets perPkgTargetsMap elaboratedPlan =+    InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)+  . Graph.fromList+    -- We have to do this in two passes+  . pruneInstallPlanPass2+  . pruneInstallPlanPass1 perPkgTargetsMap+  . InstallPlan.toList+  $ elaboratedPlan++-- | This is a temporary data type, where we temporarily+-- override the graph dependencies of an 'ElaboratedPackage',+-- so we can take a closure over them.  We'll throw out the+-- overriden dependencies when we're done so it's strictly temporary.+--+-- For 'ElaboratedComponent', this the cached unit IDs always+-- coincide with the real thing.+data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId]++instance Package PrunedPackage where+    packageId (PrunedPackage elab _) = packageId elab++instance HasUnitId PrunedPackage where+    installedUnitId = nodeKey++instance IsNode PrunedPackage where+    type Key PrunedPackage = UnitId+    nodeKey (PrunedPackage elab _)  = nodeKey elab+    nodeNeighbors (PrunedPackage _ deps) = deps++fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage+fromPrunedPackage (PrunedPackage elab _) = elab++-- | The first pass does three things:+--+-- * Set the build targets based on the user targets (but not rev deps yet).+-- * A first go at determining which optional stanzas (testsuites, benchmarks)+--   are needed. We have a second go in the next pass.+-- * Take the dependency closure using pruned dependencies. We prune deps that+--   are used only by unneeded optional stanzas. These pruned deps are only+--   used for the dependency closure and are not persisted in this pass.+--+pruneInstallPlanPass1 :: Map UnitId [PackageTarget]+                      -> [ElaboratedPlanPackage]+                      -> [ElaboratedPlanPackage]+pruneInstallPlanPass1 perPkgTargetsMap pkgs =+    map (mapConfiguredPackage fromPrunedPackage)+        (fromMaybe [] $ Graph.closure g roots)+  where+    pkgs' = map (mapConfiguredPackage prune) pkgs+    g = Graph.fromList pkgs'++    prune elab =+        let elab' = (pruneOptionalStanzas . setElabBuildTargets) elab+        in PrunedPackage elab' (pruneOptionalDependencies elab')++    roots = mapMaybe find_root pkgs'+    find_root (InstallPlan.Configured (PrunedPackage elab _)) =+        if not (null (elabBuildTargets elab)+                    && isNothing (elabReplTarget elab)+                    && not (elabBuildHaddocks elab))+            then Just (installedUnitId elab)+            else Nothing+    find_root _ = Nothing++    -- Elaborate and set the targets we'll build for this package. This is just+    -- based on the targets from the user, not targets implied by reverse+    -- dependencies. Those comes in the second pass once we know the rev deps.+    --+    setElabBuildTargets elab =+        elab {+          elabBuildTargets   = mapMaybe targetForElab buildTargets,+          elabReplTarget     = replTarget >>= targetForElab,+          elabBuildHaddocks  = buildHaddocks+        }+      where+        (buildTargets, replTarget, buildHaddocks)+                = elaboratePackageTargets elab targets+        targets = fromMaybe []+                $ Map.lookup (installedUnitId elab) perPkgTargetsMap+        targetForElab tgt@(ComponentTarget cname _) =+            case elabPkgOrComp elab of+                ElabPackage _ -> Just tgt -- always valid+                ElabComponent comp+                    -- Only if the component name matches+                    | compComponentName comp == Just cname -> Just tgt+                    | otherwise -> Nothing++    -- Decide whether or not to enable testsuites and benchmarks+    --+    -- The testsuite and benchmark targets are somewhat special in that we need+    -- to configure the packages with them enabled, and we need to do that even+    -- if we only want to build one of several testsuites.+    --+    -- There are two cases in which we will enable the testsuites (or+    -- benchmarks): if one of the targets is a testsuite, or if all of the+    -- testsuite dependencies are already cached in the store. The rationale+    -- for the latter is to minimise how often we have to reconfigure due to+    -- the particular targets we choose to build. Otherwise choosing to build+    -- a testsuite target, and then later choosing to build an exe target+    -- would involve unnecessarily reconfiguring the package with testsuites+    -- disabled. Technically this introduces a little bit of stateful+    -- behaviour to make this "sticky", but it should be benign.+    --+    pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage+    pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } =+        elab {+            elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas })+        }+      where+        stanzas :: Set OptionalStanza+        stanzas = optionalStanzasRequiredByTargets  elab+               <> optionalStanzasRequestedByDefault elab+               <> optionalStanzasWithDepsAvailable availablePkgs elab pkg+    pruneOptionalStanzas elab = elab++    -- Calculate package dependencies but cut out those needed only by+    -- optional stanzas that we've determined we will not enable.+    -- These pruned deps are not persisted in this pass since they're based on+    -- the optional stanzas and we'll make further tweaks to the optional+    -- stanzas in the next pass.+    --+    pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId]+    pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ }+        = InstallPlan.depends elab -- no pruning+    pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg }+        = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)+      where+        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas+        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas+        keepNeeded _                     _ = True+        stanzas = pkgStanzasEnabled pkg++    optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage+                                     -> Set OptionalStanza+    optionalStanzasRequiredByTargets pkg =+      Set.fromList+        [ stanza+        | ComponentTarget cname _ <- elabBuildTargets pkg+                                  ++ maybeToList (elabReplTarget pkg)+        , stanza <- maybeToList (componentOptionalStanza cname)+        ]++    optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage+                                      -> Set OptionalStanza+    optionalStanzasRequestedByDefault =+        Map.keysSet+      . Map.filter (id :: Bool -> Bool)+      . elabStanzasRequested++    availablePkgs =+      Set.fromList+        [ installedUnitId pkg+        | InstallPlan.PreExisting pkg <- pkgs ]++-- | Given a set of already installed packages @availablePkgs@,+-- determine the set of available optional stanzas from @pkg@+-- which have all of their dependencies already installed.  This is used+-- to implement "sticky" testsuites, where once we have installed+-- all of the deps needed for the test suite, we go ahead and+-- enable it always.+optionalStanzasWithDepsAvailable :: Set UnitId+                                 -> ElaboratedConfiguredPackage+                                 -> ElaboratedPackage+                                 -> Set OptionalStanza+optionalStanzasWithDepsAvailable availablePkgs elab pkg =+    Set.fromList+      [ stanza+      | stanza <- Set.toList (elabStanzasAvailable elab)+      , let deps :: [UnitId]+            deps = CD.select (optionalStanzaDeps stanza)+                             -- TODO: probably need to select other+                             -- dep types too eventually+                             (pkgOrderDependencies pkg)+      , all (`Set.member` availablePkgs) deps+      ]+  where+    optionalStanzaDeps TestStanzas  (CD.ComponentTest  _) = True+    optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True+    optionalStanzaDeps _            _                     = False+++-- The second pass does three things:+--+-- * A second go at deciding which optional stanzas to enable.+-- * Prune the dependencies based on the final choice of optional stanzas.+-- * Extend the targets within each package to build, now we know the reverse+--   dependencies, ie we know which libs are needed as deps by other packages.+--+-- Achieving sticky behaviour with enabling\/disabling optional stanzas is+-- tricky. The first approximation was handled by the first pass above, but+-- it's not quite enough. That pass will enable stanzas if all of the deps+-- of the optional stanza are already installed /in the store/. That's important+-- but it does not account for dependencies that get built inplace as part of+-- the project. We cannot take those inplace build deps into account in the+-- pruning pass however because we don't yet know which ones we're going to+-- build. Once we do know, we can have another go and enable stanzas that have+-- all their deps available. Now we can consider all packages in the pruned+-- plan to be available, including ones we already decided to build from+-- source.+--+-- Deciding which targets to build depends on knowing which packages have+-- reverse dependencies (ie are needed). This requires the result of first+-- pass, which is another reason we have to split it into two passes.+--+-- Note that just because we might enable testsuites or benchmarks (in the+-- first or second pass) doesn't mean that we build all (or even any) of them.+-- That depends on which targets we picked in the first pass.+--+pruneInstallPlanPass2 :: [ElaboratedPlanPackage]+                      -> [ElaboratedPlanPackage]+pruneInstallPlanPass2 pkgs =+    map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs+  where+    setStanzasDepsAndTargets elab =+        elab {+          elabBuildTargets = ordNub+                           $ elabBuildTargets elab+                          ++ libTargetsRequiredForRevDeps+                          ++ exeTargetsRequiredForRevDeps,+          elabPkgOrComp =+            case elabPkgOrComp elab of+              ElabPackage pkg ->+                let stanzas = pkgStanzasEnabled pkg+                           <> optionalStanzasWithDepsAvailable availablePkgs elab pkg+                    keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas+                    keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas+                    keepNeeded _                     _ = True+                in ElabPackage $ pkg {+                  pkgStanzasEnabled = stanzas,+                  pkgLibDependencies   = CD.filterDeps keepNeeded (pkgLibDependencies pkg),+                  pkgExeDependencies   = CD.filterDeps keepNeeded (pkgExeDependencies pkg),+                  pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg)+                }+              r@(ElabComponent _) -> r+        }+      where+        libTargetsRequiredForRevDeps =+          [ ComponentTarget Cabal.defaultLibName WholeComponent+          | installedUnitId elab `Set.member` hasReverseLibDeps+          ]+        exeTargetsRequiredForRevDeps =+          -- TODO: allow requesting executable with different name+          -- than package name+          [ ComponentTarget (Cabal.CExeName+                             $ packageNameToUnqualComponentName+                             $ packageName $ elabPkgSourceId elab)+                            WholeComponent+          | installedUnitId elab `Set.member` hasReverseExeDeps+          ]+++    availablePkgs :: Set UnitId+    availablePkgs = Set.fromList (map installedUnitId pkgs)++    hasReverseLibDeps :: Set UnitId+    hasReverseLibDeps =+      Set.fromList [ depid+                   | InstallPlan.Configured pkg <- pkgs+                   , depid <- elabOrderLibDependencies pkg ]++    hasReverseExeDeps :: Set UnitId+    hasReverseExeDeps =+      Set.fromList [ depid+                   | InstallPlan.Configured pkg <- pkgs+                   , depid <- elabOrderExeDependencies pkg ]++mapConfiguredPackage :: (srcpkg -> srcpkg')+                     -> InstallPlan.GenericPlanPackage ipkg srcpkg+                     -> InstallPlan.GenericPlanPackage ipkg srcpkg'+mapConfiguredPackage f (InstallPlan.Configured pkg) =+  InstallPlan.Configured (f pkg)+mapConfiguredPackage f (InstallPlan.Installed pkg) =+  InstallPlan.Installed (f pkg)+mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =+  InstallPlan.PreExisting pkg++componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza+componentOptionalStanza (Cabal.CTestName  _) = Just TestStanzas+componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas+componentOptionalStanza _                    = Nothing++------------------------------------+-- Support for --only-dependencies+--++-- | Try to remove the given targets from the install plan.+--+-- This is not always possible.+--+pruneInstallPlanToDependencies :: Set UnitId+                               -> ElaboratedInstallPlan+                               -> Either CannotPruneDependencies+                                         ElaboratedInstallPlan+pruneInstallPlanToDependencies pkgTargets installPlan =+    assert (all (isJust . InstallPlan.lookup installPlan)+                (Set.toList pkgTargets)) $++    fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))+  . checkBrokenDeps+  . Graph.fromList+  . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)+  . InstallPlan.toList+  $ installPlan+    where+      -- Our strategy is to remove the packages we don't want and then check+      -- if the remaining graph is broken or not, ie any packages with dangling+      -- dependencies. If there are then we cannot prune the given targets.+      checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage+                      -> Either CannotPruneDependencies+                                (Graph.Graph ElaboratedPlanPackage)+      checkBrokenDeps graph =+        case Graph.broken graph of+          []             -> Right graph+          brokenPackages ->+            Left $ CannotPruneDependencies+             [ (pkg, missingDeps)+             | (pkg, missingDepIds) <- brokenPackages+             , let missingDeps = catMaybes (map lookupDep missingDepIds)+             ]+            where+              -- lookup in the original unpruned graph+              lookupDep = InstallPlan.lookup installPlan++-- | It is not always possible to prune to only the dependencies of a set of+-- targets. It may be the case that removing a package leaves something else+-- that still needed the pruned package.+--+-- This lists all the packages that would be broken, and their dependencies+-- that would be missing if we did prune.+--+newtype CannotPruneDependencies =+        CannotPruneDependencies [(ElaboratedPlanPackage,+                                  [ElaboratedPlanPackage])]+#if MIN_VERSION_base(4,8,0)+  deriving (Show, Typeable)+#else+  deriving (Typeable)++instance Show CannotPruneDependencies where+  show = renderCannotPruneDependencies+#endif++instance Exception CannotPruneDependencies where+#if MIN_VERSION_base(4,8,0)+  displayException = renderCannotPruneDependencies+#endif++renderCannotPruneDependencies :: CannotPruneDependencies -> String+renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) =+      "Cannot select only the dependencies (as requested by the "+   ++ "'--only-dependencies' flag), "+   ++ (case pkgids of+          [pkgid] -> "the package " ++ display pkgid ++ " is "+          _       -> "the packages "+                     ++ intercalate ", " (map display pkgids) ++ " are ")+   ++ "required by a dependency of one of the other targets."+  where+    -- throw away the details and just list the deps that are needed+    pkgids :: [PackageId]+    pkgids = nub . map packageId . concatMap snd $ brokenPackages+++---------------------------+-- Setup.hs script policy+--++-- Handling for Setup.hs scripts is a bit tricky, part of it lives in the+-- solver phase, and part in the elaboration phase. We keep the helper+-- functions for both phases together here so at least you can see all of it+-- in one place.+--+-- There are four major cases for Setup.hs handling:+--+--  1. @build-type@ Custom with a @custom-setup@ section+--  2. @build-type@ Custom without a @custom-setup@ section+--  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@+--  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@+--+-- It's also worth noting that packages specifying @cabal-version: >= 1.23@+-- or later that have @build-type@ Custom will always have a @custom-setup@+-- section. Therefore in case 2, the specified @cabal-version@ will always be+-- less than 1.23.+--+-- In cases 1 and 2 we obviously have to build an external Setup.hs script,+-- while in case 4 we can use the internal library API. In case 3 we also have+-- to build an external Setup.hs script because the package needs a later+-- Cabal lib version than we can support internally.+--+-- data SetupScriptStyle = ...  -- see ProjectPlanning.Types++-- | Work out the 'SetupScriptStyle' given the package description.+--+packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle+packageSetupScriptStyle pkg+  | buildType == PD.Custom+  , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza+  , not (PD.defaultSetupDepends setupbi)  -- but not one we added internally+  = SetupCustomExplicitDeps++  | buildType == PD.Custom+  , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as+  , PD.defaultSetupDepends setupbi        -- the solver fills in the deps+  = SetupCustomImplicitDeps++  | buildType == PD.Custom+  , Nothing <- PD.setupBuildInfo pkg      -- we get this case pre-solver+  = SetupCustomImplicitDeps++  | PD.specVersion pkg > cabalVersion -- one cabal-install is built against+  = SetupNonCustomExternalLib++  | otherwise+  = SetupNonCustomInternalLib+  where+    buildType = fromMaybe PD.Custom (PD.buildType pkg)+++-- | Part of our Setup.hs handling policy is implemented by getting the solver+-- to work out setup dependencies for packages. The solver already handles+-- packages that explicitly specify setup dependencies, but we can also tell+-- the solver to treat other packages as if they had setup dependencies.+-- That's what this function does, it gets called by the solver for all+-- packages that don't already have setup dependencies.+--+-- The dependencies we want to add is different for each 'SetupScriptStyle'.+--+-- Note that adding default deps means these deps are actually /added/ to the+-- packages that we get out of the solver in the 'SolverInstallPlan'. Making+-- implicit setup deps explicit is a problem in the post-solver stages because+-- we still need to distinguish the case of explicit and implict setup deps.+-- See 'rememberImplicitSetupDeps'.+--+defaultSetupDeps :: Compiler -> Platform+                 -> PD.PackageDescription+                 -> Maybe [Dependency]+defaultSetupDeps compiler platform pkg =+    case packageSetupScriptStyle pkg of++      -- For packages with build type custom that do not specify explicit+      -- setup dependencies, we add a dependency on Cabal and a number+      -- of other packages.+      SetupCustomImplicitDeps ->+        Just $+        [ Dependency depPkgname anyVersion+        | depPkgname <- legacyCustomSetupPkgs compiler platform ] +++        [ Dependency cabalPkgname cabalConstraint+        | packageName pkg /= cabalPkgname ]+        where+          -- The Cabal dep is slightly special:+          -- * We omit the dep for the Cabal lib itself, since it bootstraps.+          -- * We constrain it to be >= 1.18 < 2+          --+          -- Note: cabalCompatMinVer only gets applied WHEN WE ARE ADDING a+          -- default setup build info, i.e., when there is no custom-setup+          -- stanza. If there is a custom-setup stanza, this codepath never gets+          -- invoked (that's why there's an error case for+          -- SetupCustomExplicitDeps).+          --+          -- One way we could solve this problem is by also modifying+          -- custom-setup stanzas when they exist, but we're going to take a+          -- different approach: add an extra constraint on Cabal globally to+          -- make sure the solver respects it regardless of whether or not there+          -- is an explicit setup build info or not. See planPackages.+          cabalConstraint   = orLaterVersion cabalCompatMinVer+                                `intersectVersionRanges`+                              orLaterVersion (PD.specVersion pkg)+                                `intersectVersionRanges`+                              earlierVersion cabalCompatMaxVer+          -- The idea here is that at some point we will make significant+          -- breaking changes to the Cabal API that Setup.hs scripts use.+          -- So for old custom Setup scripts that do not specify explicit+          -- constraints, we constrain them to use a compatible Cabal version.+          cabalCompatMaxVer = mkVersion [1,25]+          -- In principle we can talk to any old Cabal version, and we need to+          -- be able to do that for custom Setup scripts that require older+          -- Cabal lib versions. However in practice we have currently have+          -- problems with Cabal-1.16. (1.16 does not know about build targets)+          -- If this is fixed we can relax this constraint.+          cabalCompatMinVer = mkVersion [1,18]++      -- For other build types (like Simple) if we still need to compile an+      -- external Setup.hs, it'll be one of the simple ones that only depends+      -- on Cabal and base.+      SetupNonCustomExternalLib ->+        Just [ Dependency cabalPkgname cabalConstraint+             , Dependency basePkgname  anyVersion ]+        where+          cabalConstraint = orLaterVersion (PD.specVersion pkg)++      -- The internal setup wrapper method has no deps at all.+      SetupNonCustomInternalLib -> Just []++      -- This case gets ruled out by the caller, planPackages, see the note+      -- above in the SetupCustomIplicitDeps case.+      SetupCustomExplicitDeps ->+        error $ "defaultSetupDeps: called for a package with explicit "+             ++ "setup deps: " ++ display (packageId pkg)+++-- | Work out which version of the Cabal spec we will be using to talk to the+-- Setup.hs interface for this package.+--+-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result+-- of what the solver picked for us, based on the explicit setup deps or the+-- ones added implicitly by 'defaultSetupDeps'.+--+packageSetupScriptSpecVersion :: Package pkg+                              => SetupScriptStyle+                              -> PD.PackageDescription+                              -> ComponentDeps [pkg]+                              -> Version++-- We're going to be using the internal Cabal library, so the spec version of+-- that is simply the version of the Cabal library that cabal-install has been+-- built with.+packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ =+    cabalVersion++-- If we happen to be building the Cabal lib itself then because that+-- bootstraps itself then we use the version of the lib we're building.+packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _+  | packageName pkg == cabalPkgname+  = packageVersion pkg++-- In all other cases we have a look at what version of the Cabal lib the+-- solver picked. Or if it didn't depend on Cabal at all (which is very rare)+-- then we look at the .cabal file to see what spec version it declares.+packageSetupScriptSpecVersion _ pkg deps =+    case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of+      Just dep -> packageVersion dep+      Nothing  -> PD.specVersion pkg+++cabalPkgname, basePkgname :: PackageName+cabalPkgname = mkPackageName "Cabal"+basePkgname  = mkPackageName "base"+++legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName]+legacyCustomSetupPkgs compiler (Platform _ os) =+    map mkPackageName $+        [ "array", "base", "binary", "bytestring", "containers"+        , "deepseq", "directory", "filepath", "old-time", "pretty"+        , "process", "time", "transformers" ]+     ++ [ "Win32" | os == Windows ]+     ++ [ "unix"  | os /= Windows ]+     ++ [ "ghc-prim"         | isGHC ]+     ++ [ "template-haskell" | isGHC ]+  where+    isGHC = compilerCompatFlavor GHC compiler++-- The other aspects of our Setup.hs policy lives here where we decide on+-- the 'SetupScriptOptions'.+--+-- Our current policy for the 'SetupCustomImplicitDeps' case is that we+-- try to make the implicit deps cover everything, and we don't allow the+-- compiler to pick up other deps. This may or may not be sustainable, and+-- we might have to allow the deps to be non-exclusive, but that itself would+-- be tricky since we would have to allow the Setup access to all the packages+-- in the store and local dbs.++setupHsScriptOptions :: ElaboratedReadyPackage+                     -> ElaboratedSharedConfig+                     -> FilePath+                     -> FilePath+                     -> Bool+                     -> Lock+                     -> SetupScriptOptions+-- TODO: Fix this so custom is a separate component.  Custom can ALWAYS+-- be a separate component!!!+setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..})+                     ElaboratedSharedConfig{..} srcdir builddir+                     isParallelBuild cacheLock =+    SetupScriptOptions {+      useCabalVersion          = thisVersion elabSetupScriptCliVersion,+      useCabalSpecVersion      = Just elabSetupScriptCliVersion,+      useCompiler              = Just pkgConfigCompiler,+      usePlatform              = Just pkgConfigPlatform,+      usePackageDB             = elabSetupPackageDBStack,+      usePackageIndex          = Nothing,+      useDependencies          = [ (uid, srcid)+                                 | ConfiguredId srcid uid+                                 <- elabSetupDependencies elab ],+      useDependenciesExclusive = True,+      useVersionMacros         = elabSetupScriptStyle == SetupCustomExplicitDeps,+      useProgramDb             = pkgConfigCompilerProgs,+      useDistPref              = builddir,+      useLoggingHandle         = Nothing, -- this gets set later+      useWorkingDir            = Just srcdir,+      useExtraPathEnv          = elabExeDependencyPaths elab,+      useWin32CleanHack        = False,   --TODO: [required eventually]+      forceExternalSetupMethod = isParallelBuild,+      setupCacheLock           = Just cacheLock,+      isInteractive            = False+    }+++-- | To be used for the input for elaborateInstallPlan.+--+-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure.+--+userInstallDirTemplates :: Compiler+                        -> IO InstallDirs.InstallDirTemplates+userInstallDirTemplates compiler = do+    InstallDirs.defaultInstallDirs+                  (compilerFlavor compiler)+                  True  -- user install+                  False -- unused++storePackageInstallDirs :: CabalDirLayout+                        -> CompilerId+                        -> InstalledPackageId+                        -> InstallDirs.InstallDirs FilePath+storePackageInstallDirs CabalDirLayout{cabalStorePackageDirectory}+                        compid ipkgid =+    InstallDirs.InstallDirs {..}+  where+    prefix       = cabalStorePackageDirectory compid ipkgid+    bindir       = prefix </> "bin"+    libdir       = prefix </> "lib"+    libsubdir    = ""+    dynlibdir    = libdir+    flibdir      = libdir+    libexecdir   = prefix </> "libexec"+    includedir   = libdir </> "include"+    datadir      = prefix </> "share"+    datasubdir   = ""+    docdir       = datadir </> "doc"+    mandir       = datadir </> "man"+    htmldir      = docdir  </> "html"+    haddockdir   = htmldir+    sysconfdir   = prefix </> "etc"+++--TODO: [code cleanup] perhaps reorder this code+-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig,+-- make the various Setup.hs {configure,build,copy} flags+++setupHsConfigureFlags :: ElaboratedReadyPackage+                      -> ElaboratedSharedConfig+                      -> Verbosity+                      -> FilePath+                      -> Cabal.ConfigFlags+setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..})+                      sharedConfig@ElaboratedSharedConfig{..}+                      verbosity builddir =+    sanityCheckElaboratedConfiguredPackage sharedConfig elab+        (Cabal.ConfigFlags {..})+  where+    configArgs                = mempty -- unused, passed via args+    configDistPref            = toFlag builddir+    configCabalFilePath       = mempty+    configVerbosity           = toFlag verbosity++    configInstantiateWith     = Map.toList elabInstantiatedWith++    configIPID                = case elabPkgOrComp of+                                  ElabPackage pkg -> toFlag (display (pkgInstalledId pkg))+                                  ElabComponent _ -> mempty+    configCID                 = case elabPkgOrComp of+                                  ElabPackage _ -> mempty+                                  ElabComponent _ -> toFlag elabComponentId++    configProgramPaths        = Map.toList elabProgramPaths+    configProgramArgs         = Map.toList elabProgramArgs+    configProgramPathExtra    = toNubList elabProgramPathExtra+    configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)+    configHcPath              = mempty -- we use configProgramPaths instead+    configHcPkg               = mempty -- we use configProgramPaths instead++    configVanillaLib          = toFlag elabVanillaLib+    configSharedLib           = toFlag elabSharedLib+    configDynExe              = toFlag elabDynExe+    configGHCiLib             = toFlag elabGHCiLib+    configProfExe             = mempty+    configProfLib             = toFlag elabProfLib+    configProf                = toFlag elabProfExe++    -- configProfDetail is for exe+lib, but overridden by configProfLibDetail+    -- so we specify both so we can specify independently+    configProfDetail          = toFlag elabProfExeDetail+    configProfLibDetail       = toFlag elabProfLibDetail++    configCoverage            = toFlag elabCoverage+    configLibCoverage         = mempty++    configOptimization        = toFlag elabOptimization+    configSplitObjs           = toFlag elabSplitObjs+    configStripExes           = toFlag elabStripExes+    configStripLibs           = toFlag elabStripLibs+    configDebugInfo           = toFlag elabDebugInfo+    configAllowOlder          = mempty -- we use configExactConfiguration True+    configAllowNewer          = mempty -- we use configExactConfiguration True++    configConfigurationsFlags = elabFlagAssignment+    configConfigureArgs       = elabConfigureScriptArgs+    configExtraLibDirs        = elabExtraLibDirs+    configExtraFrameworkDirs  = elabExtraFrameworkDirs+    configExtraIncludeDirs    = elabExtraIncludeDirs+    configProgPrefix          = maybe mempty toFlag elabProgPrefix+    configProgSuffix          = maybe mempty toFlag elabProgSuffix++    configInstallDirs         = fmap (toFlag . InstallDirs.toPathTemplate)+                                     elabInstallDirs++    -- we only use configDependencies, unless we're talking to an old Cabal+    -- in which case we use configConstraints+    -- NB: This does NOT use InstallPlan.depends, which includes executable+    -- dependencies which should NOT be fed in here (also you don't have+    -- enough info anyway)+    configDependencies        = [ (packageName srcid, cid)+                                | ConfiguredId srcid cid <- elabLibDependencies elab ]+    configConstraints         =+        case elabPkgOrComp of+            ElabPackage _ ->+                [ thisPackageVersion srcid+                | ConfiguredId srcid _uid <- elabLibDependencies elab ]+            ElabComponent _ -> []+++    -- explicitly clear, then our package db stack+    -- TODO: [required eventually] have to do this differently for older Cabal versions+    configPackageDBs          = Nothing : map Just elabBuildPackageDBStack++    configTests               = case elabPkgOrComp of+                                    ElabPackage pkg -> toFlag (TestStanzas  `Set.member` pkgStanzasEnabled pkg)+                                    ElabComponent _ -> mempty+    configBenchmarks          = case elabPkgOrComp of+                                    ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg)+                                    ElabComponent _ -> mempty++    configExactConfiguration  = toFlag True+    configFlagError           = mempty --TODO: [research required] appears not to be implemented+    configRelocatable         = mempty --TODO: [research required] ???+    configScratchDir          = mempty -- never use+    configUserInstall         = mempty -- don't rely on defaults+    configPrograms_           = mempty -- never use, shouldn't exist+++setupHsConfigureArgs :: ElaboratedConfiguredPackage+                     -> [String]+setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = []+setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) =+    [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)]+  where+    cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup")+                      (compComponentName comp)++setupHsBuildFlags :: ElaboratedConfiguredPackage+                  -> ElaboratedSharedConfig+                  -> Verbosity+                  -> FilePath+                  -> Cabal.BuildFlags+setupHsBuildFlags _ _ verbosity builddir =+    Cabal.BuildFlags {+      buildProgramPaths = mempty, --unused, set at configure time+      buildProgramArgs  = mempty, --unused, set at configure time+      buildVerbosity    = toFlag verbosity,+      buildDistPref     = toFlag builddir,+      buildNumJobs      = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),+      buildArgs         = mempty  -- unused, passed via args not flags+    }+++setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]+setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ })+    -- Fix for #3335, don't pass build arguments if it's not supported+    | elabSetupScriptCliVersion elab >= mkVersion [1,17]+    = map (showComponentTarget (packageId elab)) (elabBuildTargets elab)+    | otherwise+    = []+setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ })+    = []+++setupHsReplFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.ReplFlags+setupHsReplFlags _ _ verbosity builddir =+    Cabal.ReplFlags {+      replProgramPaths = mempty, --unused, set at configure time+      replProgramArgs  = mempty, --unused, set at configure time+      replVerbosity    = toFlag verbosity,+      replDistPref     = toFlag builddir,+      replReload       = mempty  --only used as callback from repl+    }+++setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]+setupHsReplArgs elab =+    maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab)+    --TODO: should be able to give multiple modules in one component+++setupHsCopyFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.CopyFlags+setupHsCopyFlags _ _ verbosity builddir =+    Cabal.CopyFlags {+      --TODO: [nice to have] we currently just rely on Setup.hs copy to always do the right+      -- thing, but perhaps we ought really to copy into an image dir and do+      -- some sanity checks and move into the final location ourselves+      copyArgs      = [], -- TODO: could use this to only copy what we enabled+      copyDest      = toFlag InstallDirs.NoCopyDest,+      copyDistPref  = toFlag builddir,+      copyVerbosity = toFlag verbosity+    }++setupHsRegisterFlags :: ElaboratedConfiguredPackage+                     -> ElaboratedSharedConfig+                     -> Verbosity+                     -> FilePath+                     -> FilePath+                     -> Cabal.RegisterFlags+setupHsRegisterFlags ElaboratedConfiguredPackage{..} _+                     verbosity builddir pkgConfFile =+    Cabal.RegisterFlags {+      regPackageDB   = mempty,  -- misfeature+      regGenScript   = mempty,  -- never use+      regGenPkgConf  = toFlag (Just pkgConfFile),+      regInPlace     = case elabBuildStyle of+                         BuildInplaceOnly -> toFlag True+                         _                -> toFlag False,+      regPrintId     = mempty,  -- never use+      regDistPref    = toFlag builddir,+      regArgs        = [],+      regVerbosity   = toFlag verbosity+    }++setupHsHaddockFlags :: ElaboratedConfiguredPackage+                    -> ElaboratedSharedConfig+                    -> Verbosity+                    -> FilePath+                    -> Cabal.HaddockFlags+-- TODO: reconsider whether or not Executables/TestSuites/...+-- needed for component+setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir =+    Cabal.HaddockFlags {+      haddockProgramPaths  = mempty, --unused, set at configure time+      haddockProgramArgs   = mempty, --unused, set at configure time+      haddockHoogle        = toFlag elabHaddockHoogle,+      haddockHtml          = toFlag elabHaddockHtml,+      haddockHtmlLocation  = maybe mempty toFlag elabHaddockHtmlLocation,+      haddockForHackage    = mempty, --TODO: new flag+      haddockForeignLibs   = toFlag elabHaddockForeignLibs,+      haddockExecutables   = toFlag elabHaddockExecutables,+      haddockTestSuites    = toFlag elabHaddockTestSuites,+      haddockBenchmarks    = toFlag elabHaddockBenchmarks,+      haddockInternal      = toFlag elabHaddockInternal,+      haddockCss           = maybe mempty toFlag elabHaddockCss,+      haddockHscolour      = toFlag elabHaddockHscolour,+      haddockHscolourCss   = maybe mempty toFlag elabHaddockHscolourCss,+      haddockContents      = maybe mempty toFlag elabHaddockContents,+      haddockDistPref      = toFlag builddir,+      haddockKeepTempFiles = mempty, --TODO: from build settings+      haddockVerbosity     = toFlag verbosity+    }++{-+setupHsTestFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.TestFlags+setupHsTestFlags _ _ verbosity builddir =+    Cabal.TestFlags {+    }+-}++------------------------------------------------------------------------------+-- * Sharing installed packages+------------------------------------------------------------------------------++--+-- Nix style store management for tarball packages+--+-- So here's our strategy:+--+-- We use a per-user nix-style hashed store, but /only/ for tarball packages.+-- So that includes packages from hackage repos (and other http and local+-- tarballs). For packages in local directories we do not register them into+-- the shared store by default, we just build them locally inplace.+--+-- The reason we do it like this is that it's easy to make stable hashes for+-- tarball packages, and these packages benefit most from sharing. By contrast+-- unpacked dir packages are harder to hash and they tend to change more+-- frequently so there's less benefit to sharing them.+--+-- When using the nix store approach we have to run the solver *without*+-- looking at the packages installed in the store, just at the source packages+-- (plus core\/global installed packages). Then we do a post-processing pass+-- to replace configured packages in the plan with pre-existing ones, where+-- possible. Where possible of course means where the nix-style package hash+-- equals one that's already in the store.+--+-- One extra wrinkle is that unless we know package tarball hashes upfront, we+-- will have to download the tarballs to find their hashes. So we have two+-- options: delay replacing source with pre-existing installed packages until+-- the point during the execution of the install plan where we have the+-- tarball, or try to do as much up-front as possible and then check again+-- during plan execution. The former isn't great because we would end up+-- telling users we're going to re-install loads of packages when in fact we+-- would just share them. It'd be better to give as accurate a prediction as+-- we can. The latter is better for users, but we do still have to check+-- during plan execution because it's important that we don't replace existing+-- installed packages even if they have the same package hash, because we+-- don't guarantee ABI stability.++-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but+-- not replace installed packages with ghc-pkg.++packageHashInputs :: ElaboratedSharedConfig+                  -> ElaboratedConfiguredPackage+                  -> PackageHashInputs+packageHashInputs+    pkgshared+    elab@(ElaboratedConfiguredPackage {+      elabPkgSourceHash = Just srchash+    }) =+    PackageHashInputs {+      pkgHashPkgId       = packageId elab,+      pkgHashComponent   =+        case elabPkgOrComp elab of+          ElabPackage _ -> Nothing+          ElabComponent comp -> Just (compSolverName comp),+      pkgHashSourceHash  = srchash,+      pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab),+      pkgHashDirectDeps  =+        case elabPkgOrComp elab of+          ElabPackage (ElaboratedPackage{..}) ->+            Set.fromList $+             [ confInstId dep+             | dep <- CD.select relevantDeps pkgLibDependencies ] +++             [ confInstId dep+             | dep <- CD.select relevantDeps pkgExeDependencies ]+          ElabComponent comp ->+            Set.fromList (map confInstId (compLibDependencies comp)+                                       ++ compExeDependencies comp),+      pkgHashOtherConfig = packageHashConfigInputs pkgshared elab+    }+  where+    -- Obviously the main deps are relevant+    relevantDeps CD.ComponentLib       = True+    relevantDeps (CD.ComponentSubLib _) = True+    relevantDeps (CD.ComponentFLib _)   = True+    relevantDeps (CD.ComponentExe _)   = True+    -- Setup deps can affect the Setup.hs behaviour and thus what is built+    relevantDeps  CD.ComponentSetup    = True+    -- However testsuites and benchmarks do not get installed and should not+    -- affect the result, so we do not include them.+    relevantDeps (CD.ComponentTest  _) = False+    relevantDeps (CD.ComponentBench _) = False++packageHashInputs _ pkg =+    error $ "packageHashInputs: only for packages with source hashes. "+         ++ display (packageId pkg)++packageHashConfigInputs :: ElaboratedSharedConfig+                        -> ElaboratedConfiguredPackage+                        -> PackageHashConfigInputs+packageHashConfigInputs+    ElaboratedSharedConfig{..}+    ElaboratedConfiguredPackage{..} =++    PackageHashConfigInputs {+      pkgHashCompilerId          = compilerId pkgConfigCompiler,+      pkgHashPlatform            = pkgConfigPlatform,+      pkgHashFlagAssignment      = elabFlagAssignment,+      pkgHashConfigureScriptArgs = elabConfigureScriptArgs,+      pkgHashVanillaLib          = elabVanillaLib,+      pkgHashSharedLib           = elabSharedLib,+      pkgHashDynExe              = elabDynExe,+      pkgHashGHCiLib             = elabGHCiLib,+      pkgHashProfLib             = elabProfLib,+      pkgHashProfExe             = elabProfExe,+      pkgHashProfLibDetail       = elabProfLibDetail,+      pkgHashProfExeDetail       = elabProfExeDetail,+      pkgHashCoverage            = elabCoverage,+      pkgHashOptimization        = elabOptimization,+      pkgHashSplitObjs           = elabSplitObjs,+      pkgHashStripLibs           = elabStripLibs,+      pkgHashStripExes           = elabStripExes,+      pkgHashDebugInfo           = elabDebugInfo,+      pkgHashProgramArgs         = elabProgramArgs,+      pkgHashExtraLibDirs        = elabExtraLibDirs,+      pkgHashExtraFrameworkDirs  = elabExtraFrameworkDirs,+      pkgHashExtraIncludeDirs    = elabExtraIncludeDirs,+      pkgHashProgPrefix          = elabProgPrefix,+      pkgHashProgSuffix          = elabProgSuffix+    }+++-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an+-- 'ElaboratedInstallPlan', replace configured source packages by installed+-- packages from the store whenever they exist.+--+improveInstallPlanWithInstalledPackages :: Set UnitId+                                        -> ElaboratedInstallPlan+                                        -> ElaboratedInstallPlan+improveInstallPlanWithInstalledPackages installedPkgIdSet =+    InstallPlan.installed canPackageBeImproved+  where+    canPackageBeImproved pkg =+      installedUnitId pkg `Set.member` installedPkgIdSet+    --TODO: sanity checks:+    -- * the installed package must have the expected deps etc+    -- * the installed package must not be broken, valid dep closure++    --TODO: decide what to do if we encounter broken installed packages,+    -- since overwriting is never safe.+
+ cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs view
@@ -0,0 +1,608 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}++-- | Types used while planning how to build everything in a project.+--+-- Primarily this is the 'ElaboratedInstallPlan'.+--+module Distribution.Client.ProjectPlanning.Types (+    SolverInstallPlan,++    -- * Elaborated install plan types+    ElaboratedInstallPlan,+    ElaboratedConfiguredPackage(..),++    elabDistDirParams,+    elabExeDependencyPaths,+    elabLibDependencies,+    elabOrderLibDependencies,+    elabExeDependencies,+    elabOrderExeDependencies,+    elabSetupDependencies,+    elabPkgConfigDependencies,++    elabPlanPackageName,+    elabConfiguredName,++    ElaboratedPackageOrComponent(..),+    ElaboratedComponent(..),+    ElaboratedPackage(..),+    pkgOrderDependencies,+    ElaboratedPlanPackage,+    ElaboratedSharedConfig(..),+    ElaboratedReadyPackage,+    BuildStyle(..),+    CabalFileText,++    -- * Build targets+    PackageTarget(..),+    ComponentTarget(..),+    showComponentTarget,+    SubComponentTarget(..),++    -- * Setup script+    SetupScriptStyle(..),+  ) where++import           Distribution.Client.PackageHash++import           Distribution.Client.Types+import           Distribution.Client.InstallPlan+                   ( GenericInstallPlan, GenericPlanPackage(..) )+import           Distribution.Client.SolverInstallPlan+                   ( SolverInstallPlan )+import           Distribution.Client.DistDirLayout++import           Distribution.Backpack+import           Distribution.Backpack.ModuleShape++import           Distribution.Verbosity+import           Distribution.Text+import           Distribution.Types.ComponentRequestedSpec+import           Distribution.Package+                   hiding (InstalledPackageId, installedPackageId)+import           Distribution.System+import qualified Distribution.PackageDescription as Cabal+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import           Distribution.Simple.Compiler+import qualified Distribution.Simple.BuildTarget as Cabal+import           Distribution.Simple.Program.Db+import           Distribution.ModuleName (ModuleName)+import           Distribution.Simple.LocalBuildInfo (ComponentName(..))+import qualified Distribution.Simple.InstallDirs as InstallDirs+import           Distribution.Simple.InstallDirs (PathTemplate)+import           Distribution.Version++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Compat.Graph (IsNode(..))+import           Distribution.Simple.Utils (ordNub)++import           Data.Map (Map)+import           Data.Set (Set)+import qualified Data.ByteString.Lazy as LBS+import           Distribution.Compat.Binary+import           GHC.Generics (Generic)+import qualified Data.Monoid as Mon+import           Data.Typeable++++-- | The combination of an elaborated install plan plus a+-- 'ElaboratedSharedConfig' contains all the details necessary to be able+-- to execute the plan without having to make further policy decisions.+--+-- It does not include dynamic elements such as resources (such as http+-- connections).+--+type ElaboratedInstallPlan+   = GenericInstallPlan InstalledPackageInfo+                        ElaboratedConfiguredPackage++type ElaboratedPlanPackage+   = GenericPlanPackage InstalledPackageInfo+                        ElaboratedConfiguredPackage++-- | User-friendly display string for an 'ElaboratedPlanPackage'.+elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String+elabPlanPackageName verbosity (PreExisting ipkg)+    | verbosity <= normal = display (packageName ipkg)+    | otherwise           = display (installedUnitId ipkg)+elabPlanPackageName verbosity (Configured elab)+    = elabConfiguredName verbosity elab+elabPlanPackageName verbosity (Installed elab)+    = elabConfiguredName verbosity elab++--TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle+--      even platform and compiler could be different if we're building things+--      like a server + client with ghc + ghcjs+data ElaboratedSharedConfig+   = ElaboratedSharedConfig {++       pkgConfigPlatform      :: Platform,+       pkgConfigCompiler      :: Compiler, --TODO: [code cleanup] replace with CompilerInfo+       -- | The programs that the compiler configured (e.g. for GHC, the progs+       -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are+       -- used.+       pkgConfigCompilerProgs :: ProgramDb+     }+  deriving (Show, Generic, Typeable)+  --TODO: [code cleanup] no Eq instance++instance Binary ElaboratedSharedConfig++data ElaboratedConfiguredPackage+   = ElaboratedConfiguredPackage {+       -- | The 'UnitId' which uniquely identifies this item in a build plan+       elabUnitId        :: UnitId,++       elabComponentId :: ComponentId,+       elabInstantiatedWith :: Map ModuleName Module,+       elabLinkedInstantiatedWith :: Map ModuleName OpenModule,++       -- | The 'PackageId' of the originating package+       elabPkgSourceId    :: PackageId,++       -- | Mapping from 'PackageName's to 'ComponentName', for every+       -- package that is overloaded with an internal component name+       elabInternalPackages :: Map PackageName ComponentName,++       -- | Shape of the package/component, for Backpack.+       elabModuleShape    :: ModuleShape,++       -- | A total flag assignment for the package.+       -- TODO: Actually this can be per-component if we drop+       -- all flags that don't affect a component.+       elabFlagAssignment   :: Cabal.FlagAssignment,++       -- | The original default flag assignment, used only for reporting.+       elabFlagDefaults     :: Cabal.FlagAssignment,++       elabPkgDescription :: Cabal.PackageDescription,++       -- | Where the package comes from, e.g. tarball, local dir etc. This+       --   is not the same as where it may be unpacked to for the build.+       elabPkgSourceLocation :: PackageLocation (Maybe FilePath),++       -- | The hash of the source, e.g. the tarball. We don't have this for+       -- local source dir packages.+       elabPkgSourceHash     :: Maybe PackageSourceHash,++       -- | Is this package one of the ones specified by location in the+       -- project file? (As opposed to a dependency, or a named package pulled+       -- in)+       elabLocalToProject         :: Bool,++       -- | Are we going to build and install this package to the store, or are+       -- we going to build it and register it locally.+       elabBuildStyle             :: BuildStyle,++       -- | Another way of phrasing 'pkgStanzasAvailable'.+       elabEnabledSpec      :: ComponentRequestedSpec,++       -- | Which optional stanzas (ie testsuites, benchmarks) can be built.+       -- This means the solver produced a plan that has them available.+       -- This doesn't necessary mean we build them by default.+       elabStanzasAvailable :: Set OptionalStanza,++       -- | Which optional stanzas the user explicitly asked to enable or+       -- to disable. This tells us which ones we build by default, and+       -- helps with error messages when the user asks to build something+       -- they explicitly disabled.+       --+       -- TODO: The 'Bool' here should be refined into an ADT with three+       -- cases: NotRequested, ExplicitlyRequested and+       -- ImplicitlyRequested.  A stanza is explicitly requested if+       -- the user asked, for this *specific* package, that the stanza+       -- be enabled; it's implicitly requested if the user asked for+       -- all global packages to have this stanza enabled.  The+       -- difference between an explicit and implicit request is+       -- error reporting behavior: if a user asks for tests to be+       -- enabled for a specific package that doesn't have any tests,+       -- we should warn them about it, but we shouldn't complain+       -- that a user enabled tests globally, and some local packages+       -- just happen not to have any tests.  (But perhaps we should+       -- warn if ALL local packages don't have any tests.)+       elabStanzasRequested :: Map OptionalStanza Bool,++       elabSetupPackageDBStack    :: PackageDBStack,+       elabBuildPackageDBStack    :: PackageDBStack,+       elabRegisterPackageDBStack :: PackageDBStack,++       -- | The package/component contains/is a library and so must be registered+       elabRequiresRegistration :: Bool,++       elabPkgDescriptionOverride  :: Maybe CabalFileText,++       -- TODO: make per-component variants of these flags+       elabVanillaLib           :: Bool,+       elabSharedLib            :: Bool,+       elabDynExe               :: Bool,+       elabGHCiLib              :: Bool,+       elabProfLib              :: Bool,+       elabProfExe              :: Bool,+       elabProfLibDetail        :: ProfDetailLevel,+       elabProfExeDetail        :: ProfDetailLevel,+       elabCoverage             :: Bool,+       elabOptimization         :: OptimisationLevel,+       elabSplitObjs            :: Bool,+       elabStripLibs            :: Bool,+       elabStripExes            :: Bool,+       elabDebugInfo            :: DebugInfoLevel,++       elabProgramPaths          :: Map String FilePath,+       elabProgramArgs           :: Map String [String],+       elabProgramPathExtra      :: [FilePath],+       elabConfigureScriptArgs   :: [String],+       elabExtraLibDirs          :: [FilePath],+       elabExtraFrameworkDirs    :: [FilePath],+       elabExtraIncludeDirs      :: [FilePath],+       elabProgPrefix            :: Maybe PathTemplate,+       elabProgSuffix            :: Maybe PathTemplate,++       elabInstallDirs           :: InstallDirs.InstallDirs FilePath,++       elabHaddockHoogle         :: Bool,+       elabHaddockHtml           :: Bool,+       elabHaddockHtmlLocation   :: Maybe String,+       elabHaddockForeignLibs    :: Bool,+       elabHaddockExecutables    :: Bool,+       elabHaddockTestSuites     :: Bool,+       elabHaddockBenchmarks     :: Bool,+       elabHaddockInternal       :: Bool,+       elabHaddockCss            :: Maybe FilePath,+       elabHaddockHscolour       :: Bool,+       elabHaddockHscolourCss    :: Maybe FilePath,+       elabHaddockContents       :: Maybe PathTemplate,++       -- Setup.hs related things:++       -- | One of four modes for how we build and interact with the Setup.hs+       -- script, based on whether it's a build-type Custom, with or without+       -- explicit deps and the cabal spec version the .cabal file needs.+       elabSetupScriptStyle      :: SetupScriptStyle,++       -- | The version of the Cabal command line interface that we are using+       -- for this package. This is typically the version of the Cabal lib+       -- that the Setup.hs is built against.+       elabSetupScriptCliVersion :: Version,++       -- Build time related:+       elabBuildTargets          :: [ComponentTarget],+       elabReplTarget            :: Maybe ComponentTarget,+       elabBuildHaddocks         :: Bool,++       --pkgSourceDir ? -- currently passed in later because they can use temp locations+       --pkgBuildDir  ? -- but could in principle still have it here, with optional instr to use temp loc++       -- | Component/package specific information+       elabPkgOrComp :: ElaboratedPackageOrComponent+   }+  deriving (Eq, Show, Generic, Typeable)++instance Package ElaboratedConfiguredPackage where+  packageId = elabPkgSourceId++instance HasConfiguredId ElaboratedConfiguredPackage where+  configuredId elab = ConfiguredId (packageId elab) (elabComponentId elab)++instance HasUnitId ElaboratedConfiguredPackage where+  installedUnitId = elabUnitId++instance IsNode ElaboratedConfiguredPackage where+    type Key ElaboratedConfiguredPackage = UnitId+    nodeKey = elabUnitId+    nodeNeighbors = elabOrderDependencies++instance Binary ElaboratedConfiguredPackage++data ElaboratedPackageOrComponent+    = ElabPackage   ElaboratedPackage+    | ElabComponent ElaboratedComponent+  deriving (Eq, Show, Generic)++instance Binary ElaboratedPackageOrComponent++-- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'.+elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String+elabConfiguredName verbosity elab+    | verbosity <= normal+    = (case elabPkgOrComp elab of+        ElabPackage _ -> ""+        ElabComponent comp ->+            case compComponentName comp of+                Nothing -> "setup from "+                Just CLibName -> ""+                Just cname -> display cname ++ " from ")+      ++ display (packageId elab)+    | otherwise+    = display (elabUnitId elab)++elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams+elabDistDirParams shared elab = DistDirParams {+        distParamUnitId = installedUnitId elab,+        distParamComponentId = elabComponentId elab,+        distParamPackageId = elabPkgSourceId elab,+        distParamComponentName = case elabPkgOrComp elab of+            ElabComponent comp -> compComponentName comp+            ElabPackage _ -> Nothing,+        distParamCompilerId = compilerId (pkgConfigCompiler shared),+        distParamPlatform = pkgConfigPlatform shared,+        distParamOptimization = elabOptimization elab+    }++-- | The full set of dependencies which dictate what order we+-- need to build things in the install plan: "order dependencies"+-- balls everything together.  This is mostly only useful for+-- ordering; if you are, for example, trying to compute what+-- @--dependency@ flags to pass to a Setup script, you need to+-- use 'elabLibDependencies'.  This method is the same as+-- 'nodeNeighbors'.+--+-- NB: this method DOES include setup deps.+elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId]+elabOrderDependencies elab =+    case elabPkgOrComp elab of+        -- Important not to have duplicates: otherwise InstallPlan gets+        -- confused.+        ElabPackage pkg    -> ordNub (CD.flatDeps (pkgOrderDependencies pkg))+        ElabComponent comp -> compOrderDependencies comp++-- | Like 'elabOrderDependencies', but only returns dependencies on+-- libraries.+elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId]+elabOrderLibDependencies elab =+    case elabPkgOrComp elab of+        ElabPackage _      -> map (newSimpleUnitId . confInstId) (elabLibDependencies elab)+        ElabComponent comp -> compOrderLibDependencies comp++-- | The library dependencies (i.e., the libraries we depend on, NOT+-- the dependencies of the library), NOT including setup dependencies.+-- These are passed to the @Setup@ script via @--dependency@.+elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]+elabLibDependencies elab =+    case elabPkgOrComp elab of+        ElabPackage pkg    -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg))+        ElabComponent comp -> compLibDependencies comp++-- | Like 'elabOrderDependencies', but only returns dependencies on+-- executables.  (This coincides with 'elabExeDependencies'.)+elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId]+elabOrderExeDependencies =+    map newSimpleUnitId . elabExeDependencies++-- | The executable dependencies (i.e., the executables we depend on);+-- these are the executables we must add to the PATH before we invoke+-- the setup script.+elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId]+elabExeDependencies elab =+    case elabPkgOrComp elab of+        -- TODO: pkgExeDependencies being ConfiguredId is slightly awkward+        ElabPackage pkg    -> map confInstId (CD.nonSetupDeps (pkgExeDependencies pkg))+        ElabComponent comp -> compExeDependencies comp++-- | This returns the paths of all the executables we depend on; we+-- must add these paths to PATH before invoking the setup script.+-- (This is usually what you want, not 'elabExeDependencies', if you+-- actually want to build something.)+elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath]+elabExeDependencyPaths elab =+    case elabPkgOrComp elab of+        ElabPackage pkg    -> CD.nonSetupDeps (pkgExeDependencyPaths pkg)+        ElabComponent comp -> compExeDependencyPaths comp++-- | The setup dependencies (the library dependencies of the setup executable;+-- note that it is not legal for setup scripts to have executable+-- dependencies at the moment.)+elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]+elabSetupDependencies elab =+    case elabPkgOrComp elab of+        ElabPackage pkg    -> CD.setupDeps (pkgLibDependencies pkg)+        ElabComponent comp -> compSetupDependencies comp++elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe Version)]+elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg }+    = pkgPkgConfigDependencies pkg+elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }+    = compPkgConfigDependencies comp++-- | Some extra metadata associated with an+-- 'ElaboratedConfiguredPackage' which indicates that the "package"+-- in question is actually a single component to be built.  Arguably+-- it would be clearer if there were an ADT which branched into+-- package work items and component work items, but I've structured+-- it this way to minimize change to the existing code (which I+-- don't feel qualified to rewrite.)+data ElaboratedComponent+   = ElaboratedComponent {+    -- | The name of the component to be built according to the solver+    compSolverName :: CD.Component,+    -- | The name of the component to be built.  Nothing if+    -- it's a setup dep.+    compComponentName :: Maybe ComponentName,+    -- | The *external* library dependencies of this component.  We+    -- pass this to the configure script.+    compLibDependencies :: [ConfiguredId],+    -- | The linked dependencies of the component which combined with the+    -- substitution in 'elabComponentId' specify the dependencies we+    -- care about from the perspective of ORDERING builds.  It's more+    -- precise than 'compLibDependencies', and also stores information+    -- about internal dependencies.+    compLinkedLibDependencies :: [OpenUnitId],+    -- | The executable dependencies of this component (including+    -- internal executables).+    compExeDependencies :: [ComponentId],+    -- | The @pkg-config@ dependencies of the component+    compPkgConfigDependencies :: [(PkgconfigName, Maybe Version)],+    -- | The paths all our executable dependencies will be installed+    -- to once they are installed.+    compExeDependencyPaths :: [FilePath],+    compNonSetupDependencies :: [UnitId],+    -- | The setup dependencies.  TODO: Remove this when setups+    -- are components of their own.+    compSetupDependencies :: [ConfiguredId]+   }+  deriving (Eq, Show, Generic)++instance Binary ElaboratedComponent++-- | See 'elabOrderDependencies'.+compOrderDependencies :: ElaboratedComponent -> [UnitId]+compOrderDependencies comp =+    compOrderLibDependencies comp+ ++ compOrderExeDependencies comp++-- | See 'elabOrderExeDependencies'.+compOrderExeDependencies :: ElaboratedComponent -> [UnitId]+compOrderExeDependencies = map newSimpleUnitId . compExeDependencies++-- | See 'elabOrderLibDependencies'.+compOrderLibDependencies :: ElaboratedComponent -> [UnitId]+compOrderLibDependencies comp =+    compNonSetupDependencies comp+ ++ map (newSimpleUnitId . confInstId) (compSetupDependencies comp)++data ElaboratedPackage+   = ElaboratedPackage {+       pkgInstalledId :: InstalledPackageId,++       -- | The exact dependencies (on other plan packages)+       --+       pkgLibDependencies :: ComponentDeps [ConfiguredId],++       -- | Dependencies on executable packages.+       --+       pkgExeDependencies :: ComponentDeps [ConfiguredId],++       -- | Paths where executable dependencies live.+       --+       pkgExeDependencyPaths :: ComponentDeps [FilePath],++       -- | Dependencies on @pkg-config@ packages.+       -- NB: this is NOT per-component (although it could be)+       -- because Cabal library does not track per-component+       -- pkg-config depends; it always does them all at once.+       --+       pkgPkgConfigDependencies :: [(PkgconfigName, Maybe Version)],++       -- | Which optional stanzas (ie testsuites, benchmarks) will actually+       -- be enabled during the package configure step.+       pkgStanzasEnabled :: Set OptionalStanza+     }+  deriving (Eq, Show, Generic)++instance Binary ElaboratedPackage++-- | See 'elabOrderDependencies'.  This gives the unflattened version,+-- which can be useful in some circumstances.+pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId]+pkgOrderDependencies pkg =+    fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend`+    fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg)++-- | This is used in the install plan to indicate how the package will be+-- built.+--+data BuildStyle =+    -- | The classic approach where the package is built, then the files+    -- installed into some location and the result registered in a package db.+    --+    -- If the package came from a tarball then it's built in a temp dir and+    -- the results discarded.+    BuildAndInstall++    -- | The package is built, but the files are not installed anywhere,+    -- rather the build dir is kept and the package is registered inplace.+    --+    -- Such packages can still subsequently be installed.+    --+    -- Typically 'BuildAndInstall' packages will only depend on other+    -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones.+    --+  | BuildInplaceOnly+  deriving (Eq, Show, Generic)++instance Binary BuildStyle++type CabalFileText = LBS.ByteString++type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage+++---------------------------+-- Build targets+--++-- | The various targets within a package. This is more of a high level+-- specification than a elaborated prescription.+--+data PackageTarget =+     -- | Build the default components in this package. This usually means+     -- just the lib and exes, but it can also mean the testsuites and+     -- benchmarks if the user explicitly requested them.+     BuildDefaultComponents+     -- | Build a specific component in this package.+   | BuildSpecificComponent ComponentTarget+   | ReplDefaultComponent+   | ReplSpecificComponent  ComponentTarget+   | HaddockDefaultComponents+  deriving (Eq, Show, Generic)++data ComponentTarget = ComponentTarget ComponentName SubComponentTarget+  deriving (Eq, Ord, Show, Generic)++data SubComponentTarget = WholeComponent+                        | ModuleTarget ModuleName+                        | FileTarget   FilePath+  deriving (Eq, Ord, Show, Generic)++instance Binary PackageTarget+instance Binary ComponentTarget+instance Binary SubComponentTarget++-- | Unambiguously render a 'ComponentTarget', e.g., to pass+-- to a Cabal Setup script.+showComponentTarget :: PackageId -> ComponentTarget -> String+showComponentTarget pkgid =+    Cabal.showBuildTarget pkgid . toBuildTarget+  where+    toBuildTarget :: ComponentTarget -> Cabal.BuildTarget+    toBuildTarget (ComponentTarget cname subtarget) =+      case subtarget of+        WholeComponent     -> Cabal.BuildTargetComponent cname+        ModuleTarget mname -> Cabal.BuildTargetModule    cname mname+        FileTarget   fname -> Cabal.BuildTargetFile      cname fname++++---------------------------+-- Setup.hs script policy+--++-- | There are four major cases for Setup.hs handling:+--+--  1. @build-type@ Custom with a @custom-setup@ section+--  2. @build-type@ Custom without a @custom-setup@ section+--  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@+--  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@+--+-- It's also worth noting that packages specifying @cabal-version: >= 1.23@+-- or later that have @build-type@ Custom will always have a @custom-setup@+-- section. Therefore in case 2, the specified @cabal-version@ will always be+-- less than 1.23.+--+-- In cases 1 and 2 we obviously have to build an external Setup.hs script,+-- while in case 4 we can use the internal library API. In case 3 we also have+-- to build an external Setup.hs script because the package needs a later+-- Cabal lib version than we can support internally.+--+data SetupScriptStyle = SetupCustomExplicitDeps+                      | SetupCustomImplicitDeps+                      | SetupNonCustomExternalLib+                      | SetupNonCustomInternalLib+  deriving (Eq, Show, Generic, Typeable)++instance Binary SetupScriptStyle+
cabal/cabal-install/Distribution/Client/RebuildMonad.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | An abstraction for re-running actions if values or files have changed.@@ -13,6 +12,8 @@     -- * Rebuild monad     Rebuild,     runRebuild,+    execRebuild,+    askRoot,      -- * Setting up file monitoring     monitorFiles,@@ -21,12 +22,14 @@     monitorFileHashed,     monitorNonExistentFile,     monitorDirectory,+    monitorNonExistentDirectory,     monitorDirectoryExistence,     monitorFileOrDirectory,     monitorFileSearchPath,     monitorFileHashedSearchPath,     -- ** Monitoring file globs     monitorFileGlob,+    monitorFileGlobExistence,     FilePathGlob(..),     FilePathRoot(..),     FilePathGlobRel(..),@@ -39,8 +42,20 @@      -- * Utils     matchFileGlob,+    getDirectoryContentsMonitored,+    createDirectoryMonitored,+    monitorDirectoryStatus,+    doesFileExistMonitored,+    need,+    needIfExists,+    findFileWithExtensionMonitored,+    findFirstFileMonitored,+    findFileMonitored,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.FileMonitor import Distribution.Client.Glob hiding (matchFileGlob) import qualified Distribution.Client.Glob as Glob (matchFileGlob)@@ -48,19 +63,17 @@ import Distribution.Simple.Utils (debug) import Distribution.Verbosity    (Verbosity) -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad.State as State-import Distribution.Compat.Binary     (Binary)-import System.FilePath (takeFileName)+import Control.Monad.Reader as Reader+import System.FilePath+import System.Directory   -- | A monad layered on top of 'IO' to help with re-running actions when the -- input files and values they depend on change. The crucial operations are -- 'rerunIfChanged' and 'monitorFiles'. ---newtype Rebuild a = Rebuild (StateT [MonitorFilePath] IO a)+newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)   deriving (Functor, Applicative, Monad, MonadIO)  -- | Use this wihin the body action of 'rerunIfChanged' to declare that the@@ -68,17 +81,28 @@ -- actually did. It is these files that will be checked for changes next -- time 'rerunIfChanged' is called for that 'FileMonitor'. --+-- Relative paths are interpreted as relative to an implicit root, ultimately+-- passed in to 'runRebuild'.+-- monitorFiles :: [MonitorFilePath] -> Rebuild () monitorFiles filespecs = Rebuild (State.modify (filespecs++))  -- | Run a 'Rebuild' IO action.-unRebuild :: Rebuild a -> IO (a, [MonitorFilePath])-unRebuild (Rebuild action) = runStateT action []+unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])+unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []  -- | Run a 'Rebuild' IO action.-runRebuild :: Rebuild a -> IO a-runRebuild (Rebuild action) = evalStateT action []+runRebuild :: FilePath -> Rebuild a -> IO a+runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] +-- | Run a 'Rebuild' IO action.+execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath]+execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) []++-- | The root that relative paths are interpreted as being relative to.+askRoot :: Rebuild FilePath+askRoot = Rebuild Reader.ask+ -- | This captures the standard use pattern for a 'FileMonitor': given a -- monitor, an action and the input value the action depends on, either -- re-run the action to get its output, or if the value and files the action@@ -88,14 +112,14 @@ -- -- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. ---rerunIfChanged :: (Binary a, Binary b)+rerunIfChanged :: (Binary a, Binary b, Typeable a, Typeable b)                => Verbosity-               -> FilePath                -> FileMonitor a b                -> a                -> Rebuild b                -> Rebuild b-rerunIfChanged verbosity rootDir monitor key action = do+rerunIfChanged verbosity monitor key action = do+    rootDir <- askRoot     changed <- liftIO $ checkFileMonitorChanged monitor rootDir key     case changed of       MonitorUnchanged result files -> do@@ -108,7 +132,7 @@         liftIO $ debug verbosity $ "File monitor '" ++ monitorName                                 ++ "' changed: " ++ showReason reason         startTime <- liftIO $ beginUpdateFileMonitor-        (result, files) <- liftIO $ unRebuild action+        (result, files) <- liftIO $ unRebuild rootDir action         liftIO $ updateFileMonitor monitor rootDir                                    (Just startTime) files key result         monitorFiles files@@ -125,11 +149,86 @@ -- | Utility to match a file glob against the file system, starting from a -- given root directory. The results are all relative to the given root. ----- Since this operates in the 'Rebuild' monad, it also monitrs the given glob+-- Since this operates in the 'Rebuild' monad, it also monitors the given glob -- for changes. ---matchFileGlob :: FilePath -> FilePathGlob -> Rebuild [FilePath]-matchFileGlob root glob = do-    monitorFiles [monitorFileGlob glob]+matchFileGlob :: FilePathGlob -> Rebuild [FilePath]+matchFileGlob glob = do+    root <- askRoot+    monitorFiles [monitorFileGlobExistence glob]     liftIO $ Glob.matchFileGlob root glob +getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]+getDirectoryContentsMonitored dir = do+    monitorFiles [monitorDirectory dir]+    liftIO $ getDirectoryContents dir++createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()+createDirectoryMonitored createParents dir = do+    monitorFiles [monitorDirectoryExistence dir]+    liftIO $ createDirectoryIfMissing createParents dir++-- | Monitor a directory as in 'monitorDirectory' if it currently exists or+-- as 'monitorNonExistentDirectory' if it does not.+monitorDirectoryStatus :: FilePath -> Rebuild ()+monitorDirectoryStatus dir = do+    exists <- liftIO $ doesDirectoryExist dir+    monitorFiles [if exists+                    then monitorDirectory dir+                    else monitorNonExistentDirectory dir]++-- | Like 'doesFileExist', but in the 'Rebuild' monad.  This does+-- NOT track the contents of 'FilePath'; use 'need' in that case.+doesFileExistMonitored :: FilePath -> Rebuild Bool+doesFileExistMonitored f = do+    root <- askRoot+    exists <- liftIO $ doesFileExist (root </> f)+    monitorFiles [if exists+                    then monitorFileExistence f+                    else monitorNonExistentFile f]+    return exists++-- | Monitor a single file+need :: FilePath -> Rebuild ()+need f = monitorFiles [monitorFileHashed f]++-- | Monitor a file if it exists; otherwise check for when it+-- gets created.  This is a bit better for recompilation avoidance+-- because sometimes users give bad package metadata, and we don't+-- want to repeatedly rebuild in this case (which we would if we+-- need'ed a non-existent file).+needIfExists :: FilePath -> Rebuild ()+needIfExists f = do+    root <- askRoot+    exists <- liftIO $ doesFileExist (root </> f)+    monitorFiles [if exists+                    then monitorFileHashed f+                    else monitorNonExistentFile f]++-- | Like 'findFileWithExtension', but in the 'Rebuild' monad.+findFileWithExtensionMonitored+    :: [String]+    -> [FilePath]+    -> FilePath+    -> Rebuild (Maybe FilePath)+findFileWithExtensionMonitored extensions searchPath baseName =+  findFirstFileMonitored id+    [ path </> baseName <.> ext+    | path <- nub searchPath+    , ext <- nub extensions ]++-- | Like 'findFirstFile', but in the 'Rebuild' monad.+findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a)+findFirstFileMonitored file = findFirst+  where findFirst []     = return Nothing+        findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)+                              if exists+                                then return (Just x)+                                else findFirst xs++-- | Like 'findFile', but in the 'Rebuild' monad.+findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)+findFileMonitored searchPath fileName =+  findFirstFileMonitored id+    [ path </> fileName+    | path <- nub searchPath]
+ cabal/cabal-install/Distribution/Client/Reconfigure.hs view
@@ -0,0 +1,212 @@+module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where++import Control.Monad ( unless, when )+import Data.Monoid hiding ( (<>) )+import System.Directory ( doesFileExist )++import Distribution.Compat.Semigroup++import Distribution.Verbosity++import Distribution.Simple.Configure ( localBuildInfoFile )+import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag )+import Distribution.Simple.Utils+       ( existsAndIsMoreRecentThan, defaultPackageDesc, info )++import Distribution.Client.Config ( SavedConfig(..) )+import Distribution.Client.Configure ( readConfigFlags )+import Distribution.Client.Sandbox+       ( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath+       , maybeReinstallAddSourceDeps, updateInstallDirs )+import Distribution.Client.Sandbox.PackageEnvironment+       ( userPackageEnvironmentFile )+import Distribution.Client.Sandbox.Types ( UseSandbox(..) )+import Distribution.Client.Setup+       ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..)+       , SkipAddSourceDepsCheck(..) )+++-- | @Check@ represents a function to check some condition on type @a@. The+-- returned 'Any' is 'True' if any part of the condition failed.+newtype Check a = Check {+  runCheck :: Any  -- ^ Did any previous check fail?+           -> a  -- ^ value returned by previous checks+           -> IO (Any, a)  -- ^ Did this check fail? What value is returned?+}++instance Semigroup (Check a) where+  (<>) c d = Check $ \any0 a0 -> do+    (any1, a1) <- runCheck c any0 a0+    (any2, a2) <- runCheck d (any0 <> any1) a1+    return (any0 <> any1 <> any2, a2)++instance Monoid (Check a) where+  mempty = Check $ \_ a -> return (mempty, a)+  mappend = (<>)+++-- | Re-configure the package in the current directory if needed. Deciding+-- when to reconfigure and with which options is convoluted:+--+-- If we are reconfiguring, we must always run @configure@ with the+-- verbosity option we are given; however, that a previous configuration+-- uses a different verbosity setting is not reason enough to reconfigure.+--+-- The package should be configured to use the same \"dist\" prefix as+-- given to the @build@ command, otherwise the build will probably+-- fail. Not only does this determine the \"dist\" prefix setting if we+-- need to reconfigure anyway, but an existing configuration should be+-- invalidated if its \"dist\" prefix differs.+--+-- If the package has never been configured (i.e., there is no+-- LocalBuildInfo), we must configure first, using the default options.+--+-- If the package has been configured, there will be a 'LocalBuildInfo'.+-- If there no package description file, we assume that the+-- 'PackageDescription' is up to date, though the configuration may need+-- to be updated for other reasons (see above). If there is a package+-- description file, and it has been modified since the 'LocalBuildInfo'+-- was generated, then we need to reconfigure.+--+-- The caller of this function may also have specific requirements+-- regarding the flags the last configuration used. For example,+-- 'testAction' requires that the package be configured with test suites+-- enabled. The caller may pass the required settings to this function+-- along with a function to check the validity of the saved 'ConfigFlags';+-- these required settings will be checked first upon determining that+-- a previous configuration exists.+reconfigure+  :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())+     -- ^ configure action+  -> Verbosity+     -- ^ Verbosity setting+  -> FilePath+     -- ^ \"dist\" prefix+  -> UseSandbox+  -> SkipAddSourceDepsCheck+     -- ^ Should we skip the timestamp check for modified+     -- add-source dependencies?+  -> Flag (Maybe Int)+     -- ^ -j flag for reinstalling add-source deps.+  -> Check (ConfigFlags, ConfigExFlags)+     -- ^ Check that the required flags are set.+     -- If they are not set, provide a message explaining the+     -- reason for reconfiguration.+  -> [String]     -- ^ Extra arguments+  -> GlobalFlags  -- ^ Global flags+  -> SavedConfig+  -> IO SavedConfig+reconfigure+  configureAction+  verbosity+  dist+  useSandbox+  skipAddSourceDepsCheck+  numJobsFlag+  check+  extraArgs+  globalFlags+  config+  = do++  savedFlags@(_, _) <- readConfigFlags dist++  let checks =+        checkVerb+        <> checkDist+        <> checkOutdated+        <> check+        <> checkAddSourceDeps+  (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags++  let (_, config') =+        updateInstallDirs+        (configUserInstall configFlags)+        (useSandbox, config)++  when force $ configureAction flags extraArgs globalFlags+  return config'++  where++    -- Changing the verbosity does not require reconfiguration, but the new+    -- verbosity should be used if reconfiguring.+    checkVerb = Check $ \_ (configFlags, configExFlags) -> do+      let configFlags' = configFlags { configVerbosity = toFlag verbosity}+      return (mempty, (configFlags', configExFlags))++    -- Reconfiguration is required if @--build-dir@ changes.+    checkDist = Check $ \_ (configFlags, configExFlags) -> do+      -- Always set the chosen @--build-dir@ before saving the flags,+      -- or bad things could happen.+      savedDist <- findSavedDistPref config (configDistPref configFlags)+      let distChanged = dist /= savedDist+      when distChanged $ info verbosity "build directory changed"+      let configFlags' = configFlags { configDistPref = toFlag dist }+      return (Any distChanged, (configFlags', configExFlags))++    checkOutdated = Check $ \_ flags@(configFlags, _) -> do+      let buildConfig = localBuildInfoFile dist++      -- Has the package ever been configured? If not, reconfiguration is+      -- required.+      configured <- doesFileExist buildConfig+      unless configured $ info verbosity "package has never been configured"++      -- Is the configuration older than the sandbox configuration file?+      -- If so, reconfiguration is required.+      sandboxConfig <- getSandboxConfigFilePath globalFlags+      sandboxConfigNewer <- existsAndIsMoreRecentThan sandboxConfig buildConfig+      when sandboxConfigNewer $+        info verbosity "sandbox was created after the package was configured"++      -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need+      -- to force reconfigure. Note that it's possible to use @cabal.config@+      -- even without sandboxes.+      userPackageEnvironmentFileModified <-+        existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig+      when userPackageEnvironmentFileModified $+        info verbosity ("user package environment file ('"+        ++ userPackageEnvironmentFile ++ "') was modified")++      -- Is the configuration older than the package description?+      descrFile <- maybe (defaultPackageDesc verbosity) return+                   (flagToMaybe (configCabalFilePath configFlags))+      outdated <- existsAndIsMoreRecentThan descrFile buildConfig+      when outdated $ info verbosity (descrFile ++ " was changed")++      let failed =+            Any outdated+            <> Any userPackageEnvironmentFileModified+            <> Any sandboxConfigNewer+            <> Any (not configured)+      return (failed, flags)++    checkAddSourceDeps = Check $ \(Any force') flags@(configFlags, _) -> do+      let (_, config') =+            updateInstallDirs+            (configUserInstall configFlags)+            (useSandbox, config)++          skipAddSourceDepsCheck'+            | force'    = SkipAddSourceDepsCheck+            | otherwise = skipAddSourceDepsCheck++      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $+        info verbosity "skipping add-source deps check"++      -- Were any add-source dependencies reinstalled in the sandbox?+      depsReinstalled <-+        case skipAddSourceDepsCheck' of+          DontSkipAddSourceDepsCheck ->+            maybeReinstallAddSourceDeps+            verbosity numJobsFlag configFlags globalFlags+            (useSandbox, config')+          SkipAddSourceDepsCheck -> do+            return NoDepsReinstalled++      case depsReinstalled of+        NoDepsReinstalled -> return (mempty, flags)+        ReinstalledSomeDeps -> do+          info verbosity "some add-source dependencies were reinstalled"+          return (Any True, flags)
cabal/cabal-install/Distribution/Client/Run.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Run@@ -11,8 +10,17 @@ module Distribution.Client.Run ( run, splitRunArgs )        where +import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Types.TargetInfo     (targetCLBI)+import Distribution.Types.LocalBuildInfo (componentNameTargets')+ import Distribution.Client.Utils             (tryCanonicalizePath) +import Distribution.Package                  (UnqualComponentName,+                                              mkUnqualComponentName,+                                              unUnqualComponentName) import Distribution.PackageDescription       (Executable (..),                                               TestSuite(..),                                               Benchmark(..),@@ -23,21 +31,16 @@ import Distribution.Simple.BuildPaths        (exeExtension) import Distribution.Simple.LocalBuildInfo    (ComponentName (..),                                               LocalBuildInfo (..),-                                              getComponentLocalBuildInfo,                                               depLibraryPaths) import Distribution.Simple.Utils             (die, notice, warn,                                               rawSystemExitWithEnv,                                               addLibraryPath) import Distribution.System                   (Platform (..)) import Distribution.Verbosity                (Verbosity)+import Distribution.Text                     (display)  import qualified Distribution.Simple.GHCJS as GHCJS -#if !MIN_VERSION_base(4,8,0)-import Data.Functor                          ((<$>))-#endif-import Data.List                             (find)-import Data.Foldable                         (traverse_) import System.Directory                      (getCurrentDirectory) import Distribution.Compat.Environment       (getEnvironment) import System.FilePath                       ((<.>), (</>))@@ -70,14 +73,14 @@       ([]   , _)           -> Left "Couldn't find any enabled executables."       ([exe], [])          -> return (False, exe, [])       ([exe], (x:xs))-        | x == exeName exe -> return (True, exe, xs)-        | otherwise        -> return (False, exe, args)-      (_    , [])          -> Left+        | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs)+        | otherwise                                -> return (False, exe, args)+      (_    , [])                                  -> Left         $ "This package contains multiple executables. "         ++ "You must pass the executable name as the first argument "         ++ "to 'cabal run'."       (_    , (x:xs))      ->-        case find (\exe -> exeName exe == x) enabledExes of+        case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of           Nothing  -> Left $ "No executable named '" ++ x ++ "'."           Just exe -> return (True, exe, xs)       where@@ -86,20 +89,20 @@     maybeWarning :: Maybe String     maybeWarning = case args of       []    -> Nothing-      (x:_) -> lookup x components+      (x:_) -> lookup (mkUnqualComponentName x) components       where-        components :: [(String, String)] -- Component name, message.+        components :: [(UnqualComponentName, String)] -- Component name, message.         components =-          [ (name, "The executable '" ++ name ++ "' is disabled.")+          [ (name, "The executable '" ++ display name ++ "' is disabled.")           | e <- executables pkg_descr           , not . buildable . buildInfo $ e, let name = exeName e] -          ++ [ (name, "There is a test-suite '" ++ name ++ "',"+          ++ [ (name, "There is a test-suite '" ++ display name ++ "',"                       ++ " but the `run` command is only for executables.")              | t <- testSuites pkg_descr              , let name = testName t] -          ++ [ (name, "There is a benchmark '" ++ name ++ "',"+          ++ [ (name, "There is a benchmark '" ++ display name ++ "',"                       ++ " but the `run` command is only for executables.")              | b <- benchmarks pkg_descr              , let name = benchmarkName b]@@ -114,26 +117,29 @@                        curDir </> dataDir pkg_descr)    (path, runArgs) <--    case compilerFlavor (compiler lbi) of+    let exeName' = display $ exeName exe+    in case compilerFlavor (compiler lbi) of       GHCJS -> do         let (script, cmd, cmdArgs) =               GHCJS.runCmd (withPrograms lbi)-                           (buildPref </> exeName exe </> exeName exe)+                           (buildPref </> exeName' </> exeName')         script' <- tryCanonicalizePath script         return (cmd, cmdArgs ++ [script'])       _     -> do          p <- tryCanonicalizePath $-            buildPref </> exeName exe </> (exeName exe <.> exeExtension)+            buildPref </> exeName' </> (exeName' <.> exeExtension)          return (p, [])    env  <- (dataDirEnvVar:) <$> getEnvironment   -- Add (DY)LD_LIBRARY_PATH if needed   env' <- if withDynExe lbi              then do let (Platform _ os) = hostPlatform lbi-                         clbi = getComponentLocalBuildInfo lbi-                                  (CExeName (exeName exe))+                     clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of+                                [target] -> return (targetCLBI target)+                                [] -> die "run: Could not find executable in LocalBuildInfo"+                                _ -> die "run: Found multiple matching exes in LocalBuildInfo"                      paths <- depLibraryPaths True False lbi clbi                      return (addLibraryPath os paths env)              else return env-  notice verbosity $ "Running " ++ exeName exe ++ "..."+  notice verbosity $ "Running " ++ display (exeName exe) ++ "..."   rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'
cabal/cabal-install/Distribution/Client/Sandbox.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox@@ -38,12 +38,16 @@     updateSandboxConfigFileFlag,     updateInstallDirs, -    configPackageDB', configCompilerAux', getPersistOrConfigCompiler+    getPersistOrConfigCompiler   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Setup   ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)-  , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags+  , GlobalFlags(..), configCompilerAux', configPackageDB'+  , defaultConfigExFlags, defaultInstallFlags   , defaultSandboxLocation, withRepoContext ) import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps                                               , maybeAddCompilerTimestampRecord@@ -70,59 +74,51 @@                                               , UseSandbox(..) ) import Distribution.Client.SetupWrapper   ( SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Types              ( PackageLocation(..)-                                              , SourcePackage(..) )+import Distribution.Client.Types              ( PackageLocation(..) ) import Distribution.Client.Utils              ( inDir, tryCanonicalizePath                                               , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration                                               ( flattenPackageDescription ) import Distribution.PackageDescription.Parse  ( readPackageDescription )-import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..)-                                              , PackageDBStack )+import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure          ( configCompilerAuxEx-                                              , interpretPackageDbFlags                                               , getPackageDBContents                                               , maybeGetPersistBuildConfig                                               , findDistPrefOrDefault                                               , findDistPref ) import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import Distribution.Simple.PreProcess         ( knownSuffixHandlers )-import Distribution.Simple.Program            ( ProgramConfiguration )+import Distribution.Simple.Program            ( ProgramDb ) import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)                                               , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist            ( prepareTree ) import Distribution.Simple.Utils              ( die, debug, notice, info, warn                                               , debugNoWrap, defaultPackageDesc-                                              , intercalate, topHandlerWith+                                              , topHandlerWith                                               , createDirectoryIfMissingVerbose ) import Distribution.Package                   ( Package(..) ) import Distribution.System                    ( Platform ) import Distribution.Text                      ( display )-import Distribution.Verbosity                 ( Verbosity, lessVerbose )+import Distribution.Verbosity                 ( Verbosity ) import Distribution.Compat.Environment        ( lookupEnv, setEnv ) import Distribution.Client.Compat.FilePerms   ( setFileHidden ) import qualified Distribution.Client.Sandbox.Index as Index import Distribution.Simple.PackageIndex       ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex import qualified Distribution.Simple.Register      as Register++import Distribution.Solver.Types.SourcePackage+ import qualified Data.Map                          as M import qualified Data.Set                          as S import Data.Either                            (partitionEithers) import Control.Exception                      ( assert, bracket_ )-import Control.Monad                          ( forM, liftM, liftM2, unless, when )+import Control.Monad                          ( forM, mapM, mapM_ ) import Data.Bits                              ( shiftL, shiftR, xor )-import Data.Char                              ( ord ) import Data.IORef                             ( newIORef, writeIORef, readIORef ) import Data.List                              ( delete-                                              , foldl'-                                              , intersperse-                                              , isPrefixOf                                               , groupBy ) import Data.Maybe                             ( fromJust )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid                            ( mempty, mappend )-#endif-import Data.Word                              ( Word32 ) import Numeric                                ( showHex ) import System.Directory                       ( canonicalizePath                                               , createDirectory@@ -248,11 +244,11 @@  -- | Which packages are installed in the sandbox package DB? getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags-                                 -> Compiler -> ProgramConfiguration+                                 -> Compiler -> ProgramDb                                  -> IO InstalledPackageIndex-getInstalledPackagesInSandbox verbosity configFlags comp conf = do+getInstalledPackagesInSandbox verbosity configFlags comp progdb = do     sandboxDB <- getSandboxPackageDB configFlags-    getPackageDBContents verbosity comp sandboxDB conf+    getPackageDBContents verbosity comp sandboxDB progdb  -- | Temporarily add $SANDBOX_DIR/bin to $PATH. withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a@@ -280,13 +276,13 @@  -- | Initialise a package DB for this compiler if it doesn't exist. initPackageDBIfNeeded :: Verbosity -> ConfigFlags-                         -> Compiler -> ProgramConfiguration+                         -> Compiler -> ProgramDb                          -> IO ()-initPackageDBIfNeeded verbosity configFlags comp conf = do+initPackageDBIfNeeded verbosity configFlags comp progdb = do   SpecificPackageDB dbPath <- getSandboxPackageDB configFlags   packageDBExists <- doesDirectoryExist dbPath   unless packageDBExists $-    Register.initPackageDB verbosity comp conf dbPath+    Register.initPackageDB verbosity comp progdb dbPath   when packageDBExists $     debug verbosity $ "The package database already exists: " ++ dbPath @@ -318,7 +314,7 @@    -- Determine which compiler to use (using the value from ~/.cabal/config).   userConfig <- loadConfig verbosity (globalConfigFile globalFlags)-  (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)+  (comp, platform, progdb) <- configCompilerAuxEx (savedConfigureFlags userConfig)    -- Create the package environment file.   pkgEnvFile <- getSandboxConfigFilePath globalFlags@@ -336,7 +332,7 @@   Index.createEmpty verbosity indexFile    -- Create the package DB for the default compiler.-  initPackageDBIfNeeded verbosity configFlags comp conf+  initPackageDBIfNeeded verbosity configFlags comp progdb   maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile     (compilerId comp) platform @@ -551,10 +547,10 @@   let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv   -- Invoke hc-pkg for the most recently configured compiler (if any),   -- using the right package-db for the compiler (see #1935).-  (comp, platform, conf) <- getPersistOrConfigCompiler configFlags+  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags   let dir         = sandboxPackageDBPath sandboxDir comp platform       dbStack     = [GlobalPackageDB, SpecificPackageDB dir]-  Register.invokeHcPkg verbosity comp conf dbStack extraArgs+  Register.invokeHcPkg verbosity comp progdb dbStack extraArgs  updateInstallDirs :: Flag Bool                   -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig)@@ -596,7 +592,7 @@     -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.     SandboxPackageEnvironment -> do       (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-                              -- ^ Prints an error message and exits on error.+                              -- Prints an error message and exits on error.       let config = pkgEnvSavedConfig pkgEnv       return (UseSandbox sandboxDir, config) @@ -673,32 +669,32 @@                             { configDistPref  = Flag sandboxDistPref }       haddockFlags        = mempty                             { haddockDistPref = Flag sandboxDistPref }-  (comp, platform, conf) <- configCompilerAux' configFlags-  retVal                 <- newIORef NoDepsReinstalled+  (comp, platform, progdb) <- configCompilerAux' configFlags+  retVal                   <- newIORef NoDepsReinstalled    withSandboxPackageInfo verbosity configFlags globalFlags-                         comp platform conf sandboxDir $ \sandboxPkgInfo ->+                         comp platform progdb sandboxDir $ \sandboxPkgInfo ->     unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do -     withRepoContext verbosity globalFlags $ \repoContext -> do-      let args :: InstallArgs-          args = ((configPackageDB' configFlags)-                 ,repoContext-                 ,comp, platform, conf-                 ,UseSandbox sandboxDir, Just sandboxPkgInfo-                 ,globalFlags, configFlags, configExFlags, installFlags-                 ,haddockFlags)+      withRepoContext verbosity globalFlags $ \repoContext -> do+        let args :: InstallArgs+            args = ((configPackageDB' configFlags)+                  ,repoContext+                  ,comp, platform, progdb+                  ,UseSandbox sandboxDir, Just sandboxPkgInfo+                  ,globalFlags, configFlags, configExFlags, installFlags+                  ,haddockFlags) -      -- This can actually be replaced by a call to 'install', but we use a-      -- lower-level API because of layer separation reasons. Additionally, we-      -- might want to use some lower-level features this in the future.-      withSandboxBinDirOnSearchPath sandboxDir $ do-        installContext <- makeInstallContext verbosity args Nothing-        installPlan    <- foldProgress logMsg die' return =<<-                          makeInstallPlan verbosity args installContext+        -- This can actually be replaced by a call to 'install', but we use a+        -- lower-level API because of layer separation reasons. Additionally, we+        -- might want to use some lower-level features this in the future.+        withSandboxBinDirOnSearchPath sandboxDir $ do+          installContext <- makeInstallContext verbosity args Nothing+          installPlan    <- foldProgress logMsg die' return =<<+                            makeInstallPlan verbosity args installContext -        processInstallPlan verbosity args installContext installPlan-        writeIORef retVal ReinstalledSomeDeps+          processInstallPlan verbosity args installContext installPlan+          writeIORef retVal ReinstalledSomeDeps    readIORef retVal @@ -721,12 +717,12 @@ -- we don't update the timestamp file here - this is done in -- 'postInstallActions'. withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags-                          -> Compiler -> Platform -> ProgramConfiguration+                          -> Compiler -> Platform -> ProgramDb                           -> FilePath                           -> (SandboxPackageInfo -> IO ())                           -> IO () withSandboxPackageInfo verbosity configFlags globalFlags-                       comp platform conf sandboxDir cont = do+                       comp platform progdb sandboxDir cont = do   -- List all add-source deps.   indexFile              <- tryGetIndexFilePath' globalFlags   buildTreeRefs          <- Index.listBuildTreeRefs verbosity@@ -735,7 +731,7 @@    -- List all packages installed in the sandbox.   installedPkgIndex <- getInstalledPackagesInSandbox verbosity-                       configFlags comp conf+                       configFlags comp progdb   let err = "Error reading sandbox package information."   -- Get the package descriptions for all add-source deps.   depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs@@ -775,17 +771,17 @@ -- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the -- identity otherwise. maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags-                               -> Compiler -> Platform -> ProgramConfiguration+                               -> Compiler -> Platform -> ProgramDb                                -> UseSandbox                                -> (Maybe SandboxPackageInfo -> IO ())                                -> IO () maybeWithSandboxPackageInfo verbosity configFlags globalFlags-                            comp platform conf useSandbox cont =+                            comp platform progdb useSandbox cont =   case useSandbox of     NoSandbox             -> cont Nothing     UseSandbox sandboxDir -> withSandboxPackageInfo verbosity                              configFlags globalFlags-                             comp platform conf sandboxDir+                             comp platform progdb sandboxDir                              (\spi -> cont (Just spi))  -- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that@@ -853,28 +849,12 @@ -- -- Utils (transitionary) ----- FIXME: configPackageDB' and configCompilerAux' don't really belong in this--- module--- -configPackageDB' :: ConfigFlags -> PackageDBStack-configPackageDB' cfg =-    interpretPackageDbFlags userInstall (configPackageDBs cfg)-  where-    userInstall = fromFlagOrDefault True (configUserInstall cfg)--configCompilerAux' :: ConfigFlags-                   -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerAux' configFlags =-  configCompilerAuxEx configFlags-    --FIXME: make configCompilerAux use a sensible verbosity-    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }- -- | Try to read the most recently configured compiler from the -- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it -- cannot be read. getPersistOrConfigCompiler :: ConfigFlags-                           -> IO (Compiler, Platform, ProgramConfiguration)+                           -> IO (Compiler, Platform, ProgramDb) getPersistOrConfigCompiler configFlags = do   distPref <- findDistPrefOrDefault (configDistPref configFlags)   mlbi <- maybeGetPersistBuildConfig distPref
cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -36,12 +36,12 @@                                        , installDirsFields, withProgramsFields                                        , withProgramOptionsFields                                        , defaultCompiler )-import Distribution.Client.Dependency.Types ( ConstraintSource (..) ) import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection ) import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)                                        , InstallFlags(..)                                        , defaultSandboxLocation )-import Distribution.Utils.NubList            ( toNubList )+import Distribution.Client.Targets     ( userConstraintPackageName )+import Distribution.Utils.NubList      ( toNubList ) import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)                                        , compilerFlavor, showCompilerIdWithAbi ) import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate@@ -51,6 +51,7 @@                                        , ConfigFlags(..), HaddockFlags(..)                                        , fromFlagOrDefault, toFlag, flagToMaybe ) import Distribution.Simple.Utils       ( die, info, notice, warn )+import Distribution.Solver.Types.ConstraintSource import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..)                                        , commaListField, commaNewLineListField                                        , liftField, lineNo, locatedErrorMsg@@ -60,8 +61,9 @@ import Distribution.System             ( Platform ) import Distribution.Verbosity          ( Verbosity, normal ) import Control.Monad                   ( foldM, liftM2, when, unless )-import Data.List                       ( partition )+import Data.List                       ( partition, sortBy ) import Data.Maybe                      ( isJust )+import Data.Ord                        ( comparing ) import Distribution.Compat.Exception   ( catchIO ) import Distribution.Compat.Semigroup import System.Directory                ( doesDirectoryExist, doesFileExist@@ -399,7 +401,7 @@    , commaNewLineListField "constraints"     (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)-    (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)+    (sortConstraints . configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)     (\v pkgEnv -> updateConfigureExFlags pkgEnv                   (\flags -> flags { configExConstraints = v })) @@ -433,6 +435,8 @@                                  $ pkgEnv          }       }++    sortConstraints = sortBy (comparing $ userConstraintPackageName . fst)  -- | Read the package environment file. readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs view
@@ -21,7 +21,6 @@   writeTimestampFile   ) where -import Control.Exception                             (IOException) import Control.Monad                                 (filterM, forM, when) import Data.Char                                     (isSpace) import Data.List                                     (partition)@@ -30,32 +29,19 @@ import qualified Data.Map as M  import Distribution.Compiler                         (CompilerId)-import Distribution.Package                          (packageName)-import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.PackageDescription.Parse         (readPackageDescription)-import Distribution.Simple.Setup                     (Flag (..),-                                                      SDistFlags (..),-                                                      defaultSDistFlags,-                                                      sdistCommand) import Distribution.Simple.Utils                     (debug, die, warn) import Distribution.System                           (Platform) import Distribution.Text                             (display)-import Distribution.Verbosity                        (Verbosity, lessVerbose,-                                                      normal)-import Distribution.Version                          (Version (..),-                                                      orLaterVersion)+import Distribution.Verbosity                        (Verbosity) +import Distribution.Client.SrcDist (allPackageSourceFiles) import Distribution.Client.Sandbox.Index   (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)   ,listBuildTreeRefs)-import Distribution.Client.SetupWrapper              (SetupScriptOptions (..),-                                                      defaultSetupScriptOptions,-                                                      setupWrapper)-import Distribution.Client.Utils-  (inDir, removeExistingFile, tryCanonicalizePath, tryFindAddSourcePackageDesc)+import Distribution.Client.SetupWrapper  import Distribution.Compat.Exception                 (catchIO)-import Distribution.Client.Compat.Time               (ModTime, getCurTime,+import Distribution.Compat.Time               (ModTime, getCurTime,                                                       getModTime,                                                       posixSecondsToModTime) @@ -238,57 +224,21 @@       else return r     return timestampRecords' --- | List all source files of a given add-source dependency. Exits with error if--- something is wrong (e.g. there is no .cabal file in the given directory).--- FIXME: This function is not thread-safe because of 'inDir'.-allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]-allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do-  pkg <- do-    let err = "Error reading source files of add-source dependency."-    desc <- tryFindAddSourcePackageDesc packageDir err-    flattenPackageDescription `fmap` readPackageDescription verbosity desc-  let file      = "cabal-sdist-list-sources"-      flags     = defaultSDistFlags {-        sDistVerbosity   = Flag $ if verbosity == normal-                                  then lessVerbose verbosity else verbosity,-        sDistListSources = Flag file-        }-      setupOpts = defaultSetupScriptOptions {-        -- 'sdist --list-sources' was introduced in Cabal 1.18.-        useCabalVersion = orLaterVersion $ Version [1,18,0] []-        }--      doListSources :: IO [FilePath]-      doListSources = do-        setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) []-        srcs <- fmap lines . readFile $ file-        mapM tryCanonicalizePath srcs--      onFailedListSources :: IOException -> IO ()-      onFailedListSources e = do-        warn verbosity $-          "Could not list sources of the add-source dependency '"-          ++ display (packageName pkg) ++ "'. Skipping the timestamp check."-        debug verbosity $-          "Exception was: " ++ show e--  -- Run setup sdist --list-sources=TMPFILE-  ret <- doListSources `catchIO` (\e -> onFailedListSources e >> return [])-  removeExistingFile file-  return ret- -- | Has this dependency been modified since we have last looked at it? isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool isDepModified verbosity now (packageDir, timestamp) = do   debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)-  depSources <- allPackageSourceFiles verbosity packageDir+  -- TODO: we should properly plumb the correct options through+  -- instead of using defaultSetupScriptOptions+  depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir   go depSources    where     go []         = return False-    go (dep:rest) = do+    go (dep0:rest) = do       -- FIXME: What if the clock jumps backwards at any point? For now we only       -- print a warning.+      let dep = packageDir </> dep0       modTime <- getModTime dep       when (modTime > now) $         warn verbosity $ "File '" ++ dep
cabal/cabal-install/Distribution/Client/Sandbox/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox.Types@@ -13,13 +12,12 @@   SandboxPackageInfo(..)   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Client.Types (UnresolvedSourcePackage)-import Distribution.Compat.Semigroup (Semigroup((<>))) -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif import qualified Data.Set as S  -- | Are we using a sandbox?
+ cabal/cabal-install/Distribution/Client/SavedFlags.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Distribution.Client.SavedFlags+       ( readCommandFlags, writeCommandFlags+       , readSavedArgs, writeSavedArgs+       ) where++import Distribution.Simple.Command+import Distribution.Simple.UserHooks ( Args )+import Distribution.Simple.Utils+       ( createDirectoryIfMissingVerbose, unintersperse )+import Distribution.Verbosity++import Control.Exception ( Exception, throwIO )+import Control.Monad ( liftM )+import Data.List ( intercalate )+import Data.Maybe ( fromMaybe )+import Data.Typeable+import System.Directory ( doesFileExist )+import System.FilePath ( takeDirectory )+++writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO ()+writeSavedArgs verbosity path args = do+  createDirectoryIfMissingVerbose+    (lessVerbose verbosity) True (takeDirectory path)+  writeFile path (intercalate "\0" args)+++-- | Write command-line flags to a file, separated by null characters. This+-- format is also suitable for the @xargs -0@ command. Using the null+-- character also avoids the problem of escaping newlines or spaces,+-- because unlike other whitespace characters, the null character is+-- not valid in command-line arguments.+writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO ()+writeCommandFlags verbosity path command flags =+  writeSavedArgs verbosity path (commandShowOptions command flags)+++readSavedArgs :: FilePath -> IO (Maybe [String])+readSavedArgs path = do+  exists <- doesFileExist path+  if exists+     then liftM (Just . unintersperse '\0') (readFile path)+    else return Nothing+++-- | Read command-line arguments, separated by null characters, from a file.+-- Returns the default flags if the file does not exist.+readCommandFlags :: FilePath -> CommandUI flags -> IO flags+readCommandFlags path command = do+  savedArgs <- liftM (fromMaybe []) (readSavedArgs path)+  case (commandParseArgs command True savedArgs) of+    CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)+    CommandList _ -> throwIO (SavedArgsErrorList savedArgs)+    CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)+    CommandReadyToGo (mkFlags, _) ->+      return (mkFlags (commandDefaultFlags command))++-- -----------------------------------------------------------------------------+-- * Exceptions+-- -----------------------------------------------------------------------------++data SavedArgsError+    = SavedArgsErrorHelp Args+    | SavedArgsErrorList Args+    | SavedArgsErrorOther Args [String]+  deriving (Typeable)++instance Show SavedArgsError where+  show (SavedArgsErrorHelp args) =+    "unexpected flag '--help', saved command line was:\n"+    ++ intercalate " " args+  show (SavedArgsErrorList args) =+    "unexpected flag '--list-options', saved command line was:\n"+    ++ intercalate " " args+  show (SavedArgsErrorOther args errs) =+    "saved command line was:\n"+    ++ intercalate " " args ++ "\n"+    ++ "encountered errors:\n"+    ++ intercalate "\n" errs++instance Exception SavedArgsError
+ cabal/cabal-install/Distribution/Client/Security/DNS.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE DoAndIfThenElse #-}+module Distribution.Client.Security.DNS+    ( queryBootstrapMirrors+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Control.Monad+import Control.DeepSeq (force)+import Control.Exception (SomeException, evaluate, try)+import Network.URI (URI(..), URIAuth(..), parseURI)++import Distribution.Simple.Utils+import Distribution.Verbosity+import Distribution.Simple.Program.Db+         ( emptyProgramDb, addKnownProgram+         , configureAllKnownPrograms, lookupProgram )+import Distribution.Simple.Program+         ( simpleProgram+         , programInvocation+         , getProgramInvocationOutput )+import Distribution.Compat.Exception (displayException)++-- | Try to lookup RFC1464-encoded mirror urls for a Hackage+-- repository url by performing a DNS TXT lookup on the+-- @_mirrors.@-prefixed URL hostname.+--+-- Example: for @http://hackage.haskell.org/@+-- perform a DNS TXT query for the hostname+-- @_mirrors.hackage.haskell.org@ which may look like e.g.+--+-- > _mirrors.hackage.haskell.org. 300 IN TXT+-- >    "0.urlbase=http://hackage.fpcomplete.com/"+-- >    "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"+--+-- NB: hackage-security doesn't require DNS lookups being trustworthy,+-- as the trust is established via the cryptographically signed TUF+-- meta-data that is retrieved from the resolved Hackage repository.+-- Moreover, we already have to protect against a compromised+-- @hackage.haskell.org@ DNS entry, so an the additional+-- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't+-- constitute a significant new attack vector anyway.+--+queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]+queryBootstrapMirrors verbosity repoUri+  | Just auth <- uriAuthority repoUri = do+        progdb <- configureAllKnownPrograms verbosity $+                  addKnownProgram nslookupProg emptyProgramDb++        case lookupProgram nslookupProg progdb of+          Nothing -> do+              warn verbosity "'nslookup' tool missing - can't locate mirrors"+              return []++          Just nslookup -> do+              let mirrorsDnsName = "_mirrors." ++ uriRegName auth++              mirrors' <- try $ do+                  out <- getProgramInvocationOutput verbosity $+                         programInvocation nslookup ["-query=TXT", mirrorsDnsName]+                  evaluate (force $ extractMirrors mirrorsDnsName out)++              mirrors <- case mirrors' of+                Left e -> do+                    warn verbosity ("Caught exception during _mirrors lookup:"+++                                    displayException (e :: SomeException))+                    return []+                Right v -> return v++              if null mirrors+              then warn verbosity ("No mirrors found for " ++ show repoUri)+              else do info verbosity ("located " ++ show (length mirrors) +++                                      " mirrors for " ++ show repoUri ++ " :")+                      forM_ mirrors $ \url -> info verbosity ("- " ++ show url)++              return mirrors++  | otherwise = return []+  where+    nslookupProg = simpleProgram "nslookup"++-- | Extract list of mirrors from @nslookup -query=TXT@ output.+extractMirrors :: String -> String -> [URI]+extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals+  where+    vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0+                    , h == hostname+                    , e <- ents+                    , Just (k,v) <- [splitRfc1464 e]+                    , Just kn <- [isUrlBase k]+                    ]++    isUrlBase :: String -> Maybe Int+    isUrlBase s+      | isSuffixOf ".urlbase" s, not (null ns), all isDigit ns = readMaybe ns+      | otherwise = Nothing+      where+        ns = take (length s - 8) s++-- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly+parseNsLookupTxt :: String -> Maybe [(String,[String])]+parseNsLookupTxt = go0 [] []+  where+    -- approximate grammar:+    -- <entries> := { <entry> }+    -- (<entry> starts at begin of line, but may span multiple lines)+    -- <entry> := ^ <hostname> TAB "text =" { <qstring> }+    -- <qstring> := string enclosed by '"'s ('\' and '"' are \-escaped)++    -- scan for ^ <word> <TAB> "text ="+    go0 []  _  []                                = Nothing+    go0 res _  []                                = Just (reverse res)+    go0 res _  ('\n':xs)                         = go0 res [] xs+    go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs)+    go0 res lw (x:xs)                            = go0 res (x:lw) xs++    -- collect at least one <qstring>+    go1 res lw qs ('"':xs) = case qstr "" xs of+      Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')+      Nothing       -> Nothing -- bad quoting+    go1 _   _  [] _  = Nothing -- missing qstring+    go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs++    qstr _   ('\n':_) = Nothing -- We don't support unquoted LFs+    qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs+    qstr acc ('\\':'"':cs)  = qstr ('"':acc) cs+    qstr acc ('"':cs) = Just (reverse acc, cs)+    qstr acc (c:cs)   = qstr (c:acc) cs+    qstr _   []       = Nothing++-- | Split a TXT string into key and value according to RFC1464.+-- Returns 'Nothing' if parsing fails.+splitRfc1464 :: String -> Maybe (String,String)+splitRfc1464 = go ""+  where+    go _ [] = Nothing+    go acc ('`':c:cs) = go (c:acc) cs+    go acc ('=':cs)   = go2 (reverse acc) "" cs+    go acc (c:cs)+      | isSpace c = go acc cs+      | otherwise = go (c:acc) cs++    go2 k acc [] = Just (k,reverse acc)+    go2 _ _   ['`'] = Nothing+    go2 k acc ('`':c:cs) = go2 k (c:acc) cs+    go2 k acc (c:cs) = go2 k (c:acc) cs
cabal/cabal-install/Distribution/Client/Setup.hs view
@@ -18,10 +18,11 @@     ( globalCommand, GlobalFlags(..), defaultGlobalFlags     , RepoContext(..), withRepoContext     , configureCommand, ConfigFlags(..), filterConfigureFlags+    , configPackageDB', configCompilerAux'     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags-                        , configureExOptions     , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)     , replCommand, testCommand, benchmarkCommand+                        , configureExOptions, reconfigureCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , defaultSolver, defaultMaxBackjumps     , listCommand, ListFlags(..)@@ -35,7 +36,7 @@     , getCommand, unpackCommand, GetFlags(..)     , checkCommand     , formatCommand-    , uploadCommand, UploadFlags(..)+    , uploadCommand, UploadFlags(..), IsCandidate(..)     , reportCommand, ReportFlags(..)     , runCommand     , initCommand, IT.InitFlags(..)@@ -54,12 +55,19 @@     , readRepo     ) where +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)+ import Distribution.Client.Types          ( Username(..), Password(..), RemoteRepo(..) ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types-         ( PreSolver(..), ConstraintSource(..) )+         ( PreSolver(..) )++import Distribution.Client.IndexUtils.Timestamp+         ( IndexState )+ import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets@@ -67,12 +75,15 @@ import Distribution.Utils.NubList          ( NubList, toNubList, fromNubList) +import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.Settings -import Distribution.Simple.Compiler (PackageDB)-import Distribution.Simple.Program-         ( defaultProgramConfiguration )+import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack )+import Distribution.Simple.Program (ProgramDb, defaultProgramDb) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command+import Distribution.Simple.Configure+       ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup          ( ConfigFlags(..), BuildFlags(..), ReplFlags@@ -80,26 +91,27 @@          , SDistFlags(..), HaddockFlags(..)          , readPackageDbList, showPackageDbList          , Flag(..), toFlag, flagToMaybe, flagToList-         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg+         , BooleanFlag(..), optionVerbosity+         , boolOpt, boolOpt', trueArg, falseArg          , readPToMaybe, optionNumJobs ) import Distribution.Simple.InstallDirs-         ( PathTemplate, InstallDirs(sysconfdir)+         ( PathTemplate, InstallDirs(dynlibdir, sysconfdir)          , toPathTemplate, fromPathTemplate ) import Distribution.Version-         ( Version(Version), anyVersion, thisVersion )+         ( Version, mkVersion, nullVersion, anyVersion, thisVersion ) import Distribution.Package          ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import Distribution.PackageDescription          ( BuildType(..), RepoKind(..) )+import Distribution.System ( Platform ) import Distribution.Text          ( Text(..), display ) import Distribution.ReadE          ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse          ( ReadP, char, munch1, pfail,  (+++) )-import Distribution.Compat.Semigroup import Distribution.Verbosity-         ( Verbosity, normal )+         ( Verbosity, lessVerbose, normal ) import Distribution.Simple.Utils          ( wrapText, wrapLine ) import Distribution.Client.GlobalFlags@@ -107,16 +119,8 @@          , RepoContext(..), withRepoContext          ) -import Data.Char-         ( isAlphaNum ) import Data.List-         ( intercalate, deleteFirstsBy )-import Data.Maybe-         ( maybeToList, fromMaybe )-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)-import Control.Monad-         ( liftM )+         ( deleteFirstsBy ) import System.FilePath          ( (</>) ) import Network.URI@@ -342,65 +346,89 @@        ++ "    with some package-specific flag.\n"   }  where-  c = Cabal.configureCommand defaultProgramConfiguration+  c = Cabal.configureCommand defaultProgramDb  configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions = commandOptions configureCommand +-- | Given some 'ConfigFlags' for the version of Cabal that+-- cabal-install was built with, and a target older 'Version' of+-- Cabal that we want to pass these flags to, convert the+-- flags into a form that will be accepted by the older+-- Setup script.  Generally speaking, this just means filtering+-- out flags that the old Cabal library doesn't understand, but+-- in some cases it may also mean "emulating" a feature using+-- some more legacy flags. filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,23,0] [] = flags_latest-  -- ^ NB: we expect the latest version to be the most common case.-  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10-  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0-  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0-  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0-  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0-  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0-  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1-  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0-  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0-  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0+  -- NB: we expect the latest version to be the most common case,+  -- so test it first.+  | cabalLibVersion >= mkVersion [1,25,0] = flags_latest+  -- The naming convention is that flags_version gives flags with+  -- all flags *introduced* in version eliminated.+  -- It is NOT the latest version of Cabal library that+  -- these flags work for; version of introduction is a more+  -- natural metric.+  | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10+  | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0+  | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0+  | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0+  | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0+  | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1+  | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2+  | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1+  | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0+  | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0+  | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0   | otherwise = flags_latest   where     flags_latest = flags        {       -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.       configConstraints = [],-      -- Passing '--allow-newer' to Setup.hs is unnecessary, we use+      -- Passing '--allow-{older,newer}' to Setup.hs is unnecessary, we use       -- '--exact-configuration' instead.-      configAllowNewer  = Just Cabal.AllowNewerNone+      configAllowOlder  = Just (Cabal.AllowOlder Cabal.RelaxDepsNone),+      configAllowNewer  = Just (Cabal.AllowNewer Cabal.RelaxDepsNone)       } +    -- Cabal < 1.25.0 doesn't know about --dynlibdir.+    flags_1_25_0 = flags_latest { configInstallDirs = configInstallDirs_1_25_0}+    configInstallDirs_1_25_0 = (configInstallDirs flags) { dynlibdir = NoFlag }+     -- Cabal < 1.23 doesn't know about '--profiling-detail'.-    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag+    -- Cabal < 1.23 has a hacked up version of 'enable-profiling'+    -- which we shouldn't use.+    (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags+    flags_1_23_0 = flags_1_25_0 { configProfDetail    = NoFlag                                 , configProfLibDetail = NoFlag-                                , configIPID          = NoFlag }+                                , configIPID          = NoFlag+                                , configProf          = NoFlag+                                , configProfExe       = Flag tryExeProfiling+                                , configProfLib       = Flag tryLibProfiling+                                }      -- Cabal < 1.22 doesn't know about '--disable-debug-info'.-    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }+    flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag }      -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'     -- Cabal < 1.21.1 doesn't know about 'enable-profiling'-    flags_1_20_0 =-      flags_1_21_0 { configRelocatable = NoFlag-                   , configProf = NoFlag-                   , configProfExe = configProf flags-                   , configProfLib =-                     mappend (configProf flags) (configProfLib flags)+    -- (but we already dealt with it in flags_1_23_0)+    flags_1_21_1 =+      flags_1_22_0 { configRelocatable = NoFlag                    , configCoverage = NoFlag                    , configLibCoverage = configCoverage flags                    }     -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and     -- '--enable-library-stripping'.-    flags_1_19_1 = flags_1_20_0 { configExactConfiguration = NoFlag+    flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag                                 , configStripLibs = NoFlag }     -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.-    flags_1_19_0 = flags_1_19_1 { configDependencies = []+    flags_1_19_1 = flags_1_19_2 { configDependencies = []                                 , configConstraints  = configConstraints flags }     -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.-    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []+    flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList []                                 , configInstallDirs = configInstallDirs_1_18_0}-    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }+    configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag }     -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.     flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }     -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'@@ -412,6 +440,21 @@     -- Cabal < 1.3.10 does not grok the '--constraints' flag.     flags_1_3_10 = flags_1_10_0 { configConstraints = [] } +-- | Get the package database settings from 'ConfigFlags', accounting for+-- @--package-db@ and @--user@ flags.+configPackageDB' :: ConfigFlags -> PackageDBStack+configPackageDB' cfg =+    interpretPackageDbFlags userInstall (configPackageDBs cfg)+  where+    userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg)++-- | Configure the compiler, but reduce verbosity during this step.+configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb)+configCompilerAux' configFlags =+  configCompilerAuxEx configFlags+    --FIXME: make configCompilerAux use a sensible verbosity+    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }+ -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------@@ -480,6 +523,28 @@ instance Semigroup ConfigExFlags where   (<>) = gmappend +reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags)+reconfigureCommand+  = configureExCommand+    { commandName         = "reconfigure"+    , commandSynopsis     = "Reconfigure the package if necessary."+    , commandDescription  = Just $ \pname -> wrapText $+         "Run `configure` with the most recently used flags, or append FLAGS "+         ++ "to the most recently used configuration. "+         ++ "Accepts the same flags as `" ++ pname ++ " configure'. "+         ++ "If the package has never been configured, the default flags are "+         ++ "used."+    , commandNotes        = Just $ \pname ->+        "Examples:\n"+        ++ "  " ++ pname ++ " reconfigure\n"+        ++ "    Configure with the most recently used flags.\n"+        ++ "  " ++ pname ++ " reconfigure -w PATH\n"+        ++ "    Reconfigure with the most recently used flags,\n"+        ++ "    but use the compiler at PATH.\n\n"+    , commandUsage        = usageAlternatives "reconfigure" [ "[FLAGS]" ]+    , commandDefaultFlags = mempty+    }+ -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------@@ -514,7 +579,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    parent = Cabal.buildCommand defaultProgramConfiguration+    parent = Cabal.buildCommand defaultProgramDb  instance Monoid BuildExFlags where   mempty = gmempty@@ -540,7 +605,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    parent = Cabal.replCommand defaultProgramConfiguration+    parent = Cabal.replCommand defaultProgramDb  -- ------------------------------------------------------------ -- * Test command@@ -555,7 +620,7 @@                         (commandOptions parent showOrParseArgs)                         ++                         liftOptions get2 set2-                        (Cabal.buildOptions progConf showOrParseArgs)+                        (Cabal.buildOptions progDb showOrParseArgs)                         ++                         liftOptions get3 set3 (buildExOptions showOrParseArgs)   }@@ -564,8 +629,8 @@     get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)     get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) -    parent   = Cabal.testCommand-    progConf = defaultProgramConfiguration+    parent = Cabal.testCommand+    progDb = defaultProgramDb  -- ------------------------------------------------------------ -- * Bench command@@ -580,7 +645,7 @@                         (commandOptions parent showOrParseArgs)                         ++                         liftOptions get2 set2-                        (Cabal.buildOptions progConf showOrParseArgs)+                        (Cabal.buildOptions progDb showOrParseArgs)                         ++                         liftOptions get3 set3 (buildExOptions showOrParseArgs)   }@@ -589,8 +654,8 @@     get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)     get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) -    parent   = Cabal.benchmarkCommand-    progConf = defaultProgramConfiguration+    parent = Cabal.benchmarkCommand+    progDb = defaultProgramDb  -- ------------------------------------------------------------ -- * Fetch command@@ -602,10 +667,11 @@       fetchDryRun    :: Flag Bool,       fetchSolver           :: Flag PreSolver,       fetchMaxBackjumps     :: Flag Int,-      fetchReorderGoals     :: Flag Bool,-      fetchIndependentGoals :: Flag Bool,-      fetchShadowPkgs       :: Flag Bool,-      fetchStrongFlags      :: Flag Bool,+      fetchReorderGoals     :: Flag ReorderGoals,+      fetchCountConflicts   :: Flag CountConflicts,+      fetchIndependentGoals :: Flag IndependentGoals,+      fetchShadowPkgs       :: Flag ShadowPkgs,+      fetchStrongFlags      :: Flag StrongFlags,       fetchVerbosity :: Flag Verbosity     } @@ -616,10 +682,11 @@     fetchDryRun    = toFlag False,     fetchSolver           = Flag defaultSolver,     fetchMaxBackjumps     = Flag defaultMaxBackjumps,-    fetchReorderGoals     = Flag False,-    fetchIndependentGoals = Flag False,-    fetchShadowPkgs       = Flag False,-    fetchStrongFlags      = Flag False,+    fetchReorderGoals     = Flag (ReorderGoals False),+    fetchCountConflicts   = Flag (CountConflicts True),+    fetchIndependentGoals = Flag (IndependentGoals False),+    fetchShadowPkgs       = Flag (ShadowPkgs False),+    fetchStrongFlags      = Flag (StrongFlags False),     fetchVerbosity = toFlag normal    } @@ -663,6 +730,7 @@        optionSolverFlags showOrParseArgs                          fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })                          fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })+                         fetchCountConflicts   (\v flags -> flags { fetchCountConflicts   = v })                          fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })                          fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })                          fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })@@ -679,10 +747,11 @@       freezeBenchmarks       :: Flag Bool,       freezeSolver           :: Flag PreSolver,       freezeMaxBackjumps     :: Flag Int,-      freezeReorderGoals     :: Flag Bool,-      freezeIndependentGoals :: Flag Bool,-      freezeShadowPkgs       :: Flag Bool,-      freezeStrongFlags      :: Flag Bool,+      freezeReorderGoals     :: Flag ReorderGoals,+      freezeCountConflicts   :: Flag CountConflicts,+      freezeIndependentGoals :: Flag IndependentGoals,+      freezeShadowPkgs       :: Flag ShadowPkgs,+      freezeStrongFlags      :: Flag StrongFlags,       freezeVerbosity        :: Flag Verbosity     } @@ -693,10 +762,11 @@     freezeBenchmarks       = toFlag False,     freezeSolver           = Flag defaultSolver,     freezeMaxBackjumps     = Flag defaultMaxBackjumps,-    freezeReorderGoals     = Flag False,-    freezeIndependentGoals = Flag False,-    freezeShadowPkgs       = Flag False,-    freezeStrongFlags      = Flag False,+    freezeReorderGoals     = Flag (ReorderGoals False),+    freezeCountConflicts   = Flag (CountConflicts True),+    freezeIndependentGoals = Flag (IndependentGoals False),+    freezeShadowPkgs       = Flag (ShadowPkgs False),+    freezeStrongFlags      = Flag (StrongFlags False),     freezeVerbosity        = toFlag normal    } @@ -739,6 +809,7 @@        optionSolverFlags showOrParseArgs                          freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })                          freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })+                         freezeCountConflicts   (\v flags -> flags { freezeCountConflicts   = v })                          freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })                          freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })                          freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })@@ -882,7 +953,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    parent = Cabal.buildCommand defaultProgramConfiguration+    parent = Cabal.buildCommand defaultProgramDb  -- ------------------------------------------------------------ -- * Report flags@@ -1140,16 +1211,18 @@     installHaddockIndex     :: Flag PathTemplate,     installDryRun           :: Flag Bool,     installMaxBackjumps     :: Flag Int,-    installReorderGoals     :: Flag Bool,-    installIndependentGoals :: Flag Bool,-    installShadowPkgs       :: Flag Bool,-    installStrongFlags      :: Flag Bool,+    installReorderGoals     :: Flag ReorderGoals,+    installCountConflicts   :: Flag CountConflicts,+    installIndependentGoals :: Flag IndependentGoals,+    installShadowPkgs       :: Flag ShadowPkgs,+    installStrongFlags      :: Flag StrongFlags,     installReinstall        :: Flag Bool,-    installAvoidReinstalls  :: Flag Bool,+    installAvoidReinstalls  :: Flag AvoidReinstalls,     installOverrideReinstall :: Flag Bool,     installUpgradeDeps      :: Flag Bool,     installOnly             :: Flag Bool,     installOnlyDeps         :: Flag Bool,+    installIndexState       :: Flag IndexState,     installRootCmd          :: Flag String,     installSummaryFile      :: NubList PathTemplate,     installLogFile          :: Flag PathTemplate,@@ -1158,6 +1231,7 @@     installSymlinkBinDir    :: Flag FilePath,     installOneShot          :: Flag Bool,     installNumJobs          :: Flag (Maybe Int),+    installKeepGoing        :: Flag Bool,     installRunTests         :: Flag Bool,     installOfflineMode      :: Flag Bool   }@@ -1171,16 +1245,18 @@     installHaddockIndex    = Flag docIndexFile,     installDryRun          = Flag False,     installMaxBackjumps    = Flag defaultMaxBackjumps,-    installReorderGoals    = Flag False,-    installIndependentGoals= Flag False,-    installShadowPkgs      = Flag False,-    installStrongFlags     = Flag False,+    installReorderGoals    = Flag (ReorderGoals False),+    installCountConflicts  = Flag (CountConflicts True),+    installIndependentGoals= Flag (IndependentGoals False),+    installShadowPkgs      = Flag (ShadowPkgs False),+    installStrongFlags     = Flag (StrongFlags False),     installReinstall       = Flag False,-    installAvoidReinstalls = Flag False,+    installAvoidReinstalls = Flag (AvoidReinstalls False),     installOverrideReinstall = Flag False,     installUpgradeDeps     = Flag False,     installOnly            = Flag False,     installOnlyDeps        = Flag False,+    installIndexState      = mempty,     installRootCmd         = mempty,     installSummaryFile     = mempty,     installLogFile         = mempty,@@ -1189,6 +1265,7 @@     installSymlinkBinDir   = mempty,     installOneShot         = Flag False,     installNumJobs         = mempty,+    installKeepGoing       = Flag False,     installRunTests        = mempty,     installOfflineMode     = Flag False   }@@ -1200,7 +1277,7 @@ defaultMaxBackjumps = 2000  defaultSolver :: PreSolver-defaultSolver = Choose+defaultSolver = AlwaysModular  allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver]))@@ -1241,7 +1318,7 @@      ++ " continue working as long as bindir and datadir are left untouched.",   commandNotes        = Just $ \pname ->         ( case commandNotes-               $ Cabal.configureCommand defaultProgramConfiguration+               $ Cabal.configureCommand defaultProgramDb           of Just desc -> desc pname ++ "\n"              Nothing   -> ""         )@@ -1316,6 +1393,7 @@       optionSolverFlags showOrParseArgs                         installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })                         installReorderGoals     (\v flags -> flags { installReorderGoals     = v })+                        installCountConflicts   (\v flags -> flags { installCountConflicts   = v })                         installIndependentGoals (\v flags -> flags { installIndependentGoals = v })                         installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })                         installStrongFlags      (\v flags -> flags { installStrongFlags      = v }) ++@@ -1327,7 +1405,8 @@        , option [] ["avoid-reinstalls"]           "Do not select versions that would destructively overwrite installed packages."-          installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v })+          (fmap asBool . installAvoidReinstalls)+          (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v })           (yesNoOpt showOrParseArgs)        , option [] ["force-reinstalls"]@@ -1350,8 +1429,20 @@           installOnlyDeps (\v flags -> flags { installOnlyDeps = v })           (yesNoOpt showOrParseArgs) +      , option [] ["index-state"]+          ("Use source package index state as it existed at a previous time. " +++           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " +++           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")+          installIndexState (\v flags -> flags { installIndexState = v })+          (reqArg "STATE" (readP_to_E (const $ "index-state must be a  " +++                                       "unix-timestamps (e.g. '@1474732068'), " +++                                       "a ISO8601 UTC timestamp " +++                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))+       , option [] ["root-cmd"]-          "Command used to gain root privileges, when installing with --global."+          "(No longer supported, do not use.)"           installRootCmd (\v flags -> flags { installRootCmd = v })           (reqArg' "COMMAND" toFlag flagToList) @@ -1397,6 +1488,11 @@       , optionNumJobs         installNumJobs (\v flags -> flags { installNumJobs = v }) +      , option [] ["keep-going"]+          "After a build failure, continue to build other unaffected packages."+          installKeepGoing (\v flags -> flags { installKeepGoing = v })+          trueArg+       , option [] ["offline"]           "Don't download packages from the Internet."           installOfflineMode (\v flags -> flags { installOfflineMode = v })@@ -1422,8 +1518,12 @@ -- * Upload flags -- ------------------------------------------------------------ +-- | Is this a candidate package or a package to be published?+data IsCandidate = IsCandidate | IsPublished+                 deriving Eq+ data UploadFlags = UploadFlags {-    uploadCheck       :: Flag Bool,+    uploadCandidate   :: Flag IsCandidate,     uploadDoc         :: Flag Bool,     uploadUsername    :: Flag Username,     uploadPassword    :: Flag Password,@@ -1433,7 +1533,7 @@  defaultUploadFlags :: UploadFlags defaultUploadFlags = UploadFlags {-    uploadCheck       = toFlag False,+    uploadCandidate   = toFlag IsCandidate,     uploadDoc         = toFlag False,     uploadUsername    = mempty,     uploadPassword    = mempty,@@ -1453,15 +1553,19 @@          "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n",     commandDefaultFlags = defaultUploadFlags,     commandOptions      = \_ ->-      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })+      [optionVerbosity uploadVerbosity+       (\v flags -> flags { uploadVerbosity = v }) -      ,option ['c'] ["check"]-         "Do not upload, just do QA checks."-        uploadCheck (\v flags -> flags { uploadCheck = v })-        trueArg+      ,option [] ["publish"]+        "Publish the package instead of uploading it as a candidate."+        uploadCandidate (\v flags -> flags { uploadCandidate = v })+        (noArg (Flag IsPublished))        ,option ['d'] ["documentation"]-        "Upload documentation instead of a source package. Cannot be used together with --check."+        ("Upload documentation instead of a source package. "+        ++ "By default, this uploads documentation for a package candidate. "+        ++ "To upload documentation for "+        ++ "a published package, combine with --publish.")         uploadDoc (\v flags -> flags { uploadDoc = v })         trueArg @@ -1673,9 +1777,6 @@       , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })       ]   }-  where readMaybe s = case reads s of-                        [(x,"")]  -> Just x-                        _         -> Nothing  -- ------------------------------------------------------------ -- * SDist flags@@ -1688,7 +1789,7 @@   }   deriving (Show, Generic) -data ArchiveFormat = TargzFormat | ZipFormat -- | ...+data ArchiveFormat = TargzFormat | ZipFormat -- ...   deriving (Show, Eq)  defaultSDistExFlags :: SDistExFlags@@ -2057,7 +2158,7 @@              -> OptionField flags optionSolver get set =   option [] ["solver"]-    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ", where 'choose' chooses between 'topdown' and 'modular' based on compiler version.")+    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")     get set     (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers)                                  (toFlag `fmap` parse))@@ -2065,12 +2166,13 @@  optionSolverFlags :: ShowOrParseArgs                   -> (flags -> Flag Int   ) -> (Flag Int    -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)+                  -> (flags -> Flag ReorderGoals)     -> (Flag ReorderGoals     -> flags -> flags)+                  -> (flags -> Flag CountConflicts)   -> (Flag CountConflicts   -> flags -> flags)+                  -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)+                  -> (flags -> Flag ShadowPkgs)       -> (Flag ShadowPkgs       -> flags -> flags)+                  -> (flags -> Flag StrongFlags)      -> (Flag StrongFlags      -> flags -> flags)                   -> [OptionField flags]-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip getstrfl setstrfl =+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig getsip setsip getstrfl setstrfl =   [ option [] ["max-backjumps"]       ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")       getmbj setmbj@@ -2078,22 +2180,31 @@                     (map show . flagToList))   , option [] ["reorder-goals"]       "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."-      getrg setrg+      (fmap asBool . getrg)+      (setrg . fmap ReorderGoals)       (yesNoOpt showOrParseArgs)-  -- TODO: Disabled for now because it does not work as advertised (yet).+  , option [] ["count-conflicts"]+      "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)."+      (fmap asBool . getcc)+      (setcc . fmap CountConflicts)+      (yesNoOpt showOrParseArgs)+  -- TODO: Disabled for now because it may not be necessary {-   , option [] ["independent-goals"]       "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen."-      getig setig+      (fmap asBool . getig)+      (setig . fmap IndependentGoals)       (yesNoOpt showOrParseArgs) -}   , option [] ["shadow-installed-packages"]       "If multiple package instances of the same version are installed, treat all but one as shadowed."-      getsip setsip+      (fmap asBool . getsip)+      (setsip . fmap ShadowPkgs)       (yesNoOpt showOrParseArgs)   , option [] ["strong-flags"]       "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."-      getstrfl setstrfl+      (fmap asBool . getstrfl)+      (setstrfl . fmap StrongFlags)       (yesNoOpt showOrParseArgs)   ] @@ -2127,8 +2238,8 @@   where     pkgidToDependency :: PackageIdentifier -> Dependency     pkgidToDependency p = case packageVersion p of-      Version [] _ -> Dependency (packageName p) anyVersion-      version      -> Dependency (packageName p) (thisVersion version)+      v | v == nullVersion -> Dependency (packageName p) anyVersion+        | otherwise        -> Dependency (packageName p) (thisVersion v)  showRepo :: RemoteRepo -> String showRepo repo = remoteRepoName repo ++ ":"
cabal/cabal-install/Distribution/Client/SetupWrapper.hs view
@@ -16,22 +16,24 @@ -- runs it with the given arguments.  module Distribution.Client.SetupWrapper (-    setupWrapper,+    getSetup, runSetup, runSetupCommand, setupWrapper,     SetupScriptOptions(..),     defaultSetupScriptOptions,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version-         ( Version(..), VersionRange, anyVersion+         ( Version, mkVersion, versionNumbers, VersionRange, anyVersion          , intersectVersionRanges, orLaterVersion          , withinRange )-import Distribution.InstalledPackageInfo (installedUnitId)+import qualified Distribution.Backpack as Backpack import Distribution.Package-         ( UnitId(..), PackageIdentifier(..), PackageId,-           PackageName(..), Package(..), packageName-         , packageVersion, Dependency(..) )+         ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId, PackageId, mkPackageName+         , PackageIdentifier(..), packageVersion, packageName, Dependency(..) ) import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)          , PackageDescription(..), specVersion@@ -49,11 +51,11 @@ import Distribution.Simple.Build.Macros          ( generatePackageVersionMacros ) import Distribution.Simple.Program-         ( ProgramConfiguration, emptyProgramConfiguration+         ( ProgramDb, emptyProgramDb          , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram          , ghcjsProgram ) import Distribution.Simple.Program.Find-         ( programSearchPathAsPATHVar )+         ( programSearchPathAsPATHVar, ProgramSearchPathEntry(ProgramSearchPathDir) ) import Distribution.Simple.Program.Run          ( getEffectiveEnvironment ) import qualified Distribution.Simple.Program.Strip as Strip@@ -66,6 +68,8 @@          ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Client.Types import Distribution.Client.Config          ( defaultCabalDir ) import Distribution.Client.IndexUtils@@ -77,11 +81,11 @@ import Distribution.Simple.Utils          ( die, debug, info, cabalVersion, tryFindPackageDesc, comparing          , createDirectoryIfMissingVerbose, installExecutableFile-         , copyFileVerbose, rewriteFile, intercalate )+         , copyFileVerbose, rewriteFile ) import Distribution.Client.Utils-         ( inDir, tryCanonicalizePath-         , existsAndIsMoreRecentThan, moreRecentFile-#if mingw32_HOST_OS+         ( inDir, tryCanonicalizePath, withExtraPathEnv+         , existsAndIsMoreRecentThan, moreRecentFile, withEnv+#ifdef mingw32_HOST_OS          , canonicalizePathNoThrow #endif          )@@ -91,7 +95,7 @@ import Distribution.Utils.NubList          ( toNubListR ) import Distribution.Verbosity-         ( Verbosity )+         ( Verbosity, normal ) import Distribution.Compat.Exception          ( catchIO ) @@ -99,15 +103,10 @@ import System.FilePath     ( (</>), (<.>) ) import System.IO           ( Handle, hPutStr ) import System.Exit         ( ExitCode(..), exitWith )-import System.Process      ( runProcess, waitForProcess )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ( (<$>), (<*>) )-import Data.Monoid         ( mempty )-#endif-import Control.Monad       ( when, unless )+import System.Process      ( createProcess, StdStream(..), proc, waitForProcess+                           , ProcessHandle )+import qualified System.Process as Process import Data.List           ( foldl1' )-import Data.Maybe          ( fromMaybe, isJust )-import Data.Char           ( isSpace ) import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath )  #ifdef mingw32_HOST_OS@@ -120,6 +119,25 @@ import qualified System.Win32 as Win32 #endif +-- | @Setup@ encapsulates the outcome of configuring a setup method to build a+-- particular package.+data Setup = Setup { setupMethod :: SetupMethod+                   , setupScriptOptions :: SetupScriptOptions+                   , setupVersion :: Version+                   , setupBuildType :: BuildType+                   , setupPackage :: PackageDescription+                   }++-- | @SetupMethod@ represents one of the methods used to run Cabal commands.+data SetupMethod = InternalMethod+                   -- ^ run Cabal commands through \"cabal\" in the+                   -- current process+                 | SelfExecMethod+                   -- ^ run Cabal commands through \"cabal\" as a+                   -- child process+                 | ExternalMethod FilePath+                   -- ^ run Cabal commands through a custom \"Setup\" executable+ --TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two -- parts: one that has no policy and just does as it's told with all the -- explicit options, and an optional initial part that applies certain@@ -129,6 +147,8 @@ -- -- See also the discussion at https://github.com/haskell/cabal/pull/3094 +-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as+-- opposed to options given to the Cabal command at runtime. data SetupScriptOptions = SetupScriptOptions {     -- | The version of the Cabal library to use (if 'useDependenciesExclusive'     -- is not set). A suitable version of the Cabal library must be installed@@ -155,21 +175,24 @@     usePlatform              :: Maybe Platform,     usePackageDB             :: PackageDBStack,     usePackageIndex          :: Maybe InstalledPackageIndex,-    useProgramConfig         :: ProgramConfiguration,+    useProgramDb             :: ProgramDb,     useDistPref              :: FilePath,     useLoggingHandle         :: Maybe Handle,     useWorkingDir            :: Maybe FilePath,+    -- | Extra things to add to PATH when invoking the setup script.+    useExtraPathEnv          :: [FilePath],     forceExternalSetupMethod :: Bool, -    -- | List of dependencies to use when building Setup.hs-    useDependencies :: [(UnitId, PackageId)],+    -- | List of dependencies to use when building Setup.hs.+    useDependencies :: [(ComponentId, PackageId)],      -- | Is the list of setup dependencies exclusive?     ---    -- When this is @False@, if we compile the Setup.hs script we do so with-    -- the list in 'useDependencies' but all other packages in the environment-    -- are also visible. Additionally, a suitable version of @Cabal@ library-    -- is added to the list of dependencies (see 'useCabalVersion').+    -- When this is @False@, if we compile the Setup.hs script we do so with the+    -- list in 'useDependencies' but all other packages in the environment are+    -- also visible. A suitable version of @Cabal@ library (see+    -- 'useCabalVersion') is also added to the list of dependencies, unless+    -- 'useDependencies' already contains a Cabal dependency.     --     -- When @True@, only the 'useDependencies' packages are used, with other     -- packages in the environment hidden.@@ -208,7 +231,12 @@     -- version) combination the cache holds a compiled setup script     -- executable. This only affects the Simple build type; for the Custom,     -- Configure and Make build types we always compile the setup script anew.-    setupCacheLock           :: Maybe Lock+    setupCacheLock           :: Maybe Lock,++    -- | Is the task we are going to run an interactive foreground task,+    -- or an non-interactive background task? Based on this flag we+    -- decide whether or not to delegate ctrl+c to the spawned task+    isInteractive            :: Bool   }  defaultSetupScriptOptions :: SetupScriptOptions@@ -222,36 +250,55 @@     useDependencies          = [],     useDependenciesExclusive = False,     useVersionMacros         = False,-    useProgramConfig         = emptyProgramConfiguration,+    useProgramDb             = emptyProgramDb,     useDistPref              = defaultDistPref,     useLoggingHandle         = Nothing,     useWorkingDir            = Nothing,+    useExtraPathEnv          = [],     useWin32CleanHack        = False,     forceExternalSetupMethod = False,-    setupCacheLock           = Nothing+    setupCacheLock           = Nothing,+    isInteractive            = False   } -setupWrapper :: Verbosity-             -> SetupScriptOptions-             -> Maybe PackageDescription-             -> CommandUI flags-             -> (Version -> flags)-             -> [String]-             -> IO ()-setupWrapper verbosity options mpkg cmd flags extraArgs = do+workingDir :: SetupScriptOptions -> FilePath+workingDir options =+  case fromMaybe "" (useWorkingDir options) of+    []  -> "."+    dir -> dir++-- | A @SetupRunner@ implements a 'SetupMethod'.+type SetupRunner = Verbosity+                 -> SetupScriptOptions+                 -> BuildType+                 -> [String]+                 -> IO ()++-- | Prepare to build a package by configuring a 'SetupMethod'. The returned+-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed+-- during the configuration process; the final values are given by+-- 'setupScriptOptions'.+getSetup :: Verbosity+         -> SetupScriptOptions+         -> Maybe PackageDescription+         -> IO Setup+getSetup verbosity options mpkg = do   pkg <- maybe getPkg return mpkg-  let setupMethod = determineSetupMethod options' buildType'-      options'    = options {+  let options'    = options {                       useCabalVersion = intersectVersionRanges                                           (useCabalVersion options)                                           (orLaterVersion (specVersion pkg))                     }       buildType'  = fromMaybe Custom (buildType pkg)-      mkArgs cabalLibVersion = commandName cmd-                             : commandShowOptions cmd (flags cabalLibVersion)-                            ++ extraArgs   checkBuildType buildType'-  setupMethod verbosity options' (packageId pkg) buildType' mkArgs+  (version, method, options'') <-+    getSetupMethod verbosity options' pkg buildType'+  return Setup { setupMethod = method+               , setupScriptOptions = options''+               , setupVersion = version+               , setupBuildType = buildType'+               , setupPackage = pkg+               }   where     getPkg = tryFindPackageDesc (fromMaybe "." (useWorkingDir options))          >>= readPackageDescription verbosity@@ -262,48 +309,77 @@          ++ intercalate ", " (map display knownBuildTypes) ++ "."     checkBuildType _ = return () + -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script. ---determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod-determineSetupMethod options buildType'-    -- This order is picked so that it's stable. The build type and-    -- required cabal version are external info, coming from .cabal-    -- files and the command line. Those do switch between the-    -- external and self & internal methods, but that info itself can-    -- be considered stable. The logging and force-external conditions-    -- are internally generated choices but now these only switch-    -- between the self and internal setup methods, which are-    -- consistent with each other.-  | buildType' == Custom             = externalSetupMethod-  | maybe False (cabalVersion /=)-        (useCabalSpecVersion options)- || not (cabalVersion `withinRange`-         useCabalVersion options)    = externalSetupMethod+getSetupMethod+  :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType+  -> IO (Version, SetupMethod, SetupScriptOptions)+getSetupMethod verbosity options pkg buildType'+  | buildType' == Custom+    || maybe False (cabalVersion /=) (useCabalSpecVersion options)+    || not (cabalVersion `withinRange` useCabalVersion options)    =+         getExternalSetupMethod verbosity options pkg buildType'   | isJust (useLoggingHandle options)     -- Forcing is done to use an external process e.g. due to parallel     -- build concerns.- || forceExternalSetupMethod options = selfExecSetupMethod-  | otherwise                        = internalSetupMethod+    || forceExternalSetupMethod options =+        return (cabalVersion, SelfExecMethod, options)+  | otherwise = return (cabalVersion, InternalMethod, options) -type SetupMethod = Verbosity-                -> SetupScriptOptions-                -> PackageIdentifier-                -> BuildType-                -> (Version -> [String]) -> IO ()+runSetupMethod :: SetupMethod -> SetupRunner+runSetupMethod InternalMethod = internalSetupMethod+runSetupMethod (ExternalMethod path) = externalSetupMethod path+runSetupMethod SelfExecMethod = selfExecSetupMethod +-- | Run a configured 'Setup' with specific arguments.+runSetup :: Verbosity -> Setup+         -> [String]  -- ^ command-line arguments+         -> IO ()+runSetup verbosity setup args =+  let method = setupMethod setup+      options = setupScriptOptions setup+      bt = setupBuildType setup+  in runSetupMethod method verbosity options bt args++-- | Run a command through a configured 'Setup'.+runSetupCommand :: Verbosity -> Setup+                -> CommandUI flags  -- ^ command definition+                -> flags  -- ^ command flags+                -> [String]  -- ^ extra command-line arguments+                -> IO ()+runSetupCommand verbosity setup cmd flags extraArgs = do+  let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs+  runSetup verbosity setup args++-- | Configure a 'Setup' and run a command in one step. The command flags+-- may depend on the Cabal library version in use.+setupWrapper :: Verbosity+             -> SetupScriptOptions+             -> Maybe PackageDescription+             -> CommandUI flags+             -> (Version -> flags)+                -- ^ produce command flags given the Cabal library version+             -> [String]+             -> IO ()+setupWrapper verbosity options mpkg cmd flags extraArgs = do+  setup <- getSetup verbosity options mpkg+  runSetupCommand verbosity setup cmd (flags $ setupVersion setup) extraArgs+ -- ------------------------------------------------------------ -- * Internal SetupMethod -- ------------------------------------------------------------ -internalSetupMethod :: SetupMethod-internalSetupMethod verbosity options _ bt mkargs = do-  let args = mkargs cabalVersion-  debug verbosity $ "Using internal setup method with build-type " ++ show bt-                 ++ " and args:\n  " ++ show args-  inDir (useWorkingDir options) $-    buildTypeAction bt args+internalSetupMethod :: SetupRunner+internalSetupMethod verbosity options bt args = do+  info verbosity $ "Using internal setup method with build-type " ++ show bt+                ++ " and args:\n  " ++ show args+  inDir (useWorkingDir options) $ do+    withEnv "HASKELL_DIST_DIR" (useDistPref options) $+      withExtraPathEnv (useExtraPathEnv options) $+        buildTypeAction bt args  buildTypeAction :: BuildType -> ([String] -> IO ()) buildTypeAction Simple    = Simple.defaultMainArgs@@ -313,16 +389,46 @@ buildTypeAction Custom               = error "buildTypeAction Custom" buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" ++-- | @runProcess'@ is a version of @runProcess@ where we have+-- the additional option to decide whether or not we should+-- delegate CTRL+C to the spawned process.+runProcess' :: FilePath                 -- ^ Filename of the executable+            -> [String]                 -- ^ Arguments to pass to executable+            -> Maybe FilePath           -- ^ Optional path to working directory+            -> Maybe [(String, String)] -- ^ Optional environment+            -> Maybe Handle             -- ^ Handle for @stdin@+            -> Maybe Handle             -- ^ Handle for @stdout@+            -> Maybe Handle             -- ^ Handle for @stderr@+            -> Bool                     -- ^ Delegate Ctrl+C ?+            -> IO ProcessHandle+runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do+  (_,_,_,ph) <-+    createProcess+      (proc cmd args){ Process.cwd = mb_cwd+                     , Process.env = mb_env+                     , Process.std_in  = mbToStd mb_stdin+                     , Process.std_out = mbToStd mb_stdout+                     , Process.std_err = mbToStd mb_stderr+#if MIN_VERSION_process(1,2,0)+                     , Process.delegate_ctlc = _delegate+#endif+                     }+  return ph+  where+    mbToStd :: Maybe Handle -> StdStream+    mbToStd Nothing = Inherit+    mbToStd (Just hdl) = UseHandle hdl -- ------------------------------------------------------------ -- * Self-Exec SetupMethod -- ------------------------------------------------------------ -selfExecSetupMethod :: SetupMethod-selfExecSetupMethod verbosity options _pkg bt mkargs = do+selfExecSetupMethod :: SetupRunner+selfExecSetupMethod verbosity options bt args0 = do   let args = ["act-as-setup",               "--build-type=" ++ display bt,-              "--"] ++ mkargs cabalVersion-  debug verbosity $ "Using self-exec internal setup method with build-type "+              "--"] ++ args0+  info verbosity $ "Using self-exec internal setup method with build-type "                  ++ show bt ++ " and args:\n  " ++ show args   path <- getExecutablePath   info verbosity $ unwords (path : args)@@ -332,12 +438,14 @@                                     ++ show logHandle    searchpath <- programSearchPathAsPATHVar-                (getProgramSearchPath (useProgramConfig options))-  env        <- getEffectiveEnvironment [("PATH", Just searchpath)]--  process <- runProcess path args+                (map ProgramSearchPathDir (useExtraPathEnv options) +++                 getProgramSearchPath (useProgramDb options))+  env       <- getEffectiveEnvironment [("PATH", Just searchpath)+                                        ,("HASKELL_DIST_DIR", Just (useDistPref options))]+  process <- runProcess' path args              (useWorkingDir options) env Nothing              (useLoggingHandle options) (useLoggingHandle options)+             (isInteractive options)   exitCode <- waitForProcess process   unless (exitCode == ExitSuccess) $ exitWith exitCode @@ -345,8 +453,62 @@ -- * External SetupMethod -- ------------------------------------------------------------ -externalSetupMethod :: SetupMethod-externalSetupMethod verbosity options pkg bt mkargs = do+externalSetupMethod :: FilePath -> SetupRunner+externalSetupMethod path verbosity options _ args = do+  info verbosity $ unwords (path : args)+  case useLoggingHandle options of+    Nothing        -> return ()+    Just logHandle -> info verbosity $ "Redirecting build log to "+                                    ++ show logHandle++  -- See 'Note: win32 clean hack' above.+#ifdef mingw32_HOST_OS+  if useWin32CleanHack options then doWin32CleanHack path else doInvoke path+#else+  doInvoke path+#endif++  where+    doInvoke path' = do+      searchpath <- programSearchPathAsPATHVar+                    (map ProgramSearchPathDir (useExtraPathEnv options) +++                      getProgramSearchPath (useProgramDb options))+      env        <- getEffectiveEnvironment [("PATH", Just searchpath)+                                            ,("HASKELL_DIST_DIR", Just (useDistPref options))]++      process <- runProcess' path' args+                  (useWorkingDir options) env Nothing+                  (useLoggingHandle options) (useLoggingHandle options)+                  (isInteractive options)+      exitCode <- waitForProcess process+      unless (exitCode == ExitSuccess) $ exitWith exitCode++#ifdef mingw32_HOST_OS+    doWin32CleanHack path' = do+      info verbosity $ "Using the Win32 clean hack."+      -- Recursively removes the temp dir on exit.+      withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir ->+          bracket (moveOutOfTheWay tmpDir path')+                  (maybeRestore path')+                  doInvoke++    moveOutOfTheWay tmpDir path' = do+      let newPath = tmpDir </> "setup" <.> exeExtension+      Win32.moveFile path' newPath+      return newPath++    maybeRestore oldPath path' = do+      let oldPathDir = takeDirectory oldPath+      oldPathDirExists <- doesDirectoryExist oldPathDir+      -- 'setup clean' didn't complete, 'dist/setup' still exists.+      when oldPathDirExists $+        Win32.moveFile path' oldPath+#endif++getExternalSetupMethod+  :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType+  -> IO (Version, SetupMethod, SetupScriptOptions)+getExternalSetupMethod verbosity options pkg bt = do   debug verbosity $ "Using external setup method with build-type " ++ show bt   debug verbosity $ "Using explicit dependencies: "     ++ show (useDependenciesExclusive options)@@ -358,13 +520,29 @@                cabalLibVersion mCabalLibInstalledPkgId           else compileSetupExecutable   options'                cabalLibVersion mCabalLibInstalledPkgId False-  invokeSetupScript options' path (mkargs cabalLibVersion) +  -- Since useWorkingDir can change the relative path, the path argument must+  -- be turned into an absolute path. On some systems, runProcess' will take+  -- path as relative to the new working directory instead of the current+  -- working directory.+  path' <- tryCanonicalizePath path++  -- See 'Note: win32 clean hack' above.+#ifdef mingw32_HOST_OS+  -- setupProgFile may not exist if we're using a cached program+  setupProgFile' <- canonicalizePathNoThrow setupProgFile+  let win32CleanHackNeeded = (useWin32CleanHack options)+                              -- Skip when a cached setup script is used.+                              && setupProgFile' `equalFilePath` path'+#else+  let win32CleanHackNeeded = False+#endif+  let options'' = options' { useWin32CleanHack = win32CleanHackNeeded }++  return (cabalLibVersion, ExternalMethod path', options'')+   where-  workingDir       = case fromMaybe "" (useWorkingDir options) of-                       []  -> "."-                       dir -> dir-  setupDir         = workingDir </> useDistPref options </> "setup"+  setupDir         = workingDir options </> useDistPref options </> "setup"   setupVersionFile = setupDir   </> "setup" <.> "version"   setupHs          = setupDir   </> "setup" <.> "hs"   setupProgFile    = setupDir   </> "setup" <.> exeExtension@@ -373,33 +551,52 @@   useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)    maybeGetInstalledPackages :: SetupScriptOptions -> Compiler-                            -> ProgramConfiguration -> IO InstalledPackageIndex-  maybeGetInstalledPackages options' comp conf =+                            -> ProgramDb -> IO InstalledPackageIndex+  maybeGetInstalledPackages options' comp progdb =     case usePackageIndex options' of       Just index -> return index       Nothing    -> getInstalledPackages verbosity-                    comp (usePackageDB options') conf+                    comp (usePackageDB options') progdb -  cabalLibVersionToUse :: IO (Version, (Maybe UnitId)+  -- Choose the version of Cabal to use if the setup script has a dependency on+  -- Cabal, and possibly update the setup script options. The version also+  -- determines how to filter the flags to Setup.+  --+  -- We first check whether the dependency solver has specified a Cabal version.+  -- If it has, we use the solver's version without looking at the installed+  -- package index (See issue #3436). Otherwise, we pick the Cabal version by+  -- checking 'useCabalSpecVersion', then the saved version, and finally the+  -- versions available in the index.+  --+  -- The version chosen here must match the one used in 'compileSetupExecutable'+  -- (See issue #3433).+  cabalLibVersionToUse :: IO (Version, Maybe ComponentId                              ,SetupScriptOptions)   cabalLibVersionToUse =-    case useCabalSpecVersion options of-      Just version -> do+    case find (isCabalPkgId . snd) (useDependencies options) of+      Just (unitId, pkgId) -> do+        let version = pkgVersion pkgId         updateSetupScript version bt-        writeFile setupVersionFile (show version ++ "\n")-        return (version, Nothing, options)-      Nothing  -> do-        savedVer <- savedVersion-        case savedVer of-          Just version | version `withinRange` useCabalVersion options-            -> do updateSetupScript version bt-                  -- Does the previously compiled setup executable still exist-                  -- and is it up-to date?-                  useExisting <- canUseExistingSetup version-                  if useExisting-                    then return (version, Nothing, options)-                    else installedVersion-          _ -> installedVersion+        writeSetupVersionFile version+        return (version, Just unitId, options)+      Nothing ->+        case useCabalSpecVersion options of+          Just version -> do+            updateSetupScript version bt+            writeSetupVersionFile version+            return (version, Nothing, options)+          Nothing  -> do+            savedVer <- savedVersion+            case savedVer of+              Just version | version `withinRange` useCabalVersion options+                -> do updateSetupScript version bt+                      -- Does the previously compiled setup executable still exist+                      -- and is it up-to date?+                      useExisting <- canUseExistingSetup version+                      if useExisting+                        then return (version, Nothing, options)+                        else installedVersion+              _ -> installedVersion     where       -- This check duplicates the checks in 'getCachedSetupExecutable' /       -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice@@ -415,13 +612,17 @@           (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs                <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile -      installedVersion :: IO (Version, Maybe UnitId+      writeSetupVersionFile :: Version -> IO ()+      writeSetupVersionFile version =+          writeFile setupVersionFile (show version ++ "\n")++      installedVersion :: IO (Version, Maybe InstalledPackageId                              ,SetupScriptOptions)       installedVersion = do-        (comp,    conf,    options')  <- configureCompiler options-        (version, mipkgid, options'') <- installedCabalVersion options' comp conf+        (comp,    progdb,  options')  <- configureCompiler options+        (version, mipkgid, options'') <- installedCabalVersion options' comp progdb         updateSetupScript version bt-        writeFile setupVersionFile (show version ++ "\n")+        writeSetupVersionFile version         return (version, mipkgid, options'')        savedVersion :: IO (Maybe Version)@@ -444,8 +645,8 @@                     then copyFileVerbose verbosity src setupHs                     else runSimplePreProcessor ppUnlit src setupHs verbosity     where-      customSetupHs   = workingDir </> "Setup.hs"-      customSetupLhs  = workingDir </> "Setup.lhs"+      customSetupHs   = workingDir options </> "Setup.hs"+      customSetupLhs  = workingDir options </> "Setup.lhs"    updateSetupScript cabalLibVersion _ =     rewriteFile setupHs (buildTypeScript cabalLibVersion)@@ -454,19 +655,19 @@   buildTypeScript cabalLibVersion = case bt of     Simple    -> "import Distribution.Simple; main = defaultMain\n"     Configure -> "import Distribution.Simple; main = defaultMainWithHooks "-              ++ if cabalLibVersion >= Version [1,3,10] []+              ++ if cabalLibVersion >= mkVersion [1,3,10]                    then "autoconfUserHooks\n"                    else "defaultUserHooks\n"     Make      -> "import Distribution.Make; main = defaultMain\n"     Custom             -> error "buildTypeScript Custom"     UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" -  installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration-                        -> IO (Version, Maybe UnitId+  installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb+                        -> IO (Version, Maybe InstalledPackageId                               ,SetupScriptOptions)-  installedCabalVersion options' compiler conf = do-    index <- maybeGetInstalledPackages options' compiler conf-    let cabalDep   = Dependency (PackageName "Cabal") (useCabalVersion options')+  installedCabalVersion options' compiler progdb = do+    index <- maybeGetInstalledPackages options' compiler progdb+    let cabalDep   = Dependency (mkPackageName "Cabal") (useCabalVersion options')         options''  = options' { usePackageIndex = Just index }     case PackageIndex.lookupDependency index cabalDep of       []   -> die $ "The package '" ++ display (packageName pkg)@@ -475,7 +676,7 @@                  ++ " but no suitable version is installed."       pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs               in return (packageVersion ipkginfo-                        ,Just . installedUnitId $ ipkginfo, options'')+                        ,Just . IPI.installedComponentId $ ipkginfo, options'')    bestVersion :: (a -> Version) -> [a] -> a   bestVersion f = firstMaximumBy (comparing (preference . f))@@ -501,27 +702,27 @@         where           sameVersion      = version == cabalVersion           sameMajorVersion = majorVersion version == majorVersion cabalVersion-          majorVersion     = take 2 . versionBranch-          stableVersion    = case versionBranch version of+          majorVersion     = take 2 . versionNumbers+          stableVersion    = case versionNumbers version of                                (_:x:_) -> even x                                _       -> False           latestVersion    = version    configureCompiler :: SetupScriptOptions-                    -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)+                    -> IO (Compiler, ProgramDb, SetupScriptOptions)   configureCompiler options' = do-    (comp, conf) <- case useCompiler options' of-      Just comp -> return (comp, useProgramConfig options')-      Nothing   -> do (comp, _, conf) <-+    (comp, progdb) <- case useCompiler options' of+      Just comp -> return (comp, useProgramDb options')+      Nothing   -> do (comp, _, progdb) <-                         configCompilerEx (Just GHC) Nothing Nothing-                        (useProgramConfig options') verbosity-                      return (comp, conf)+                        (useProgramDb options') verbosity+                      return (comp, progdb)     -- Whenever we need to call configureCompiler, we also need to access the     -- package index, so let's cache it in SetupScriptOptions.-    index <- maybeGetInstalledPackages options' comp conf-    return (comp, conf, options' { useCompiler      = Just comp,-                                   usePackageIndex  = Just index,-                                   useProgramConfig = conf })+    index <- maybeGetInstalledPackages options' comp progdb+    return (comp, progdb, options' { useCompiler      = Just comp,+                                     usePackageIndex  = Just index,+                                     useProgramDb = progdb })    -- | Path to the setup exe cache directory and path to the cached setup   -- executable.@@ -548,7 +749,7 @@   -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.   getCachedSetupExecutable :: SetupScriptOptions-                           -> Version -> Maybe UnitId+                           -> Version -> Maybe InstalledPackageId                            -> IO FilePath   getCachedSetupExecutable options' cabalLibVersion                            maybeCabalLibInstalledPkgId = do@@ -572,7 +773,7 @@           installExecutableFile verbosity src cachedSetupProgFile           -- Do not strip if we're using GHCJS, since the result may be a script           when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $-            Strip.stripExe verbosity platform (useProgramConfig options')+            Strip.stripExe verbosity platform (useProgramDb options')               cachedSetupProgFile     return cachedSetupProgFile       where@@ -583,7 +784,7 @@   -- Currently this is GHC/GHCJS only. It should really be generalised.   --   compileSetupExecutable :: SetupScriptOptions-                         -> Version -> Maybe UnitId -> Bool+                         -> Version -> Maybe ComponentId -> Bool                          -> IO FilePath   compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId                          forceCompile = do@@ -592,8 +793,8 @@     let outOfDate = setupHsNewer || cabalVersionNewer     when (outOfDate || forceCompile) $ do       debug verbosity "Setup executable needs to be updated, compiling..."-      (compiler, conf, options'') <- configureCompiler options'-      let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion+      (compiler, progdb, options'') <- configureCompiler options'+      let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion           (program, extraOpts)             = case compilerFlavor compiler of                       GHCJS -> (ghcjsProgram, ["-build-runner"])@@ -604,7 +805,7 @@           -- With 'useDependenciesExclusive' we enforce the deps specified,           -- so only the given ones can be used. Otherwise we allow the use           -- of packages in the ambient environment, and add on a dep on the-          -- Cabal library.+          -- Cabal library (unless 'useDependencies' already contains one).           --           -- With 'useVersionMacros' we use a version CPP macros .h file.           --@@ -613,11 +814,18 @@           --           selectedDeps | useDependenciesExclusive options'                                    = useDependencies options'-                       | otherwise = useDependencies options' ++ cabalDep-          addRenaming (ipid, _) = (ipid, defaultRenaming)+                       | otherwise = useDependencies options' +++                                     if any (isCabalPkgId . snd) (useDependencies options')+                                     then []+                                     else cabalDep+          addRenaming (ipid, _) =+            -- Assert 'DefUnitId' invariant+            (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)), defaultRenaming)           cppMacrosFile = setupDir </> "setup_macros.h"           ghcOptions = mempty {-              ghcOptVerbosity       = Flag verbosity+              -- Respect -v0, but don't crank up verbosity on GHC if+              -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!+              ghcOptVerbosity       = Flag (min verbosity normal)             , ghcOptMode            = Flag GhcModeMake             , ghcOptInputFiles      = toNubListR [setupHs]             , ghcOptOutputFile      = Flag setupProgFile@@ -625,7 +833,7 @@             , ghcOptHiDir           = Flag setupDir             , ghcOptSourcePathClear = Flag True             , ghcOptSourcePath      = case bt of-                                      Custom -> toNubListR [workingDir]+                                      Custom -> toNubListR [workingDir options']                                       _      -> mempty             , ghcOptPackageDBs      = usePackageDB options''             , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')@@ -640,70 +848,14 @@         rewriteFile cppMacrosFile (generatePackageVersionMacros                                      [ pid | (_ipid, pid) <- selectedDeps ])       case useLoggingHandle options of-        Nothing          -> runDbProgram verbosity program conf ghcCmdLine+        Nothing          -> runDbProgram verbosity program progdb ghcCmdLine          -- If build logging is enabled, redirect compiler output to the log file.         (Just logHandle) -> do output <- getDbProgramOutput verbosity program-                                         conf ghcCmdLine+                                         progdb ghcCmdLine                                hPutStr logHandle output     return setupProgFile -  invokeSetupScript :: SetupScriptOptions -> FilePath -> [String] -> IO ()-  invokeSetupScript options' path args = do-    info verbosity $ unwords (path : args)-    case useLoggingHandle options' of-      Nothing        -> return ()-      Just logHandle -> info verbosity $ "Redirecting build log to "-                                      ++ show logHandle -    -- Since useWorkingDir can change the relative path, the path argument must-    -- be turned into an absolute path. On some systems, runProcess will take-    -- path as relative to the new working directory instead of the current-    -- working directory.-    path' <- tryCanonicalizePath path--    -- See 'Note: win32 clean hack' above.-#if mingw32_HOST_OS-    -- setupProgFile may not exist if we're using a cached program-    setupProgFile' <- canonicalizePathNoThrow setupProgFile-    let win32CleanHackNeeded = (useWin32CleanHack options')-                               -- Skip when a cached setup script is used.-                               && setupProgFile' `equalFilePath` path'-    if win32CleanHackNeeded then doWin32CleanHack path' else doInvoke path'-#else-    doInvoke path'-#endif--    where-      doInvoke path' = do-        searchpath <- programSearchPathAsPATHVar-                      (getProgramSearchPath (useProgramConfig options'))-        env        <- getEffectiveEnvironment [("PATH", Just searchpath)]--        process <- runProcess path' args-                   (useWorkingDir options') env Nothing-                   (useLoggingHandle options') (useLoggingHandle options')-        exitCode <- waitForProcess process-        unless (exitCode == ExitSuccess) $ exitWith exitCode--#if mingw32_HOST_OS-      doWin32CleanHack path' = do-        info verbosity $ "Using the Win32 clean hack."-        -- Recursively removes the temp dir on exit.-        withTempDirectory verbosity workingDir "cabal-tmp" $ \tmpDir ->-            bracket (moveOutOfTheWay tmpDir path')-                    (maybeRestore path')-                    doInvoke--      moveOutOfTheWay tmpDir path' = do-        let newPath = tmpDir </> "setup" <.> exeExtension-        Win32.moveFile path' newPath-        return newPath--      maybeRestore oldPath path' = do-        let oldPathDir = takeDirectory oldPath-        oldPathDirExists <- doesDirectoryExist oldPathDir-        -- 'setup clean' didn't complete, 'dist/setup' still exists.-        when oldPathDirExists $-          Win32.moveFile path' oldPath-#endif+isCabalPkgId :: PackageIdentifier -> Bool+isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"
+ cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.SolverInstallPlan+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'SolverInstallPlan' is the graph of packages produced by the+-- dependency solver, and specifies at the package-granularity what+-- things are going to be installed.  To put it another way: the+-- dependency solver produces a 'SolverInstallPlan', which is then+-- consumed by various other parts of Cabal.+--+-----------------------------------------------------------------------------+module Distribution.Client.SolverInstallPlan(+  SolverInstallPlan(..),+  SolverPlanPackage,+  ResolverPackage(..),++  -- * Operations on 'SolverInstallPlan's+  new,+  toList,+  toMap,++  remove,++  showPlanIndex,+  showInstallPlan,++  -- * Checking validity of plans+  valid,+  closed,+  consistent,+  acyclic,++  -- ** Details on invalid plans+  SolverPlanProblem(..),+  showPlanProblem,+  problems,++  -- ** Querying the install plan+  dependencyClosure,+  reverseDependencyClosure,+  topologicalOrder,+  reverseTopologicalOrder,+) where++import Distribution.Package+         ( PackageIdentifier(..), Package(..), PackageName+         , HasUnitId(..), PackageId, packageVersion, packageName )+import qualified Distribution.Solver.Types.ComponentDeps as CD+import Distribution.Text+         ( display )++import Distribution.Client.Types+         ( UnresolvedPkgLoc )+import Distribution.Version+         ( Version )++import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.SolverId++import Data.List+         ( intercalate )+import Data.Maybe+         ( fromMaybe, catMaybes )+import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Graph (Graph, IsNode(..))+import qualified Data.Graph as OldGraph+import qualified Distribution.Compat.Graph as Graph+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Array ((!))+import Data.Typeable++type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc++type SolverPlanIndex = Graph SolverPlanPackage++data SolverInstallPlan = SolverInstallPlan {+    planIndex      :: !SolverPlanIndex,+    planIndepGoals :: !IndependentGoals+  }+  deriving (Typeable)++{-+-- | Much like 'planPkgIdOf', but mapping back to full packages.+planPkgOf :: SolverInstallPlan+          -> Graph.Vertex+          -> SolverPlanPackage+planPkgOf plan v =+    case Graph.lookupKey (planIndex plan)+                         (planPkgIdOf plan v) of+      Just pkg -> pkg+      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"+-}++mkInstallPlan :: SolverPlanIndex+              -> IndependentGoals+              -> SolverInstallPlan+mkInstallPlan index indepGoals =+    SolverInstallPlan {+      planIndex      = index,+      planIndepGoals = indepGoals+    }++instance Binary SolverInstallPlan where+    put SolverInstallPlan {+              planIndex      = index,+              planIndepGoals = indepGoals+        } = put (index, indepGoals)++    get = do+      (index, indepGoals) <- get+      return $! mkInstallPlan index indepGoals++showPlanIndex :: SolverPlanIndex -> String+showPlanIndex index =+    intercalate "\n" (map showPlanPackage (Graph.toList index))++showInstallPlan :: SolverInstallPlan -> String+showInstallPlan = showPlanIndex . planIndex++showPlanPackage :: SolverPlanPackage -> String+showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg)+                                            ++ " (" ++ display (installedUnitId ipkg)+                                            ++ ")"+showPlanPackage (Configured  spkg)   = "Configured " ++ display (packageId spkg)++-- | Build an installation plan from a valid set of resolved packages.+--+new :: IndependentGoals+    -> SolverPlanIndex+    -> Either [SolverPlanProblem] SolverInstallPlan+new indepGoals index =+  case problems indepGoals index of+    []    -> Right (mkInstallPlan index indepGoals)+    probs -> Left probs++toList :: SolverInstallPlan -> [SolverPlanPackage]+toList = Graph.toList . planIndex++toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage+toMap = Graph.toMap . planIndex++-- | Remove packages from the install plan. This will result in an+-- error if there are remaining packages that depend on any matching+-- package. This is primarily useful for obtaining an install plan for+-- the dependencies of a package or set of packages without actually+-- installing the package itself, as when doing development.+--+remove :: (SolverPlanPackage -> Bool)+       -> SolverInstallPlan+       -> Either [SolverPlanProblem]+                 (SolverInstallPlan)+remove shouldRemove plan =+    new (planIndepGoals plan) newIndex+  where+    newIndex = Graph.fromList $+                 filter (not . shouldRemove) (toList plan)++-- ------------------------------------------------------------+-- * Checking validity of plans+-- ------------------------------------------------------------++-- | A valid installation plan is a set of packages that is 'acyclic',+-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the+-- plan has to have a valid configuration (see 'configuredPackageValid').+--+-- * if the result is @False@ use 'problems' to get a detailed list.+--+valid :: IndependentGoals+      -> SolverPlanIndex+      -> Bool+valid indepGoals index =+    null $ problems indepGoals index++data SolverPlanProblem =+     PackageMissingDeps   SolverPlanPackage+                          [PackageIdentifier]+   | PackageCycle         [SolverPlanPackage]+   | PackageInconsistency PackageName [(PackageIdentifier, Version)]+   | PackageStateInvalid  SolverPlanPackage SolverPlanPackage++showPlanProblem :: SolverPlanProblem -> String+showPlanProblem (PackageMissingDeps pkg missingDeps) =+     "Package " ++ display (packageId pkg)+  ++ " depends on the following packages which are missing from the plan: "+  ++ intercalate ", " (map display missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (display.packageId) cycleGroup)++showPlanProblem (PackageInconsistency name inconsistencies) =+     "Package " ++ display name+  ++ " is required by several packages,"+  ++ " but they require inconsistent versions:\n"+  ++ unlines [ "  package " ++ display pkg ++ " requires "+                            ++ display (PackageIdentifier name ver)+             | (pkg, ver) <- inconsistencies ]++showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ display (packageId pkg)+  ++ " is in the " ++ showPlanState pkg+  ++ " state but it depends on package " ++ display (packageId pkg')+  ++ " which is in the " ++ showPlanState pkg'+  ++ " state"+  where+    showPlanState (PreExisting _) = "pre-existing"+    showPlanState (Configured  _)   = "configured"++-- | For an invalid plan, produce a detailed list of problems as human readable+-- error messages. This is mainly intended for debugging purposes.+-- Use 'showPlanProblem' for a human readable explanation.+--+problems :: IndependentGoals+         -> SolverPlanIndex+         -> [SolverPlanProblem]+problems indepGoals index =++     [ PackageMissingDeps pkg+       (catMaybes+        (map+         (fmap packageId . flip Graph.lookup index)+         missingDeps))+     | (pkg, missingDeps) <- Graph.broken index ]++  ++ [ PackageCycle cycleGroup+     | cycleGroup <- Graph.cycles index ]++  ++ [ PackageInconsistency name inconsistencies+     | (name, inconsistencies) <-+       dependencyInconsistencies indepGoals index ]++  ++ [ PackageStateInvalid pkg pkg'+     | pkg <- Graph.toList index+     , Just pkg' <- map (flip Graph.lookup index)+                    (nodeNeighbors pkg)+     , not (stateDependencyRelation pkg pkg') ]+++-- | Compute all roots of the install plan, and verify that the transitive+-- plans from those roots are all consistent.+--+-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles+-- may be absent from the subplans even if the larger plan contains a dependency+-- cycle. Such cycles may or may not be an issue; either way, we don't check+-- for them here.+dependencyInconsistencies :: IndependentGoals+                          -> SolverPlanIndex+                          -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies indepGoals index  =+    concatMap dependencyInconsistencies' subplans+  where+    subplans :: [SolverPlanIndex]+    subplans = -- Not Graph.closure!!+               map (nonSetupClosure index)+                   (rootSets indepGoals index)++-- NB: When we check for inconsistencies, packages from the setup+-- scripts don't count as part of the closure (this way, we+-- can build, e.g., Cabal-1.24.1 even if its setup script is+-- built with Cabal-1.24.0).+--+-- This is a best effort function that swallows any non-existent+-- SolverIds.+nonSetupClosure :: SolverPlanIndex+                -> [SolverId]+                -> SolverPlanIndex+nonSetupClosure index pkgids0 = closure Graph.empty pkgids0+ where+    closure completed []             = completed+    closure completed (pkgid:pkgids) =+      case Graph.lookup pkgid index of+        Nothing   -> closure completed pkgids+        Just pkg  ->+          case Graph.lookup (nodeKey pkg) completed of+            Just _  -> closure completed  pkgids+            Nothing -> closure completed' pkgids'+              where completed' = Graph.insert pkg completed+                    pkgids'    = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids++-- | Compute the root sets of a plan+--+-- A root set is a set of packages whose dependency closure must be consistent.+-- This is the set of all top-level library roots (taken together normally, or+-- as singletons sets if we are considering them as independent goals), along+-- with all setup dependencies of all packages.+rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]]+rootSets (IndependentGoals indepGoals) index =+       if indepGoals then map (:[]) libRoots else [libRoots]+    ++ setupRoots index+  where+    libRoots = libraryRoots index++-- | Compute the library roots of a plan+--+-- The library roots are the set of packages with no reverse dependencies+-- (no reverse library dependencies but also no reverse setup dependencies).+libraryRoots :: SolverPlanIndex -> [SolverId]+libraryRoots index =+    map (nodeKey . toPkgId) roots+  where+    (graph, toPkgId, _) = Graph.toGraph index+    indegree = OldGraph.indegree graph+    roots    = filter isRoot (OldGraph.vertices graph)+    isRoot v = indegree ! v == 0++-- | The setup dependencies of each package in the plan+setupRoots :: SolverPlanIndex -> [[SolverId]]+setupRoots = filter (not . null)+           . map (CD.setupDeps . resolverPackageLibDeps)+           . Graph.toList++-- | Given a package index where we assume we want to use all the packages+-- (use 'dependencyClosure' if you need to get such a index subset) find out+-- if the dependencies within it use consistent versions of each package.+-- Return all cases where multiple packages depend on different versions of+-- some other package.+--+-- Each element in the result is a package name along with the packages that+-- depend on it and the versions they require. These are guaranteed to be+-- distinct.+--+dependencyInconsistencies' :: SolverPlanIndex+                           -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies' index =+    [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids])+    | (name, ipid_map) <- Map.toList inverseIndex+    , let uses = Map.elems ipid_map+    , reallyIsInconsistent (map fst uses)+    ]+  where+    -- For each package name (of a dependency, somewhere)+    --   and each installed ID of that that package+    --     the associated package instance+    --     and a list of reverse dependencies (as source IDs)+    inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId]))+    inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))+      [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))])+      | -- For each package @pkg@+        pkg <- Graph.toList index+        -- Find out which @sid@ @pkg@ depends on+      , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg)+        -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@)+      , Just dep <- [Graph.lookup sid index]+      ]++    -- If, in a single install plan, we depend on more than one version of a+    -- package, then this is ONLY okay in the (rather special) case that we+    -- depend on precisely two versions of that package, and one of them+    -- depends on the other. This is necessary for example for the base where+    -- we have base-3 depending on base-4.+    reallyIsInconsistent :: [SolverPlanPackage] -> Bool+    reallyIsInconsistent []       = False+    reallyIsInconsistent [_p]     = False+    reallyIsInconsistent [p1, p2] =+      let pid1 = nodeKey p1+          pid2 = nodeKey p2+      in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2)+      && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1)+    reallyIsInconsistent _ = True+++-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.+--+-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out+--   which packages are involved in dependency cycles.+--+acyclic :: SolverPlanIndex -> Bool+acyclic = null . Graph.cycles++-- | An installation plan is closed if for every package in the set, all of+-- its dependencies are also in the set. That is, the set is closed under the+-- dependency relation.+--+-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out+--   which packages depend on packages not in the index.+--+closed :: SolverPlanIndex -> Bool+closed = null . Graph.broken++-- | An installation plan is consistent if all dependencies that target a+-- single package name, target the same version.+--+-- This is slightly subtle. It is not the same as requiring that there be at+-- most one version of any package in the set. It only requires that of+-- packages which have more than one other package depending on them. We could+-- actually make the condition even more precise and say that different+-- versions are OK so long as they are not both in the transitive closure of+-- any other package (or equivalently that their inverse closures do not+-- intersect). The point is we do not want to have any packages depending+-- directly or indirectly on two different versions of the same package. The+-- current definition is just a safe approximation of that.+--+-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to+--   find out which packages are.+--+consistent :: SolverPlanIndex -> Bool+consistent = null . dependencyInconsistencies (IndependentGoals False)++-- | The states of packages have that depend on each other must respect+-- this relation. That is for very case where package @a@ depends on+-- package @b@ we require that @dependencyStatesOk a b = True@.+--+stateDependencyRelation :: SolverPlanPackage+                        -> SolverPlanPackage+                        -> Bool+stateDependencyRelation PreExisting{}   PreExisting{}     = True++stateDependencyRelation (Configured  _) PreExisting{}     = True+stateDependencyRelation (Configured  _) (Configured  _)   = True++stateDependencyRelation _               _                 = False+++-- | Compute the dependency closure of a package in a install plan+--+dependencyClosure :: SolverInstallPlan+                  -> [SolverId]+                  -> [SolverPlanPackage]+dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan)+++reverseDependencyClosure :: SolverInstallPlan+                         -> [SolverId]+                         -> [SolverPlanPackage]+reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan)+++topologicalOrder :: SolverInstallPlan+                 -> [SolverPlanPackage]+topologicalOrder plan = Graph.topSort (planIndex plan)+++reverseTopologicalOrder :: SolverInstallPlan+                        -> [SolverPlanPackage]+reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan)
+ cabal/cabal-install/Distribution/Client/SolverPlanIndex.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | These graph traversal functions mirror the ones in Cabal, but work with+-- the more complete (and fine-grained) set of dependencies provided by+-- PackageFixedDeps rather than only the library dependencies provided by+-- PackageInstalled.+module Distribution.Client.SolverPlanIndex (+    -- * Graph traversal functions+    brokenPackages+  , dependencyCycles+  , dependencyGraph+  , dependencyInconsistencies+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++-- import Prelude hiding (lookup)+import qualified Data.Map as Map+import qualified Data.Graph as Graph+import Data.Array ((!))+import Data.Map (Map)+-- import Data.Maybe (isNothing)+import Data.Either (rights)++import Distribution.Package+         ( PackageName, PackageIdentifier(..), UnitId(..)+         , Package(..), packageName, packageVersion+         )+import Distribution.Version+         ( Version )++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.PackageFixedDeps+import           Distribution.Solver.Types.Settings++import Distribution.Simple.PackageIndex+         ( PackageIndex, allPackages, insert, lookupUnitId )+import Distribution.Package+         ( HasUnitId(..), PackageId )++-- | All packages that have dependencies that are not in the index.+--+-- Returns such packages along with the dependencies that they're missing.+--+brokenPackages :: (PackageFixedDeps pkg)+               => PackageIndex pkg+               -> [(pkg, [UnitId])]+brokenPackages index =+  [ (pkg, missing)+  | pkg  <- allPackages index+  , let missing =+          [ pkg' | pkg' <- CD.flatDeps (depends pkg)+                 , isNothing (lookupUnitId index pkg') ]+  , not (null missing) ]++-- | Compute all roots of the install plan, and verify that the transitive+-- plans from those roots are all consistent.+--+-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles+-- may be absent from the subplans even if the larger plan contains a dependency+-- cycle. Such cycles may or may not be an issue; either way, we don't check+-- for them here.+dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg)+                          => IndependentGoals+                          -> PackageIndex pkg+                          -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies indepGoals index  =+    concatMap dependencyInconsistencies' subplans+  where+    subplans :: [PackageIndex pkg]+    subplans = rights $+                 map (dependencyClosure index)+                     (rootSets indepGoals index)++-- | Compute the root sets of a plan+--+-- A root set is a set of packages whose dependency closure must be consistent.+-- This is the set of all top-level library roots (taken together normally, or+-- as singletons sets if we are considering them as independent goals), along+-- with all setup dependencies of all packages.+rootSets :: (PackageFixedDeps pkg, HasUnitId pkg)+         => IndependentGoals -> PackageIndex pkg -> [[UnitId]]+rootSets (IndependentGoals indepGoals) index =+       if indepGoals then map (:[]) libRoots else [libRoots]+    ++ setupRoots index+  where+    libRoots = libraryRoots index++-- | Compute the library roots of a plan+--+-- The library roots are the set of packages with no reverse dependencies+-- (no reverse library dependencies but also no reverse setup dependencies).+libraryRoots :: (PackageFixedDeps pkg, HasUnitId pkg)+             => PackageIndex pkg -> [UnitId]+libraryRoots index =+    map toPkgId roots+  where+    (graph, toPkgId, _) = dependencyGraph index+    indegree = Graph.indegree graph+    roots    = filter isRoot (Graph.vertices graph)+    isRoot v = indegree ! v == 0++-- | The setup dependencies of each package in the plan+setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]]+setupRoots = filter (not . null)+           . map (CD.setupDeps . depends)+           . allPackages++-- | Given a package index where we assume we want to use all the packages+-- (use 'dependencyClosure' if you need to get such a index subset) find out+-- if the dependencies within it use consistent versions of each package.+-- Return all cases where multiple packages depend on different versions of+-- some other package.+--+-- Each element in the result is a package name along with the packages that+-- depend on it and the versions they require. These are guaranteed to be+-- distinct.+--+dependencyInconsistencies' :: forall pkg.+                              (PackageFixedDeps pkg, HasUnitId pkg)+                           => PackageIndex pkg+                           -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies' index =+    [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])+    | (name, ipid_map) <- Map.toList inverseIndex+    , let uses = Map.elems ipid_map+    , reallyIsInconsistent (map fst uses)+    ]+  where+    -- For each package name (of a dependency, somewhere)+    --   and each installed ID of that that package+    --     the associated package instance+    --     and a list of reverse dependencies (as source IDs)+    inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId]))+    inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))+      [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))])+      | -- For each package @pkg@+        pkg <- allPackages index+        -- Find out which @ipid@ @pkg@ depends on+      , ipid <- CD.nonSetupDeps (depends pkg)+        -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)+      , Just dep <- [lookupUnitId index ipid]+      ]++    -- If, in a single install plan, we depend on more than one version of a+    -- package, then this is ONLY okay in the (rather special) case that we+    -- depend on precisely two versions of that package, and one of them+    -- depends on the other. This is necessary for example for the base where+    -- we have base-3 depending on base-4.+    reallyIsInconsistent :: [pkg] -> Bool+    reallyIsInconsistent []       = False+    reallyIsInconsistent [_p]     = False+    reallyIsInconsistent [p1, p2] =+      let pid1 = installedUnitId p1+          pid2 = installedUnitId p2+      in pid1 `notElem` CD.nonSetupDeps (depends p2)+      && pid2 `notElem` CD.nonSetupDeps (depends p1)+    reallyIsInconsistent _ = True++++-- | Find if there are any cycles in the dependency graph. If there are no+-- cycles the result is @[]@.+--+-- This actually computes the strongly connected components. So it gives us a+-- list of groups of packages where within each group they all depend on each+-- other, directly or indirectly.+--+dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg)+                 => PackageIndex pkg+                 -> [[pkg]]+dependencyCycles index =+  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]+  where+    adjacencyList = [ (pkg, installedUnitId pkg,+                            CD.flatDeps (depends pkg))+                    | pkg <- allPackages index ]+++-- | Tries to take the transitive closure of the package dependencies.+--+-- If the transitive closure is complete then it returns that subset of the+-- index. Otherwise it returns the broken packages as in 'brokenPackages'.+--+-- * Note that if the result is @Right []@ it is because at least one of+-- the original given 'PackageIdentifier's do not occur in the index.+dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg)+                  => PackageIndex pkg+                  -> [UnitId]+                  -> Either [(pkg, [UnitId])]+                            (PackageIndex pkg)+dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of+  (completed, []) -> Right completed+  (completed, _)  -> Left (brokenPackages completed)+ where+    closure completed failed []             = (completed, failed)+    closure completed failed (pkgid:pkgids) =+      case lookupUnitId index pkgid of+        Nothing   -> closure completed (pkgid:failed) pkgids+        Just pkg  ->+          case lookupUnitId completed+               (installedUnitId pkg) of+            Just _  -> closure completed  failed pkgids+            Nothing -> closure completed' failed pkgids'+              where completed' = insert pkg completed+                    pkgids'    = CD.nonSetupDeps (depends pkg) ++ pkgids+++-- | Builds a graph of the package dependencies.+--+-- Dependencies on other packages that are not in the index are discarded.+-- You can check if there are any such dependencies with 'brokenPackages'.+--+dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg)+                => PackageIndex pkg+                -> (Graph.Graph,+                    Graph.Vertex -> UnitId,+                    UnitId -> Maybe Graph.Vertex)+dependencyGraph index = (graph, vertexToPkg, idToVertex)+  where+    (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges+    vertexToPkg v = case vertexToPkg' v of+                      ((), pkgid, _targets) -> pkgid++    pkgs  = allPackages index+    edges = map edgesFrom pkgs++    resolve   pid = pid+    edgesFrom pkg = ( ()+                    , resolve (installedUnitId pkg)+                    , CD.flatDeps (depends pkg)+                    )
+ cabal/cabal-install/Distribution/Client/SourceFiles.hs view
@@ -0,0 +1,168 @@+-- | Contains an @sdist@ like function which computes the source files+-- that we should track to determine if a rebuild is necessary.+-- Unlike @sdist@, we can operate directly on the true+-- 'PackageDescription' (not flattened).+--+-- The naming convention, roughly, is that to declare we need the+-- source for some type T, you use the function needT; some functions+-- need auxiliary information.+--+-- We can only use this code for non-Custom scripts; Custom scripts+-- may have arbitrary extra dependencies (esp. new preprocessors) which+-- we cannot "see" easily.+module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where++import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.RebuildMonad++import Distribution.Solver.Types.OptionalStanza++import Distribution.Simple.PreProcess++import Distribution.Types.PackageDescription+import Distribution.Types.Component+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.Library+import Distribution.Types.Executable+import Distribution.Types.Benchmark+import Distribution.Types.BenchmarkInterface+import Distribution.Types.TestSuite+import Distribution.Types.TestSuiteInterface+import Distribution.Types.BuildInfo+import Distribution.Types.ForeignLib++import Distribution.ModuleName++import Prelude ()+import Distribution.Client.Compat.Prelude++import System.FilePath+import Control.Monad+import qualified Data.Set as Set++needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild ()+needElaboratedConfiguredPackage elab =+    case elabPkgOrComp elab of+        ElabComponent ecomp -> needElaboratedComponent elab ecomp+        ElabPackage   epkg  -> needElaboratedPackage   elab epkg++needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild ()+needElaboratedPackage elab epkg =+    mapM_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)+  where+    pkg_descr = elabPkgDescription elab+    enabled_stanzas = pkgStanzasEnabled epkg+    -- TODO: turn this into a helper function somewhere+    enabled =+        ComponentRequestedSpec {+            testsRequested      = TestStanzas  `Set.member` enabled_stanzas,+            benchmarksRequested = BenchStanzas `Set.member` enabled_stanzas+        }++needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild ()+needElaboratedComponent elab ecomp =+    case mb_comp of+        Nothing   -> needSetup+        Just comp -> needComponent pkg_descr comp+  where+    pkg_descr = elabPkgDescription elab+    mb_comp   = fmap (getComponent pkg_descr) (compComponentName ecomp)++needComponent :: PackageDescription -> Component -> Rebuild ()+needComponent pkg_descr comp =+    case comp of+        CLib lib     -> needLibrary    pkg_descr lib+        CFLib flib   -> needForeignLib pkg_descr flib+        CExe exe     -> needExecutable pkg_descr exe+        CTest test   -> needTestSuite  pkg_descr test+        CBench bench -> needBenchmark  pkg_descr bench++needSetup :: Rebuild ()+needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return ()++needLibrary :: PackageDescription -> Library -> Rebuild ()+needLibrary pkg_descr (Library { exposedModules = modules+                               , signatures     = sigs+                               , libBuildInfo   = bi })+  = needBuildInfo pkg_descr bi (modules ++ sigs)++needForeignLib :: PackageDescription -> ForeignLib -> Rebuild ()+needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs+                                     , foreignLibBuildInfo = bi })+  = do mapM_ needIfExists fs+       needBuildInfo pkg_descr bi []++needExecutable :: PackageDescription -> Executable -> Rebuild ()+needExecutable pkg_descr (Executable { modulePath = mainPath+                                     , buildInfo  = bi })+  = do needBuildInfo pkg_descr bi []+       needMainFile  bi mainPath++needTestSuite :: PackageDescription -> TestSuite -> Rebuild ()+needTestSuite pkg_descr t+  = case testInterface t of+      TestSuiteExeV10 _ mainPath -> do+        needBuildInfo pkg_descr bi []+        needMainFile  bi mainPath+      TestSuiteLibV09 _ m ->+        needBuildInfo pkg_descr bi [m]+      TestSuiteUnsupported _ -> return () -- soft fail+ where+  bi = testBuildInfo t++needMainFile :: BuildInfo -> FilePath -> Rebuild ()+needMainFile bi mainPath = do+    -- The matter here is subtle.  It might *seem* that we+    -- should just search for mainPath, but as per+    -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is'+    -- will actually be the source file AFTER preprocessing,+    -- whereas we need to get the file *prior* to preprocessing.+    ppFile <- findFileWithExtensionMonitored+                (ppSuffixes knownSuffixHandlers)+                (hsSourceDirs bi)+                (dropExtension mainPath)+    case ppFile of+        -- But check the original path in the end, because+        -- maybe it's a non-preprocessed file with a non-traditional+        -- extension.+        Nothing -> findFileMonitored (hsSourceDirs bi) mainPath+                    >>= maybe (return ()) need+        Just pp -> need pp++needBenchmark :: PackageDescription -> Benchmark -> Rebuild ()+needBenchmark pkg_descr bm+  = case benchmarkInterface bm of+     BenchmarkExeV10 _ mainPath -> do+       needBuildInfo pkg_descr bi []+       needMainFile  bi mainPath+     BenchmarkUnsupported _ -> return () -- soft fail+ where+  bi = benchmarkBuildInfo bm++needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild ()+needBuildInfo pkg_descr bi modules = do+    -- NB: These are separate because there may be both A.hs and+    -- A.hs-boot; need to track both.+    findNeededModules ["hs", "lhs", "hsig", "lhsig"]+    findNeededModules ["hs-boot", "lhs-boot"]+    mapM_ needIfExists (cSources bi ++ jsSources bi)+    -- A MASSIVE HACK to (1) make sure we rebuild when header+    -- files change, but (2) not have to rebuild when anything+    -- in extra-src-files changes (most of these won't affect+    -- compilation).  It would be even better if we knew on a+    -- per-component basis which headers would be used but that+    -- seems to be too difficult.+    mapM_ needIfExists (filter ((==".h").takeExtension) (extraSrcFiles pkg_descr))+    forM_ (installIncludes bi) $ \f ->+        findFileMonitored ("." : includeDirs bi) f+            >>= maybe (return ()) need+  where+    findNeededModules exts =+        mapM_ (findNeededModule exts)+              (modules ++ otherModules bi)+    findNeededModule exts m =+        findFileWithExtensionMonitored+            (ppSuffixes knownSuffixHandlers ++ exts)+            (hsSourceDirs bi)+            (toFilePath m)+          >>= maybe (return ()) need
cabal/cabal-install/Distribution/Client/SrcDist.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE FlexibleContexts #-} -- Implements the \"@.\/cabal sdist@\" command, which creates a source -- distribution for this package.  That is, packs up the source code -- into a tarball, making use of the corresponding Cabal module. module Distribution.Client.SrcDist (-         sdist+         sdist,+         allPackageSourceFiles   )  where  @@ -11,7 +14,7 @@ import Distribution.Client.Tar (createTarGzFile)  import Distribution.Package-         ( Package(..) )+         ( Package(..), packageName ) import Distribution.PackageDescription          ( PackageDescription ) import Distribution.PackageDescription.Configuration@@ -20,30 +23,37 @@          ( readPackageDescription ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, defaultPackageDesc-         , die, notice, withTempDirectory )+         , warn, die, notice, withTempDirectory ) import Distribution.Client.Setup          ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup-         ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault )+         ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault+         , defaultSDistFlags ) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display )-import Distribution.Verbosity (Verbosity)-import Distribution.Version   (Version(..), orLaterVersion)+import Distribution.Verbosity (Verbosity, normal, lessVerbose)+import Distribution.Version   (mkVersion, orLaterVersion, intersectVersionRanges) +import Distribution.Client.Utils+  (tryFindAddSourcePackageDesc)+import Distribution.Compat.Exception                 (catchIO)+ import System.FilePath ((</>), (<.>)) import Control.Monad (when, unless, liftM)-import System.Directory (doesFileExist, removeFile, canonicalizePath)+import System.Directory (doesFileExist, removeFile, canonicalizePath, getTemporaryDirectory) import System.Process (runProcess, waitForProcess) import System.Exit    (ExitCode(..))+import Control.Exception                             (IOException, evaluate)  -- |Create a source distribution. sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do   pkg <- liftM flattenPackageDescription     (readPackageDescription verbosity =<< defaultPackageDesc verbosity)-  let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)+  let withDir :: (FilePath -> IO a) -> IO a+      withDir = if not needMakeArchive then \f -> f tmpTargetDir                 else withTempDirectory verbosity tmpTargetDir "sdist."   -- 'withTempDir' fails if we don't create 'tmpTargetDir'...   when needMakeArchive $@@ -82,11 +92,12 @@     distPref        = fromFlag (sDistDistPref flags)     tmpTargetDir    = fromFlagOrDefault (srcPref distPref) (sDistDirectory flags)     setupOpts       = defaultSetupScriptOptions {+      useDistPref     = distPref,       -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and       -- '--list-sources' in 1.17.       useCabalVersion = if isListSources-                        then orLaterVersion $ Version [1,17,0] []-                        else orLaterVersion $ Version [1,12,0] []+                        then orLaterVersion $ mkVersion [1,17,0]+                        else orLaterVersion $ mkVersion [1,12,0]       }     format        = fromFlag (sDistFormat exflags)     createArchive = case format of@@ -136,3 +147,48 @@     notice verbosity $ "Source zip archive created: " ++ zipfile   where     zipProgram = simpleProgram "zip"++-- | List all source files of a given add-source dependency. Exits with error if+-- something is wrong (e.g. there is no .cabal file in the given directory).+allPackageSourceFiles :: Verbosity -> SetupScriptOptions -> FilePath+                         -> IO [FilePath]+allPackageSourceFiles verbosity setupOpts0 packageDir = do+  pkg <- do+    let err = "Error reading source files of package."+    desc <- tryFindAddSourcePackageDesc packageDir err+    flattenPackageDescription `fmap` readPackageDescription verbosity desc+  globalTmp <- getTemporaryDirectory+  withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do+  let file      = tempDir </> "cabal-sdist-list-sources"+      flags     = defaultSDistFlags {+        sDistVerbosity   = Flag $ if verbosity == normal+                                  then lessVerbose verbosity else verbosity,+        sDistListSources = Flag file+        }+      setupOpts = setupOpts0 {+        -- 'sdist --list-sources' was introduced in Cabal 1.18.+        useCabalVersion = intersectVersionRanges+                            (orLaterVersion $ mkVersion [1,18,0])+                            (useCabalVersion setupOpts0),+        useWorkingDir = Just packageDir+        }++      doListSources :: IO [FilePath]+      doListSources = do+        setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) []+        fmap lines . readFile $ file++      onFailedListSources :: IOException -> IO ()+      onFailedListSources e = do+        warn verbosity $+          "Could not list sources of the package '"+          ++ display (packageName pkg) ++ "'."+        warn verbosity $+          "Exception was: " ++ show e++  -- Run setup sdist --list-sources=TMPFILE+  r <- doListSources `catchIO` (\e -> onFailedListSources e >> return [])+  -- Ensure that we've closed the 'readFile' handle before we exit the+  -- temporary directory.+  _ <- evaluate (length r)+  return r
cabal/cabal-install/Distribution/Client/Targets.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Targets@@ -50,20 +50,26 @@    ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Package-         ( Package(..), PackageName(..)+         ( Package(..), PackageName, unPackageName, mkPackageName          , PackageIdentifier(..), packageName, packageVersion          , Dependency(Dependency) ) import Distribution.Client.Types-         ( SourcePackage(..), PackageLocation(..), OptionalStanza(..)+         ( PackageLocation(..)          , ResolvedPkgLoc, UnresolvedSourcePackage )-import Distribution.Client.Dependency.Types-         ( PackageConstraint(..), ConstraintSource(..)-         , LabeledPackageConstraint(..) ) +import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageConstraint+import           Distribution.Solver.Types.PackageIndex (PackageIndex)+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.SourcePackage+ import qualified Distribution.Client.World as World-import Distribution.Client.PackageIndex (PackageIndex)-import qualified Distribution.Client.PackageIndex as PackageIndex import qualified Codec.Archive.Tar       as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.Tar as Tar@@ -73,51 +79,38 @@          ( RepoContext(..) )  import Distribution.PackageDescription-         ( GenericPackageDescription, FlagName(..), FlagAssignment )+         ( GenericPackageDescription, mkFlagName, unFlagName, FlagAssignment ) import Distribution.PackageDescription.Parse          ( readPackageDescription, parsePackageDescription, ParseResult(..) ) import Distribution.Version-         ( Version(Version), thisVersion, anyVersion, isAnyVersion+         ( nullVersion, thisVersion, anyVersion, isAnyVersion          , VersionRange ) import Distribution.Text          ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, warn, intercalate, fromUTF8, lowercase, ignoreBOM )+         ( die, warn, fromUTF8, lowercase, ignoreBOM ) -import Data.List-         ( find, nub )-import Data.Maybe-         ( listToMaybe )+-- import Data.List ( find, nub ) import Data.Either          ( partitionEithers )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Client.GZipUtils as GZipUtils-import Control.Monad (liftM)+import Control.Monad (mapM) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP          ( (+++), (<++) )-import qualified Distribution.Compat.Semigroup as Semi-         ( Semigroup((<>)) ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint-         ( (<>), (<+>) )-import Data.Char-         ( isSpace, isAlphaNum )+         ( (<+>) ) import System.FilePath          ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory          ( doesFileExist, doesDirectoryExist ) import Network.URI          ( URI(..), URIAuth(..), parseAbsoluteURI )-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)  -- ------------------------------------------------------------ -- * User targets@@ -237,10 +230,12 @@ readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr =     case testNamedTargets targetstr of-      Just (Dependency (PackageName "world") verrange)-        | verrange == anyVersion -> return (Right UserTargetWorld)-        | otherwise              -> return (Left  UserTargetBadWorldPkg)-      Just dep                   -> return (Right (UserTargetNamed dep))+      Just (Dependency pkgn verrange)+        | pkgn == mkPackageName "world"+          -> return $ if verrange == anyVersion+                      then Right UserTargetWorld+                      else Left  UserTargetBadWorldPkg+      Just dep -> return (Right (UserTargetNamed dep))       Nothing -> do         fileTarget <- testFileTargets targetstr         case fileTarget of@@ -303,8 +298,8 @@       where         pkgidToDependency :: PackageIdentifier -> Dependency         pkgidToDependency p = case packageVersion p of-          Version [] _ -> Dependency (packageName p) anyVersion-          version      -> Dependency (packageName p) (thisVersion version)+          v | v == nullVersion -> Dependency (packageName p) anyVersion+            | otherwise        -> Dependency (packageName p) (thisVersion v)  readPToMaybe :: Parse.ReadP a a -> String -> Maybe a readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str@@ -680,26 +675,26 @@  instance Monoid PackageNameEnv where   mempty = PackageNameEnv (const [])-  mappend = (Semi.<>)+  mappend = (<>) -instance Semi.Semigroup PackageNameEnv where+instance Semigroup PackageNameEnv where   PackageNameEnv lookupA <> PackageNameEnv lookupB =     PackageNameEnv (\name -> lookupA name ++ lookupB name)  indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup   where-    pkgNameLookup (PackageName name) =-      map fst (PackageIndex.searchByName pkgIndex name)+    pkgNameLookup pname =+      map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname)  extraPackageNameEnv :: [PackageName] -> PackageNameEnv extraPackageNameEnv names = PackageNameEnv pkgNameLookup   where-    pkgNameLookup (PackageName name) =-      [ PackageName name'-      | let lname = lowercase name-      , PackageName name' <- names-      , lowercase name' == lname ]+    pkgNameLookup pname =+      [ pname'+      | let lname = lowercase (unPackageName pname)+      , pname' <- names+      , lowercase (unPackageName pname') == lname ]   -- ------------------------------------------------------------@@ -791,9 +786,9 @@ dispFlagAssignment :: FlagAssignment -> Disp.Doc dispFlagAssignment = Disp.hsep . map dispFlagValue   where-    dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f-    dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f-    dispFlagName (FlagName f) = Disp.text f+    dispFlagValue (f, True)   = Disp.char '+' <<>> dispFlagName f+    dispFlagValue (f, False)  = Disp.char '-' <<>> dispFlagName f+    dispFlagName = Disp.text . unFlagName  parseFlagAssignment :: Parse.ReadP r FlagAssignment parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1@@ -805,7 +800,7 @@       +++ (do _ <- Parse.char '-'               f <- parseFlagName               return (f, False))-    parseFlagName = liftM (FlagName . lowercase) ident+    parseFlagName = liftM (mkFlagName . lowercase) ident      ident :: Parse.ReadP r String     ident = Parse.munch1 identChar >>= \s -> check s >> return s
cabal/cabal-install/Distribution/Client/Types.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -21,29 +22,31 @@  import Distribution.Package          ( PackageName, PackageId, Package(..)-         , UnitId(..), mkUnitId, pkgName-         , HasUnitId(..), PackageInstalled(..) )+         , UnitId, ComponentId, HasUnitId(..)+         , PackageInstalled(..), newSimpleUnitId ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )+         ( InstalledPackageInfo, installedComponentId ) import Distribution.PackageDescription-         ( Benchmark(..), GenericPackageDescription(..), FlagAssignment-         , TestSuite(..) )-import Distribution.PackageDescription.Configuration-         ( mapTreeData )-import Distribution.Client.PackageIndex-         ( PackageIndex )-import Distribution.Client.ComponentDeps-         ( ComponentDeps )-import qualified Distribution.Client.ComponentDeps as CD+         ( FlagAssignment ) import Distribution.Version          ( VersionRange )-import Distribution.Text (display) +import Distribution.Solver.Types.PackageIndex+         ( PackageIndex )+import qualified Distribution.Solver.Types.ComponentDeps as CD+import Distribution.Solver.Types.ComponentDeps+         ( ComponentDeps )+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageFixedDeps+import Distribution.Solver.Types.SourcePackage+import Distribution.Compat.Graph (IsNode(..))+import Distribution.Simple.Utils (ordNub)+ import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI)-import Data.ByteString.Lazy (ByteString) import Control.Exception-         ( SomeException )+         ( Exception, SomeException )+import Data.Typeable (Typeable) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) @@ -76,44 +79,19 @@ -- slightly and we may distinguish these two types and have an explicit -- conversion when we register units with the compiler. ---type InstalledPackageId = UnitId--installedPackageId :: HasUnitId pkg => pkg -> InstalledPackageId-installedPackageId = installedUnitId---- | Subclass of packages that have specific versioned dependencies.------ So for example a not-yet-configured package has dependencies on version--- ranges, not specific versions. A configured or an already installed package--- depends on exact versions. Some operations or data structures (like---  dependency graphs) only make sense on this subclass of package types.----class Package pkg => PackageFixedDeps pkg where-  depends :: pkg -> ComponentDeps [UnitId]--instance PackageFixedDeps InstalledPackageInfo where-  depends pkg = CD.fromInstalled (display (pkgName (packageId pkg)))-                                 (installedDepends pkg)+type InstalledPackageId = ComponentId  --- | In order to reuse the implementation of PackageIndex which relies on--- 'UnitId', we need to be able to synthesize these IDs prior--- to installation.  Eventually, we'll move to a representation of--- 'UnitId' which can be properly computed before compilation--- (of course, it's a bit of a misnomer since the packages are not actually--- installed yet.)  In any case, we'll synthesize temporary installed package--- IDs to use as keys during install planning.  These should never be written--- out!  Additionally, they need to be guaranteed unique within the install--- plan.-fakeUnitId :: PackageId -> UnitId-fakeUnitId = mkUnitId . (".fake."++) . display- -- | A 'ConfiguredPackage' is a not-yet-installed package along with the -- total configuration information. The configuration information is total in -- the sense that it provides all the configuration information and so the -- final configure process will be independent of the environment. --+-- 'ConfiguredPackage' is assumed to not support Backpack.  Only the+-- @new-build@ codepath supports Backpack.+-- data ConfiguredPackage loc = ConfiguredPackage {+       confPkgId :: InstalledPackageId,        confPkgSource :: SourcePackage loc, -- package info, including repo        confPkgFlags :: FlagAssignment,     -- complete flag assignment for the package        confPkgStanzas :: [OptionalStanza], -- list of enabled optional stanzas for the package@@ -125,8 +103,29 @@     }   deriving (Eq, Show, Generic) +-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'.+-- This type class is mostly used to conveniently finesse between+-- 'ElaboratedPackage' and 'ElaboratedComponent'.+--+instance HasConfiguredId (ConfiguredPackage loc) where+    configuredId pkg = ConfiguredId (packageId pkg) (confPkgId pkg)++-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed+-- to never have a nontrivial 'UnitId'+instance PackageFixedDeps (ConfiguredPackage loc) where+    depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps++instance IsNode (ConfiguredPackage loc) where+    type Key (ConfiguredPackage loc) = UnitId+    nodeKey       = newSimpleUnitId . confPkgId+    -- TODO: if we update ConfiguredPackage to support order-only+    -- dependencies, need to include those here.+    -- NB: have to deduplicate, otherwise the planner gets confused+    nodeNeighbors = ordNub . CD.flatDeps . depends+ instance (Binary loc) => Binary (ConfiguredPackage loc) + -- | A ConfiguredId is a package ID for a configured package. -- -- Once we configure a source package we know it's UnitId. It is still@@ -135,14 +134,11 @@ -- -- An already installed package of course is also "configured" (all it's -- configuration parameters and dependencies have been specified).------ TODO: I wonder if it would make sense to promote this datatype to Cabal--- and use it consistently instead of UnitIds? data ConfiguredId = ConfiguredId {     confSrcId  :: PackageId-  , confInstId :: UnitId+  , confInstId :: ComponentId   }-  deriving (Eq, Generic)+  deriving (Eq, Ord, Generic)  instance Binary ConfiguredId @@ -152,68 +148,41 @@ instance Package ConfiguredId where   packageId = confSrcId -instance HasUnitId ConfiguredId where-  installedUnitId = confInstId- instance Package (ConfiguredPackage loc) where   packageId cpkg = packageId (confPkgSource cpkg) -instance PackageFixedDeps (ConfiguredPackage loc) where-  depends cpkg = fmap (map installedUnitId) (confPkgDeps cpkg)-+-- Never has nontrivial UnitId instance HasUnitId (ConfiguredPackage loc) where-  installedUnitId cpkg = fakeUnitId (packageId cpkg)+  installedUnitId = newSimpleUnitId . confPkgId +instance PackageInstalled (ConfiguredPackage loc) where+  installedDepends = CD.flatDeps . depends++class HasConfiguredId a where+    configuredId :: a -> ConfiguredId++-- NB: This instance is slightly dangerous, in that you'll lose+-- information about the specific UnitId you depended on.+instance HasConfiguredId InstalledPackageInfo where+    configuredId ipkg = ConfiguredId (packageId ipkg) (installedComponentId ipkg)+ -- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be -- installed already, hence itself ready to be installed. newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.-  deriving (Eq, Show, Generic, Package, PackageFixedDeps, HasUnitId, Binary)--type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)-+  deriving (Eq, Show, Generic, Package, PackageFixedDeps,+            HasUnitId, PackageInstalled, Binary) --- | A package description along with the location of the package sources.----data SourcePackage loc = SourcePackage {-    packageInfoId        :: PackageId,-    packageDescription   :: GenericPackageDescription,-    packageSource        :: loc,-    packageDescrOverride :: PackageDescriptionOverride-  }-  deriving (Eq, Show, Generic)+-- Can't newtype derive this+instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where+    type Key (GenericReadyPackage srcpkg) = Key srcpkg+    nodeKey (ReadyPackage spkg) = nodeKey spkg+    nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg -instance (Binary loc) => Binary (SourcePackage loc)+type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)  -- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc --- | We sometimes need to override the .cabal file in the tarball with--- the newer one from the package index.-type PackageDescriptionOverride = Maybe ByteString--instance Package (SourcePackage a) where packageId = packageInfoId--data OptionalStanza-    = TestStanzas-    | BenchStanzas-  deriving (Eq, Ord, Enum, Bounded, Show, Generic)--instance Binary OptionalStanza--enableStanzas-    :: [OptionalStanza]-    -> GenericPackageDescription-    -> GenericPackageDescription-enableStanzas stanzas gpkg = gpkg-    { condBenchmarks = flagBenchmarks $ condBenchmarks gpkg-    , condTestSuites = flagTests $ condTestSuites gpkg-    }-  where-    enableTest t = t { testEnabled = TestStanzas `elem` stanzas }-    enableBenchmark bm = bm { benchmarkEnabled = BenchStanzas `elem` stanzas }-    flagBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))-    flagTests = map (\(n, t) -> (n, mapTreeData enableTest t))- -- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------@@ -242,7 +211,7 @@ --TODO: --  * add support for darcs and other SCM style remote repos with a local cache --  | ScmPackage-  deriving (Show, Functor, Eq, Ord, Generic)+  deriving (Show, Functor, Eq, Ord, Generic, Typeable)  instance Binary local => Binary (PackageLocation local) @@ -334,7 +303,14 @@ -- * Build results -- ------------------------------------------------------------ -type BuildResult  = Either BuildFailure BuildSuccess+-- | A summary of the outcome for building a single package.+--+type BuildOutcome = Either BuildFailure BuildResult++-- | A summary of the outcome for building a whole set of packages.+--+type BuildOutcomes = Map UnitId BuildOutcome+ data BuildFailure = PlanningFailed                   | DependentFailed PackageId                   | DownloadFailed  SomeException@@ -343,18 +319,25 @@                   | BuildFailed     SomeException                   | TestsFailed     SomeException                   | InstallFailed   SomeException-  deriving (Show, Generic)-data BuildSuccess = BuildOk         DocsResult TestsResult-                                    (Maybe InstalledPackageInfo)+  deriving (Show, Typeable, Generic)++instance Exception BuildFailure++-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only+-- the public library's 'InstalledPackageInfo' is stored here, even if+-- there were 'InstalledPackageInfo' from internal libraries.  This+-- 'InstalledPackageInfo' is not used anyway, so it makes no difference.+data BuildResult = BuildResult DocsResult TestsResult+                               (Maybe InstalledPackageInfo)   deriving (Show, Generic)  data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable) data TestsResult = TestsNotTried | TestsOk-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  instance Binary BuildFailure-instance Binary BuildSuccess+instance Binary BuildResult instance Binary DocsResult instance Binary TestsResult
cabal/cabal-install/Distribution/Client/Update.hs view
@@ -47,7 +47,6 @@   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file." update verbosity repoCtxt = do-  jobCtrl <- newParallelJobControl   let repos       = repoContextRepos repoCtxt       remoteRepos = catMaybes (map maybeRepoRemote repos)   case remoteRepos of@@ -58,6 +57,7 @@     _ -> notice verbosity . unlines             $ "Downloading the latest package lists from: "             : map (("- " ++) . remoteRepoName) remoteRepos+  jobCtrl <- newParallelJobControl (length repos)   mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos   mapM_ (\_ -> collectJob jobCtrl) repos
cabal/cabal-install/Distribution/Client/Upload.hs view
@@ -1,11 +1,11 @@-module Distribution.Client.Upload (check, upload, uploadDoc, report) where+module Distribution.Client.Upload (upload, uploadDoc, report) where  import Distribution.Client.Types ( Username(..), Password(..)                                  , RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils          ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) import Distribution.Client.Setup-         ( RepoContext(..) )+         ( IsCandidate(..), RepoContext(..) )  import Distribution.Simple.Utils (notice, warn, info, die) import Distribution.Verbosity (Verbosity)@@ -15,28 +15,36 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport -import Network.URI (URI(uriPath), parseURI)+import Network.URI (URI(uriPath)) import Network.HTTP (Header(..), HeaderName(..))  import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho) import System.Exit      (exitFailure) import Control.Exception (bracket)-import System.FilePath  ((</>), takeExtension, takeFileName)+import System.FilePath  ((</>), takeExtension, takeFileName, dropExtension) import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory-import Control.Monad (forM_, when)+import Control.Monad (forM_, when, foldM) import Data.Maybe (catMaybes)+import Data.Char (isSpace)  type Auth = Maybe (String, String) -checkURI :: URI-Just checkURI = parseURI $ "http://hackage.haskell.org/cgi-bin/"-                           ++ "hackage-scripts/check-pkg"+-- > stripExtensions ["tar", "gz"] "foo.tar.gz"+-- Just "foo"+-- > stripExtensions ["tar", "gz"] "foo.gz.tar"+-- Nothing+stripExtensions :: [String] -> FilePath -> Maybe String+stripExtensions exts path = foldM f path (reverse exts)+ where+  f p e+    | takeExtension p == '.':e = Just (dropExtension p)+    | otherwise = Nothing  upload :: Verbosity -> RepoContext-       -> Maybe Username -> Maybe Password -> [FilePath]+       -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]        -> IO ()-upload verbosity repoCtxt mUsername mPassword paths = do+upload verbosity repoCtxt mUsername mPassword isCandidate paths = do     let repos = repoContextRepos repoCtxt     transport  <- repoContextGetTransport repoCtxt     targetRepo <-@@ -46,20 +54,36 @@     let targetRepoURI = remoteRepoURI targetRepo         rootIfEmpty x = if null x then "/" else x         uploadURI = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>+              case isCandidate of+                IsCandidate -> "packages/candidates"+                IsPublished -> "upload"+        }+        packageURI pkgid = targetRepoURI {             uriPath = rootIfEmpty (uriPath targetRepoURI)-                      FilePath.Posix.</> "upload"+                      FilePath.Posix.</> concat+              [ "package/", pkgid+              , case isCandidate of+                  IsCandidate -> "/candidate"+                  IsPublished -> ""+              ]         }     Username username <- maybe promptUsername return mUsername     Password password <- maybe promptPassword return mPassword     let auth = Just (username,password)     forM_ paths $ \path -> do       notice verbosity $ "Uploading " ++ path ++ "... "-      handlePackage transport verbosity uploadURI auth path+      case fmap takeFileName (stripExtensions ["tar", "gz"] path) of+        Just pkgid -> handlePackage transport verbosity uploadURI+                                    (packageURI pkgid) auth isCandidate path+        -- This case shouldn't really happen, since we check in Main that we+        -- only pass tar.gz files to upload.+        Nothing -> die $ "Not a tar.gz file: " ++ path  uploadDoc :: Verbosity -> RepoContext-          -> Maybe Username -> Maybe Password -> FilePath+          -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath           -> IO ()-uploadDoc verbosity repoCtxt mUsername mPassword path = do+uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do     let repos = repoContextRepos repoCtxt     transport  <- repoContextGetTransport repoCtxt     targetRepo <-@@ -70,7 +94,13 @@         rootIfEmpty x = if null x then "/" else x         uploadURI = targetRepoURI {             uriPath = rootIfEmpty (uriPath targetRepoURI)-                      FilePath.Posix.</> "package/" ++ pkgid ++ "/docs"+                      FilePath.Posix.</> concat+              [ "package/", pkgid+              , case isCandidate of+                IsCandidate -> "/candidate"+                IsPublished -> ""+              , "/docs"+              ]         }         (reverseSuffix, reversePkgid) = break (== '-')                                         (reverse (takeFileName path))@@ -89,7 +119,9 @@     notice verbosity $ "Uploading documentation " ++ path ++ "... "     resp <- putHttpFile transport verbosity uploadURI path auth headers     case resp of-      (200,_)     ->+      -- Hackage responds with 204 No Content when docs are uploaded+      -- successfully.+      (code,_) | code `elem` [200,204] -> do         notice verbosity "Ok"       (code,err)  -> do         notice verbosity $ "Error uploading documentation "@@ -132,7 +164,7 @@            contents <- getDirectoryContents srcDir            forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->              do inp <- readFile (srcDir </> logFile)-                let (reportStr, buildLog) = read inp :: (String,String)+                let (reportStr, buildLog) = read inp :: (String,String) -- TODO: eradicateNoParse                 case BuildReport.parse reportStr of                   Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME                   Right report' ->@@ -142,22 +174,32 @@                          (remoteRepoURI remoteRepo) [(report', Just buildLog)]                        return () -check :: Verbosity -> RepoContext -> [FilePath] -> IO ()-check verbosity repoCtxt paths = do-    transport <- repoContextGetTransport repoCtxt-    forM_ paths $ \path -> do-      notice verbosity $ "Checking " ++ path ++ "... "-      handlePackage transport verbosity checkURI Nothing path--handlePackage :: HttpTransport -> Verbosity -> URI -> Auth-              -> FilePath -> IO ()-handlePackage transport verbosity uri auth path =+handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth+              -> IsCandidate -> FilePath -> IO ()+handlePackage transport verbosity uri packageUri auth isCandidate path =   do resp <- postHttpFile transport verbosity uri path auth      case resp of-       (200,_)     ->-          notice verbosity "Ok"+       (code,warnings) | code `elem` [200, 204] ->+          notice verbosity $ okMessage isCandidate +++            if null warnings then "" else "\n" ++ formatWarnings (trim warnings)        (code,err)  -> do           notice verbosity $ "Error uploading " ++ path ++ ": "                           ++ "http code " ++ show code ++ "\n"                           ++ err           exitFailure+ where+  okMessage IsCandidate =+    "Package successfully uploaded as candidate. "+    ++ "You can now preview the result at '" ++ show packageUri+    ++ "'. To publish the candidate, use 'cabal upload --publish'."+  okMessage IsPublished =+    "Package successfully published. You can now view it at '"+    ++ show packageUri ++ "'."++formatWarnings :: String -> String+formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x++-- Trim+trim :: String -> String+trim = f . f+      where f = reverse . dropWhile isSpace
cabal/cabal-install/Distribution/Client/Utils.hs view
@@ -3,7 +3,8 @@ module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy                                  , readMaybe-                                 , inDir, logDirChange+                                 , inDir, withEnv, logDirChange+                                 , withExtraPathEnv                                  , determineNumJobs, numberOfProcessors                                  , removeExistingFile                                  , withTempFileName@@ -18,36 +19,26 @@                                  , relaxEncodingErrors)        where +import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Compat.Environment import Distribution.Compat.Exception   ( catchIO )-import Distribution.Client.Compat.Time ( getModTime )+import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup       ( Flag(..) ) import Distribution.Simple.Utils       ( die, findPackageDesc ) import qualified Data.ByteString.Lazy as BS-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import Control.Monad-         ( when ) import Data.Bits          ( (.|.), shiftL, shiftR )-import Data.Char-         ( ord, chr )-#if MIN_VERSION_base(4,6,0)-import Text.Read-         ( readMaybe )-#endif+import System.FilePath import Data.List-         ( isPrefixOf, sortBy, groupBy )-import Data.Word-         ( Word8, Word32)+         ( groupBy ) import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception          ( finally, bracket ) import System.Directory          ( canonicalizePath, doesFileExist, getCurrentDirectory          , removeFile, setCurrentDirectory )-import System.FilePath-         ( (</>), isAbsolute, takeDrive, splitPath, joinPath ) import System.IO          ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0)@@ -64,16 +55,12 @@ #endif  #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)-import Prelude hiding (ioError)-import Control.Monad (liftM2, unless)-import System.Directory (doesDirectoryExist)-import System.IO.Error (ioError, mkIOError, doesNotExistErrorType)+import qualified System.Directory as Dir+import qualified System.IO.Error as IOError #endif  -- | Generic merging utility. For sorted input lists this is a full outer join. ----- * The result list never contains @(Nothing, Nothing)@.--- mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] mergeBy cmp = merge   where@@ -99,14 +86,6 @@     moreThanOne (_:_:_) = True     moreThanOne _       = False -#if !MIN_VERSION_base(4,6,0)--- | An implementation of readMaybe, for compatability with older base versions.-readMaybe :: Read a => String -> Maybe a-readMaybe s = case reads s of-                [(x,"")] -> Just x-                _        -> Nothing-#endif- -- | Like 'removeFile', but does not throw an exception when the file does not -- exist. removeExistingFile :: FilePath -> IO ()@@ -139,6 +118,36 @@   setCurrentDirectory d   m `Exception.finally` setCurrentDirectory old +-- | Executes the action with an environment variable set to some+-- value.+--+-- Warning: This operation is NOT thread-safe, because current+-- environment is a process-global concept.+withEnv :: String -> String -> IO a -> IO a+withEnv k v m = do+  mb_old <- lookupEnv k+  setEnv k v+  m `Exception.finally` (case mb_old of+    Nothing -> unsetEnv k+    Just old -> setEnv k old)++-- | Executes the action, increasing the PATH environment+-- in some way+--+-- Warning: This operation is NOT thread-safe, because the+-- environment variables are a process-global concept.+withExtraPathEnv :: [FilePath] -> IO a -> IO a+withExtraPathEnv paths m = do+  oldPathSplit <- getSearchPath+  let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)+      oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit+      -- TODO: This is a horrible hack to work around the fact that+      -- setEnv can't take empty values as an argument+      mungePath p | p == ""   = "/dev/null"+                  | otherwise = p+  setEnv "PATH" newPath+  m `Exception.finally` setEnv "PATH" oldPath+ -- | Log directory change in 'make' compatible syntax logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a logDirChange _ Nothing m = m@@ -234,9 +243,9 @@ tryCanonicalizePath path = do   ret <- canonicalizePath path #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)-  exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)+  exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)   unless exists $-    ioError $ mkIOError doesNotExistErrorType "canonicalizePath"+    IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"                         Nothing (Just ret) #endif   return ret
+ cabal/cabal-install/Distribution/Client/Utils/Json.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Minimal JSON / RFC 7159 support+--+-- The API is heavily inspired by @aeson@'s API but puts emphasis on+-- simplicity rather than performance. The 'ToJSON' instances are+-- intended to have an encoding compatible with @aeson@'s encoding.+--+module Distribution.Client.Utils.Json+    ( Value(..)+    , Object, object, Pair, (.=)+    , encodeToString+    , encodeToBuilder+    , ToJSON(toJSON)+    )+    where++import Data.Char+import Data.Int+import Data.String+import Data.Word+import Data.List+import Data.Monoid++import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB++-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array  [Value]+           | String  String+           | Number !Double+           | Bool   !Bool+           | Null+           deriving (Eq, Read, Show)++-- | A key\/value pair for an 'Object'+type Pair = (String, Value)++-- | A JSON \"object\" (key/value map).+type Object = [Pair]++infixr 8 .=++-- | A key-value pair for encoding a JSON object.+(.=) :: ToJSON v => String -> v -> Pair+k .= v  = (k, toJSON v)++-- | Create a 'Value' from a list of name\/value 'Pair's.+object :: [Pair] -> Value+object = Object++instance IsString Value where+  fromString = String+++-- | A type that can be converted to JSON.+class ToJSON a where+  -- | Convert a Haskell value to a JSON-friendly intermediate type.+  toJSON :: a -> Value++instance ToJSON () where+  toJSON () = Array []++instance ToJSON Value where+  toJSON = id++instance ToJSON Bool where+  toJSON = Bool++instance ToJSON a => ToJSON [a] where+  toJSON = Array . map toJSON++instance ToJSON a => ToJSON (Maybe a) where+  toJSON Nothing  = Null+  toJSON (Just a) = toJSON a++instance (ToJSON a,ToJSON b) => ToJSON (a,b) where+  toJSON (a,b) = Array [toJSON a, toJSON b]++instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where+  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]++instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where+  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]++instance ToJSON Float where+  toJSON = Number . realToFrac++instance ToJSON Double where+  toJSON = Number++instance ToJSON Int    where  toJSON = Number . realToFrac+instance ToJSON Int8   where  toJSON = Number . realToFrac+instance ToJSON Int16  where  toJSON = Number . realToFrac+instance ToJSON Int32  where  toJSON = Number . realToFrac++instance ToJSON Word   where  toJSON = Number . realToFrac+instance ToJSON Word8  where  toJSON = Number . realToFrac+instance ToJSON Word16 where  toJSON = Number . realToFrac+instance ToJSON Word32 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Int64  where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Word64 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Integer where toJSON = Number . fromInteger++------------------------------------------------------------------------------+-- 'BB.Builder'-based encoding++-- | Serialise value as JSON/UTF8-encoded 'Builder'+encodeToBuilder :: ToJSON a => a -> Builder+encodeToBuilder = encodeValueBB . toJSON++encodeValueBB :: Value -> Builder+encodeValueBB jv = case jv of+  Bool True  -> "true"+  Bool False -> "false"+  Null       -> "null"+  Number n+    | isNaN n || isInfinite n   -> encodeValueBB Null+    | Just i <- doubleToInt64 n -> BB.int64Dec i+    | otherwise                 -> BB.doubleDec n+  Array a  -> encodeArrayBB a+  String s -> encodeStringBB s+  Object o -> encodeObjectBB o++encodeArrayBB :: [Value] -> Builder+encodeArrayBB [] = "[]"+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'+  where+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB++encodeObjectBB :: Object -> Builder+encodeObjectBB [] = "{}"+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'+  where+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair+    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x++encodeStringBB :: String -> Builder+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'+  where+    go = BB.stringUtf8 . escapeString++------------------------------------------------------------------------------+-- 'String'-based encoding++-- | Serialise value as JSON-encoded Unicode 'String'+encodeToString :: ToJSON a => a -> String+encodeToString jv = encodeValue (toJSON jv) []++encodeValue :: Value -> ShowS+encodeValue jv = case jv of+  Bool b   -> showString (if b then "true" else "false")+  Null     -> showString "null"+  Number n+    | isNaN n || isInfinite n    -> encodeValue Null+    | Just i <- doubleToInt64 n -> shows i+    | otherwise                 -> shows n+  Array a -> encodeArray a+  String s -> encodeString s+  Object o -> encodeObject o++encodeArray :: [Value] -> ShowS+encodeArray [] = showString "[]"+encodeArray jvs = ('[':) . go jvs . (']':)+  where+    go []     = id+    go [x]    = encodeValue x+    go (x:xs) = encodeValue x . (',':) . go xs++encodeObject :: Object -> ShowS+encodeObject [] = showString "{}"+encodeObject jvs = ('{':) . go jvs . ('}':)+  where+    go []          = id+    go [(l,x)]     = encodeString l . (':':) . encodeValue x+    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs++encodeString :: String -> ShowS+encodeString str = ('"':) . showString (escapeString str) . ('"':)++------------------------------------------------------------------------------+-- helpers++-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not+-- representable loss-free as integral 'Int64' value.+doubleToInt64 :: Double -> Maybe Int64+doubleToInt64 x+  | fromInteger x' == x+  , x' <= toInteger (maxBound :: Int64)+  , x' >= toInteger (minBound :: Int64)+    = Just (fromIntegral x')+  | otherwise = Nothing+  where+    x' = round x++-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"+escapeString :: String -> String+escapeString s+  | not (any needsEscape s) = s+  | otherwise               = escape s+  where+    escape [] = []+    escape (x:xs) = case x of+      '\\' -> '\\':'\\':escape xs+      '"'  -> '\\':'"':escape xs+      '\b' -> '\\':'b':escape xs+      '\f' -> '\\':'f':escape xs+      '\n' -> '\\':'n':escape xs+      '\r' -> '\\':'r':escape xs+      '\t' -> '\\':'t':escape xs+      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs+        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs+        | otherwise    -> c : escape xs++    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF+    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']
− cabal/cabal-install/Distribution/Client/Utils/LabeledGraph.hs 
@@ -1,116 +0,0 @@--- | Wrapper around Data.Graph with support for edge labels-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Client.Utils.LabeledGraph (-    -- * Graphs-    Graph-  , Vertex-    -- ** Building graphs-  , graphFromEdges-  , graphFromEdges'-  , buildG-  , transposeG-    -- ** Graph properties-  , vertices-  , edges-    -- ** Operations on the underlying unlabeled graph-  , forgetLabels-  , topSort-  ) where--import Data.Array-import Data.Graph (Vertex, Bounds)-import Data.List (sortBy)-import Data.Maybe (mapMaybe)-import qualified Data.Graph as G--{--------------------------------------------------------------------------------  Types--------------------------------------------------------------------------------}--type Graph e = Array Vertex [(e, Vertex)]-type Edge  e = (Vertex, e, Vertex)--{--------------------------------------------------------------------------------  Building graphs--------------------------------------------------------------------------------}---- | Construct an edge-labeled graph------ This is a simple adaptation of the definition in Data.Graph-graphFromEdges :: forall key node edge. Ord key-               => [ (node, key, [(edge, key)]) ]-               -> ( Graph edge-                  , Vertex -> (node, key, [(edge, key)])-                  , key -> Maybe Vertex-                  )-graphFromEdges edges0 =-    (graph, \v -> vertex_map ! v, key_vertex)-  where-    max_v        = length edges0 - 1-    bounds0      = (0, max_v) :: (Vertex, Vertex)-    sorted_edges = sortBy lt edges0-    edges1       = zipWith (,) [0..] sorted_edges--    graph        = array bounds0 [(v, (mapMaybe mk_edge ks))-                                 | (v, (_, _, ks)) <- edges1]-    key_map      = array bounds0 [(v, k                    )-                                 | (v, (_, k, _ )) <- edges1]-    vertex_map   = array bounds0 edges1--    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2--    mk_edge :: (edge, key) -> Maybe (edge, Vertex)-    mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)--    --  returns Nothing for non-interesting vertices-    key_vertex :: key -> Maybe Vertex-    key_vertex k = findVertex 0 max_v-      where-        findVertex a b-          | a > b     = Nothing-          | otherwise = case compare k (key_map ! mid) of-              LT -> findVertex a (mid-1)-              EQ -> Just mid-              GT -> findVertex (mid+1) b-          where-            mid = a + (b - a) `div` 2--graphFromEdges' :: Ord key-                => [ (node, key, [(edge, key)]) ]-                -> ( Graph edge-                   , Vertex -> (node, key, [(edge, key)])-                   )-graphFromEdges' x = (a,b)-  where-    (a,b,_) = graphFromEdges x--transposeG :: Graph e -> Graph e-transposeG g = buildG (bounds g) (reverseE g)--buildG :: Bounds -> [Edge e] -> Graph e-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)-  where-    reassoc (v, e, w) = (v, (e, w))--reverseE :: Graph e -> [Edge e]-reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]--{--------------------------------------------------------------------------------  Graph properties--------------------------------------------------------------------------------}--vertices :: Graph e -> [Vertex]-vertices = indices--edges :: Graph e -> [Edge e]-edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]--{--------------------------------------------------------------------------------  Operations on the underlying unlabelled graph--------------------------------------------------------------------------------}--forgetLabels :: Graph e -> G.Graph-forgetLabels = fmap (map snd)--topSort :: Graph e -> [Vertex]-topSort = G.topSort . forgetLabels
cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs view
@@ -42,7 +42,7 @@     deleteOldExeFile,   ) where -#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS  import qualified System.Win32 as Win32 import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)
cabal/cabal-install/Distribution/Client/World.hs view
@@ -31,8 +31,10 @@  import Distribution.Package          ( Dependency(..) )+import Distribution.Package.TextClass+         () import Distribution.PackageDescription-         ( FlagAssignment, FlagName(FlagName) )+         ( FlagAssignment, mkFlagName, unFlagName ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Simple.Utils@@ -128,10 +130,10 @@       dispFlags [] = Disp.empty       dispFlags fs = Disp.text "--flags="                   <> Disp.doubleQuotes (flagAssToDoc fs)-      flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->+      flagAssToDoc = foldr (\(fname,val) flagAssDoc ->                              (if not val then Disp.char '-'                                          else Disp.empty)-                             Disp.<> Disp.text fname+                             Disp.<> Disp.text (unFlagName fname)                              Disp.<+> flagAssDoc)                            Disp.empty   parse = do@@ -156,7 +158,7 @@             val <- negative Parse.+++ positive             name <- ident             Parse.skipSpaces-            return (FlagName name,val)+            return (mkFlagName name,val)           negative = do             _ <- Parse.char '-'             return False
+ cabal/cabal-install/Distribution/Solver/Modular.hs view
@@ -0,0 +1,66 @@+module Distribution.Solver.Modular+         ( modularResolver, SolverConfig(..)) where++-- Here, we try to map between the external cabal-install solver+-- interface and the internal interface that the solver actually+-- expects. There are a number of type conversions to perform: we+-- have to convert the package indices to the uniform index used+-- by the solver; we also have to convert the initial constraints;+-- and finally, we have to convert back the resulting install+-- plan.++import Data.Function+         ( on )+import Data.List+         ( nubBy )+import Data.Map as M+         ( fromListWith )+import Distribution.Compat.Graph+         ( IsNode(..) )+import Distribution.Solver.Modular.Assignment+         ( toCPs )+import Distribution.Solver.Modular.ConfiguredConversion+         ( convCP )+import Distribution.Solver.Modular.IndexConversion+         ( convPIs )+import Distribution.Solver.Modular.Log+         ( logToProgress )+import Distribution.Solver.Modular.Package+         ( PN )+import Distribution.Solver.Modular.Solver+         ( SolverConfig(..), solve )+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.DependencyResolver+import Distribution.System+         ( Platform(..) )++-- | Ties the two worlds together: classic cabal-install vs. the modular+-- solver. Performs the necessary translations before and after.+modularResolver :: SolverConfig -> DependencyResolver loc+modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =+  fmap (uncurry postprocess)      $ -- convert install plan+  logToProgress (maxBackjumps sc) $ -- convert log format into progress format+  solve sc cinfo idx pkgConfigDB pprefs gcs pns+    where+      -- Indices have to be converted into solver-specific uniform index.+      idx    = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx+      -- Constraints have to be converted into a finite map indexed by PN.+      gcs    = M.fromListWith (++) (map pair pcs)+        where+          pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])++      -- Results have to be converted into an install plan. 'convCP' removes+      -- package qualifiers, which means that linked packages become duplicates+      -- and can be removed.+      -- TODO: Use ordNubBy instead of nubBy.+      postprocess a rdm = nubBy ((==) `on` nodeKey) $+                          map (convCP iidx sidx) (toCPs a rdm)++      -- Helper function to extract the PN from a constraint.+      pcName :: PackageConstraint -> PN+      pcName (PackageConstraintVersion   pn _) = pn+      pcName (PackageConstraintInstalled pn  ) = pn+      pcName (PackageConstraintSource    pn  ) = pn+      pcName (PackageConstraintFlags     pn _) = pn+      pcName (PackageConstraintStanzas   pn _) = pn
+ cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs view
@@ -0,0 +1,152 @@+module Distribution.Solver.Modular.Assignment+    ( Assignment(..)+    , FAssignment+    , SAssignment+    , PreAssignment(..)+    , extend+    , toCPs+    ) where++import Control.Applicative+import Control.Monad+import Data.Array as A+import Data.List as L+import Data.Map as M+import Data.Maybe+import Prelude hiding (pi)++import Language.Haskell.Extension (Extension, Language)++import Distribution.PackageDescription (FlagAssignment) -- from Cabal++import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)+import qualified Distribution.Solver.Types.ComponentDeps as CD+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath++import Distribution.Solver.Modular.Configured+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.LabeledGraph+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Version++-- | A (partial) package assignment. Qualified package names+-- are associated with instances.+type PAssignment    = Map QPN I++-- | A (partial) package preassignment. Qualified package names+-- are associated with constrained instances. Constrained instances+-- record constraints about the instances that can still be chosen,+-- and in the extreme case fix a concrete instance.+type PPreAssignment = Map QPN (CI QPN)+type FAssignment    = Map QFN Bool+type SAssignment    = Map QSN Bool++-- | A (partial) assignment of variables.+data Assignment = A PAssignment FAssignment SAssignment+  deriving (Show, Eq)++-- | A preassignment comprises knowledge about variables, but not+-- necessarily fixed values.+data PreAssignment = PA PPreAssignment FAssignment SAssignment++-- | Extend a package preassignment.+--+-- Takes the variable that causes the new constraints, a current preassignment+-- and a set of new dependency constraints.+--+-- We're trying to extend the preassignment with each dependency one by one.+-- Each dependency is for a particular variable. We check if we already have+-- constraints for that variable in the current preassignment. If so, we're+-- trying to merge the constraints.+--+-- Either returns a witness of the conflict that would arise during the merge,+-- or the successfully extended assignment.+extend :: (Extension -> Bool) -- ^ is a given extension supported+       -> (Language  -> Bool) -- ^ is a given language supported+       -> (PkgconfigName -> VR  -> Bool) -- ^ is a given pkg-config requirement satisfiable+       -> Var QPN+       -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment+extend extSupported langSupported pkgPresent var = foldM extendSingle+  where++    extendSingle :: PPreAssignment -> Dep QPN+                 -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment+    extendSingle a (Ext  ext )  =+      if extSupported  ext  then Right a+                            else Left (varToConflictSet var, [Ext ext])+    extendSingle a (Lang lang)  =+      if langSupported lang then Right a+                            else Left (varToConflictSet var, [Lang lang])+    extendSingle a (Pkg pn vr)  =+      if pkgPresent pn vr then Right a+                          else Left (varToConflictSet var, [Pkg pn vr])+    extendSingle a (Dep is_exe qpn ci) =+      let ci' = M.findWithDefault (Constrained []) qpn a+      in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of+            Left (c, (d, d')) -> Left  (c, L.map (Dep is_exe qpn) (simplify (P qpn) d d'))+            Right x           -> Right x++    -- We're trying to remove trivial elements of the conflict. If we're just+    -- making a choice pkg == instance, and pkg => pkg == instance is a part+    -- of the conflict, then this info is clear from the context and does not+    -- have to be repeated.+    simplify v (Fixed _ var') c | v == var && var' == var = [c]+    simplify v c (Fixed _ var') | v == var && var' == var = [c]+    simplify _ c              d                           = [c, d]++-- | Delivers an ordered list of fully configured packages.+--+-- TODO: This function is (sort of) ok. However, there's an open bug+-- w.r.t. unqualification. There might be several different instances+-- of one package version chosen by the solver, which will lead to+-- clashes.+toCPs :: Assignment -> RevDepMap -> [CP QPN]+toCPs (A pa fa sa) rdm =+  let+    -- get hold of the graph+    g   :: Graph Component+    vm  :: Vertex -> ((), QPN, [(Component, QPN)])+    cvm :: QPN -> Maybe Vertex+    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.+    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))+                                  (M.toList rdm))+    tg :: Graph Component+    tg = transposeG g+    -- Topsort the dependency graph, yielding a list of pkgs in the right order.+    -- The graph will still contain all the installed packages, and it might+    -- contain duplicates, because several variables might actually resolve to+    -- the same package in the presence of qualified package names.+    ps :: [PI QPN]+    ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $+         topSort g+    -- Determine the flags per package, by walking over and regrouping the+    -- complete flag assignment by package.+    fapp :: Map QPN FlagAssignment+    fapp = M.fromListWith (++) $+           L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $+           M.toList $+           fa+    -- Stanzas per package.+    sapp :: Map QPN [OptionalStanza]+    sapp = M.fromListWith (++) $+           L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $+           M.toList $+           sa+    -- Dependencies per package.+    depp :: QPN -> [(Component, PI QPN)]+    depp qpn = let v :: Vertex+                   v   = fromJust (cvm qpn)+                   dvs :: [(Component, Vertex)]+                   dvs = tg A.! v+               in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs+    -- Translated to PackageDeps+    depp' :: QPN -> ComponentDeps [PI QPN]+    depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp+  in+    L.map (\ pi@(PI qpn _) -> CP pi+                                 (M.findWithDefault [] qpn fapp)+                                 (M.findWithDefault [] qpn sapp)+                                 (depp' qpn))+          ps
+ cabal/cabal-install/Distribution/Solver/Modular/Builder.hs view
@@ -0,0 +1,192 @@+module Distribution.Solver.Modular.Builder (buildTree) where++-- Building the search tree.+--+-- In this phase, we build a search tree that is too large, i.e, it contains+-- invalid solutions. We keep track of the open goals at each point. We+-- nondeterministically pick an open goal (via a goal choice node), create+-- subtrees according to the index and the available solutions, and extend the+-- set of open goals by superficially looking at the dependencies recorded in+-- the index.+--+-- For each goal, we keep track of all the *reasons* why it is being+-- introduced. These are for debugging and error messages, mainly. A little bit+-- of care has to be taken due to the way we treat flags. If a package has+-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we+-- store the entire dependency.++import Data.List as L+import Data.Map as M+import Prelude hiding (sequence, mapM)++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.PSQ (PSQ)+import qualified Distribution.Solver.Modular.PSQ as P+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Distribution.Solver.Types.ComponentDeps (Component)+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Settings++-- | The state needed during the build phase of the search tree.+data BuildState = BS {+  index :: Index,                -- ^ information about packages and their dependencies+  rdeps :: RevDepMap,            -- ^ set of all package goals, completed and open, with reverse dependencies+  open  :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals)+  next  :: BuildType,            -- ^ kind of node to generate next+  qualifyOptions :: QualifyOptions -- ^ qualification options+}++-- | Extend the set of open goals with the new goals listed.+--+-- We also adjust the map of overall goals, and keep track of the+-- reverse dependencies of each of the goals.+extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState+extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs+  where+    go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState+    go g o []                                               = s { rdeps = g, open = o }+    go g o (ng@(OpenGoal (Flagged _ _ _ _)      _gr) : ngs) = go g (cons' ng () o) ngs+      -- Note: for 'Flagged' goals, we always insert, so later additions win.+      -- This is important, because in general, if a goal is inserted twice,+      -- the later addition will have better dependency information.+    go g o (ng@(OpenGoal (Stanza  _   _  )      _gr) : ngs) = go g (cons' ng () o) ngs+    go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs)+      | qpn == qpn'       = go                            g               o  ngs+          -- we ignore self-dependencies at this point; TODO: more care may be needed+      | qpn `M.member` g  = go (M.adjust ((c, qpn'):) qpn g)              o  ngs+      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (cons' ng () o) ngs+          -- code above is correct; insert/adjust have different arg order+    go g o (   (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs+    go g o (   (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs+    go g o (   (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs++    cons' = P.cons . forgetCompOpenGoal++-- | Given the current scope, qualify all the package names in the given set of+-- dependencies and then extend the set of open goals accordingly.+scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->+                    BuildState -> BuildState+scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s+  where+    -- Qualify all package names+    qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps+    -- Introduce all package flags+    qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs+    -- Combine new package and flag goals+    gs     = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps)+    -- NOTE:+    --+    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially+    -- multiple times, both via the flag declaration and via dependencies.+    -- The order is potentially important, because the occurrences via+    -- dependencies may record flag-dependency information. After a number+    -- of bugs involving computing this information incorrectly, however,+    -- we're currently not using carefully computed inter-flag dependencies+    -- anymore, but instead use 'simplifyVar' when computing conflict sets+    -- to map all flags of one package to a single flag for conflict set+    -- purposes, thereby treating them all as interdependent.+    --+    -- If we ever move to a more clever algorithm again, then the line above+    -- needs to be looked at very carefully, and probably be replaced by+    -- more systematically computed flag dependency information.++-- | Datatype that encodes what to build next+data BuildType =+    Goals                                  -- ^ build a goal choice node+  | OneGoal (OpenGoal ())                  -- ^ build a node for this goal+  | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance+  deriving Show++build :: BuildState -> Tree () QGoalReason+build = ana go+  where+    go :: BuildState -> TreeF () QGoalReason BuildState++    -- If we have a choice between many goals, we just record the choice in+    -- the tree. We select each open goal in turn, and before we descend, remove+    -- it from the queue of open goals.+    go bs@(BS { rdeps = rds, open = gs, next = Goals })+      | P.null gs = DoneF rds ()+      | otherwise = GoalChoiceF $ P.mapKeys close+                                $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })+                                $ P.splits gs++    -- If we have already picked a goal, then the choice depends on the kind+    -- of goal.+    --+    -- For a package, we look up the instances available in the global info,+    -- and then handle each instance in turn.+    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =+      error "Distribution.Solver.Modular.Builder: build.go called with Ext goal"+    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =+      error "Distribution.Solver.Modular.Builder: build.go called with Lang goal"+    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =+      error "Distribution.Solver.Modular.Builder: build.go called with Pkg goal"+    go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =+      -- If the package does not exist in the index, we construct an emty PChoiceF node for it+      -- After all, we have no choices here. Alternatively, we could immediately construct+      -- a Fail node here, but that would complicate the construction of conflict sets.+      -- We will probably want to give this case special treatment when generating error+      -- messages though.+      case M.lookup pn idx of+        Nothing  -> PChoiceF qpn gr (W.fromList [])+        Just pis -> PChoiceF qpn gr (W.fromList (L.map (\ (i, info) ->+                                                           ([], POption i Nothing, bs { next = Instance qpn i info gr }))+                                                         (M.toList pis)))+          -- TODO: data structure conversion is rather ugly here++    -- For a flag, we create only two subtrees, and we create them in the order+    -- that is indicated by the flag default.+    --+    -- TODO: Should we include the flag default in the tree?+    go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =+      FChoiceF qfn gr weak m (W.fromList+        [([if b then 0 else 1], True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),+         ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])+      where+        trivial = L.null t && L.null f+        weak = WeakOrTrivial $ unWeakOrTrivial w || trivial++    -- For a stanza, we also create only two subtrees. The order is initially+    -- False, True. This can be changed later by constraints (force enabling+    -- the stanza by replacing the False branch with failure) or preferences+    -- (try enabling the stanza if possible by moving the True branch first).++    go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =+      SChoiceF qsn gr trivial (W.fromList+        [([0], False,                                                             bs  { next = Goals }),+         ([1], True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])+      where+        trivial = WeakOrTrivial (L.null t)++    -- For a particular instance, we change the state: we update the scope,+    -- and furthermore we update the set of goals.+    --+    -- TODO: We could inline this above.+    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =+      go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)+             { next = Goals })++-- | Interface to the tree builder. Just takes an index and a list of package names,+-- and computes the initial state and then the tree from there.+buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason+buildTree idx (IndependentGoals ind) igs =+    build BS {+        index = idx+      , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)+      , open  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)+      , next  = Goals+      , qualifyOptions = defaultQualifyOptions idx+      }+  where+    -- Should a top-level goal allowed to be an executable style+    -- dependency? Well, I don't think it would make much difference+    topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal++    qpns | ind       = makeIndependent igs+         | otherwise = L.map (Q (PackagePath DefaultNamespace Unqualified)) igs
+ cabal/cabal-install/Distribution/Solver/Modular/Configured.hs view
@@ -0,0 +1,13 @@+module Distribution.Solver.Modular.Configured+    ( CP(..)+    ) where++import Distribution.PackageDescription (FlagAssignment)++import Distribution.Solver.Modular.Package+import Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import Distribution.Solver.Types.OptionalStanza++-- | A configured package is a package instance together with+-- a flag assignment and complete dependencies.+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])
+ cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs view
@@ -0,0 +1,72 @@+module Distribution.Solver.Modular.ConfiguredConversion+    ( convCP+    ) where++import Data.Maybe+import Prelude hiding (pi)+import Data.Either (partitionEithers)++import Distribution.Package (UnitId, packageId)++import qualified Distribution.Simple.PackageIndex as SI++import Distribution.Solver.Modular.Configured+import Distribution.Solver.Modular.Package++import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import qualified Distribution.Solver.Types.PackageIndex as CI+import           Distribution.Solver.Types.PackagePath+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.InstSolverPackage+import           Distribution.Solver.Types.SourcePackage++-- | Converts from the solver specific result @CP QPN@ into+-- a 'ResolverPackage', which can then be converted into+-- the install plan.+convCP :: SI.InstalledPackageIndex ->+          CI.PackageIndex (SourcePackage loc) ->+          CP QPN -> ResolverPackage loc+convCP iidx sidx (CP qpi fa es ds) =+  case convPI qpi of+    Left  pi -> PreExisting $+                  InstSolverPackage {+                    instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,+                    instSolverPkgLibDeps = fmap fst ds',+                    instSolverPkgExeDeps = fmap snd ds'+                  }+    Right pi -> Configured $+                  SolverPackage {+                      solverPkgSource = srcpkg,+                      solverPkgFlags = fa,+                      solverPkgStanzas = es,+                      solverPkgLibDeps = fmap fst ds',+                      solverPkgExeDeps = fmap snd ds'+                    }+      where+        Just srcpkg = CI.lookupPackageId sidx pi+  where+    ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})+    ds' = fmap (partitionEithers . map convConfId) ds++convPI :: PI QPN -> Either UnitId PackageId+convPI (PI _ (I _ (Inst pi))) = Left pi+convPI pi                     = Right (packageId (either id id (convConfId pi)))++convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}+convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =+    case loc of+        Inst pi -> Left (PreExistingId sourceId pi)+        _otherwise+          | Exe _ pn' <- q+          -- NB: the dependencies of the executable are also+          -- qualified.  So the way to tell if this is an executable+          -- dependency is to make sure the qualifier is pointing+          -- at the actual thing.  Fortunately for us, I was+          -- silly and didn't allow arbitrarily nested build-tools+          -- dependencies, so a shallow check works.+          , pn == pn' -> Right (PlannedId sourceId)+          | otherwise    -> Left  (PlannedId sourceId)+  where+    sourceId    = PackageIdentifier pn v
+ cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+#ifdef DEBUG_CONFLICT_SETS+{-# LANGUAGE ImplicitParams #-}+#endif+-- | Conflict sets+--+-- Intended for double import+--+-- > import Distribution.Solver.Modular.ConflictSet (ConflictSet)+-- > import qualified Distribution.Solver.Modular.ConflictSet as CS+module Distribution.Solver.Modular.ConflictSet (+    ConflictSet -- opaque+#ifdef DEBUG_CONFLICT_SETS+  , conflictSetOrigin+#endif+  , showCS+    -- Set-like operations+  , toList+  , union+  , unions+  , insert+  , empty+  , singleton+  , member+  , filter+  , fromList+  ) where++import Prelude hiding (filter)+import Data.List (intercalate)+import Data.Set (Set)+import Data.Function (on)+import qualified Data.Set as S++#ifdef DEBUG_CONFLICT_SETS+import Data.Tree+import GHC.Stack+#endif++import Distribution.Solver.Modular.Var+import Distribution.Solver.Types.PackagePath++-- | The set of variables involved in a solver conflict+--+-- Since these variables should be preprocessed in some way, this type is+-- kept abstract.+data ConflictSet qpn = CS {+    -- | The set of variables involved on the conflict+    conflictSetToSet :: Set (Var qpn)++#ifdef DEBUG_CONFLICT_SETS+    -- | The origin of the conflict set+    --+    -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@,+    -- we record the origin of every conflict set. For new conflict sets+    -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations+    -- that construct new conflict sets from existing conflict sets ('union',+    -- 'filter', ..)  we record the 'CallStack' to the call to the combinator+    -- as well as the 'CallStack's of the input conflict sets.+    --+    -- Requires @GHC >= 7.10@.+  , conflictSetOrigin :: Tree CallStack+#endif+  }+  deriving (Show)++instance Eq qpn => Eq (ConflictSet qpn) where+  (==) = (==) `on` conflictSetToSet++instance Ord qpn => Ord (ConflictSet qpn) where+  compare = compare `on` conflictSetToSet++showCS :: ConflictSet QPN -> String+showCS = intercalate ", " . map showVar . toList++{-------------------------------------------------------------------------------+  Set-like operations+-------------------------------------------------------------------------------}++toList :: ConflictSet qpn -> [Var qpn]+toList = S.toList . conflictSetToSet++union ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn+union cs cs' = CS {+      conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs')+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs'])+#endif+    }++unions ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Ord qpn => [ConflictSet qpn] -> ConflictSet qpn+unions css = CS {+      conflictSetToSet = S.unions (map conflictSetToSet css)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc (map conflictSetOrigin css)+#endif+    }++insert ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn+insert var cs = CS {+      conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]+#endif+    }++empty ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  ConflictSet qpn+empty = CS {+      conflictSetToSet = S.empty+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++singleton ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Var qpn -> ConflictSet qpn+singleton var = CS {+      conflictSetToSet = S.singleton (simplifyVar var)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool+member var = S.member (simplifyVar var) . conflictSetToSet++filter ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+#if !MIN_VERSION_containers(0,5,0)+  Ord qpn =>+#endif+  (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn+filter p cs = CS {+      conflictSetToSet = S.filter p (conflictSetToSet cs)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]+#endif+    }++fromList ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Ord qpn => [Var qpn] -> ConflictSet qpn+fromList vars = CS {+      conflictSetToSet = S.fromList (map simplifyVar vars)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }
+ cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs view
@@ -0,0 +1,50 @@+module Distribution.Solver.Modular.Cycles (+    detectCyclesPhase+  ) where++import Prelude hiding (cycle)+import Data.Graph (SCC)+import qualified Data.Graph as Gr+import qualified Data.Map   as Map++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Types.PackagePath++-- | Find and reject any solutions that are cyclic+detectCyclesPhase :: Tree d c -> Tree d c+detectCyclesPhase = cata go+  where+    -- The only node of interest is DoneF+    go :: TreeF d c (Tree d c) -> Tree d c+    go (PChoiceF qpn gr     cs) = PChoice qpn gr     cs+    go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs+    go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   cs+    go (GoalChoiceF         cs) = GoalChoice         cs+    go (FailF cs reason)        = Fail cs reason++    -- We check for cycles only if we have actually found a solution+    -- This minimizes the number of cycle checks we do as cycles are rare+    go (DoneF revDeps s) = do+      case findCycles revDeps of+        Nothing     -> Done revDeps s+        Just relSet -> Fail relSet CyclicDependencies++-- | Given the reverse dependency map from a 'Done' node in the tree, check+-- if the solution is cyclic. If it is, return the conflict set containing+-- all decisions that could potentially break the cycle.+findCycles :: RevDepMap -> Maybe (ConflictSet QPN)+findCycles revDeps =+    case cycles of+      []  -> Nothing+      c:_ -> Just $ CS.unions $ map (varToConflictSet . P) c+  where+    cycles :: [[QPN]]+    cycles = [vs | Gr.CyclicSCC vs <- scc]++    scc :: [SCC QPN]+    scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps++    aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN])+    aux (fr, to) = (fr, fr, map snd to)
+ cabal/cabal-install/Distribution/Solver/Modular/Degree.hs view
@@ -0,0 +1,21 @@+module Distribution.Solver.Modular.Degree where++-- | Approximation of the branching degree.+--+-- This is designed for computing the branching degree of a goal choice+-- node. If the degree is 0 or 1, it is always good to take that goal,+-- because we can either abort immediately, or have no other choice anyway.+--+-- So we do not actually want to compute the full degree (which is+-- somewhat costly) in cases where we have such an easy choice.+--+data Degree = ZeroOrOne | Two | Other+  deriving (Show, Eq)++instance Ord Degree where+  compare ZeroOrOne _         = LT -- lazy approximation+  compare _         ZeroOrOne = GT -- approximation+  compare Two       Two       = EQ+  compare Two       Other     = LT+  compare Other     Two       = GT+  compare Other     Other     = EQ
+ cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+#ifdef DEBUG_CONFLICT_SETS+{-# LANGUAGE ImplicitParams #-}+#endif+module Distribution.Solver.Modular.Dependency (+    -- * Variables+    Var(..)+  , simplifyVar+  , varPI+  , showVar+    -- * Conflict sets+  , ConflictSet+  , CS.showCS+    -- * Constrained instances+  , CI(..)+  , merge+    -- * Flagged dependencies+  , FlaggedDeps+  , FlaggedDep(..)+  , Dep(..)+  , showDep+  , flattenFlaggedDeps+  , QualifyOptions(..)+  , qualifyDeps+  , unqualifyDeps+    -- ** Setting/forgetting components+  , forgetCompOpenGoal+  , setCompFlaggedDeps+    -- * Reverse dependency map+  , RevDepMap+    -- * Goals+  , Goal(..)+  , GoalReason(..)+  , QGoalReason+  , ResetVar(..)+  , goalToVar+  , goalVarToConflictSet+  , varToConflictSet+  , goalReasonToVars+    -- * Open goals+  , OpenGoal(..)+  , close+  ) where++import Prelude hiding (pi)++import Data.Map (Map)+import qualified Data.List as L++import Language.Haskell.Extension (Extension(..), Language(..))++import Distribution.Text++import Distribution.Solver.Modular.ConflictSet (ConflictSet)+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Var+import Distribution.Solver.Modular.Version+import qualified Distribution.Solver.Modular.ConflictSet as CS++import Distribution.Solver.Types.ComponentDeps (Component(..))+import Distribution.Solver.Types.PackagePath++#ifdef DEBUG_CONFLICT_SETS+import GHC.Stack (CallStack)+#endif++{-------------------------------------------------------------------------------+  Constrained instances+-------------------------------------------------------------------------------}++-- | Constrained instance. If the choice has already been made, this is+-- a fixed instance, and we record the package name for which the choice+-- is for convenience. Otherwise, it is a list of version ranges paired with+-- the goals / variables that introduced them.+data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn]+  deriving (Eq, Show, Functor)++showCI :: CI QPN -> String+showCI (Fixed i _)      = "==" ++ showI i+showCI (Constrained vr) = showVR (collapse vr)++-- | Merge constrained instances. We currently adopt a lazy strategy for+-- merging, i.e., we only perform actual checking if one of the two choices+-- is fixed. If the merge fails, we return a conflict set indicating the+-- variables responsible for the failure, as well as the two conflicting+-- fragments.+--+-- Note that while there may be more than one conflicting pair of version+-- ranges, we only return the first we find.+--+-- TODO: Different pairs might have different conflict sets. We're+-- obviously interested to return a conflict that has a "better" conflict+-- set in the sense the it contains variables that allow us to backjump+-- further. We might apply some heuristics here, such as to change the+-- order in which we check the constraints.+merge ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)+merge c@(Fixed i g1)       d@(Fixed j g2)+  | i == j                                    = Right c+  | otherwise                                 = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d))+merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...+  where+    go []              = Right c+    go (d@(vr, g2) : vrs)+      | checkVR vr v   = go vrs+      | otherwise      = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d]))+merge c@(Constrained _)    d@(Fixed _ _)      = merge d c+merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))++{-------------------------------------------------------------------------------+  Flagged dependencies+-------------------------------------------------------------------------------}++-- | Flagged dependencies+--+-- 'FlaggedDeps' is the modular solver's view of a packages dependencies:+-- rather than having the dependencies indexed by component, each dependency+-- defines what component it is in.+--+-- However, top-level goals are also modelled as dependencies, but of course+-- these don't actually belong in any component of any package. Therefore, we+-- parameterize 'FlaggedDeps' and derived datatypes with a type argument that+-- specifies whether or not we have a component: we only ever instantiate this+-- type argument with @()@ for top-level goals, or 'Component' for everything+-- else (we could express this as a kind at the type-level, but that would+-- require a very recent GHC).+--+-- Note however, crucially, that independent of the type parameters, the list+-- of dependencies underneath a flag choice or stanza choices _always_ uses+-- Component as the type argument. This is important: when we pick a value for+-- a flag, we _must_ know what component the new dependencies belong to, or+-- else we don't be able to construct fine-grained reverse dependencies.+type FlaggedDeps comp qpn = [FlaggedDep comp qpn]++-- | Flagged dependencies can either be plain dependency constraints,+-- or flag-dependent dependency trees.+data FlaggedDep comp qpn =+    -- | Dependencies which are conditional on a flag choice.+    Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)+    -- | Dependencies which are conditional on whether or not a stanza+    -- (e.g., a test suite or benchmark) is enabled.+  | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)+    -- | Dependencies for which are always enabled, for the component+    -- 'comp' (or requested for the user, if comp is @()@).+  | Simple (Dep qpn) comp+  deriving (Eq, Show)++-- | Conversatively flatten out flagged dependencies+--+-- NOTE: We do not filter out duplicates.+flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)]+flattenFlaggedDeps = concatMap aux+  where+    aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)]+    aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f+    aux (Stanza  _   t)   = flattenFlaggedDeps t+    aux (Simple d c)      = [(d, c)]++type TrueFlaggedDeps  qpn = FlaggedDeps Component qpn+type FalseFlaggedDeps qpn = FlaggedDeps Component qpn++-- | Is this dependency on an executable+type IsExe = Bool++-- | A dependency (constraint) associates a package name with a+-- constrained instance.+--+-- 'Dep' intentionally has no 'Functor' instance because the type variable+-- is used both to record the dependencies as well as who's doing the+-- depending; having a 'Functor' instance makes bugs where we don't distinguish+-- these two far too likely. (By rights 'Dep' ought to have two type variables.)+data Dep qpn = Dep IsExe qpn (CI qpn)  -- ^ dependency on a package (possibly for executable+             | Ext  Extension          -- ^ dependency on a language extension+             | Lang Language           -- ^ dependency on a language version+             | Pkg  PkgconfigName VR   -- ^ dependency on a pkg-config package+  deriving (Eq, Show)++showDep :: Dep QPN -> String+showDep (Dep is_exe qpn (Fixed i v)            ) =+  (if P qpn /= v then showVar v ++ " => " else "") +++  showQPN qpn +++  (if is_exe then " (exe) " else "") ++ "==" ++ showI i+showDep (Dep is_exe qpn (Constrained [(vr, v)])) =+  showVar v ++ " => " ++ showQPN qpn +++  (if is_exe then " (exe) " else "") ++ showVR vr+showDep (Dep is_exe qpn ci                     ) =+  showQPN qpn ++ (if is_exe then " (exe) " else "") ++ showCI ci+showDep (Ext ext)   = "requires " ++ display ext+showDep (Lang lang) = "requires " ++ display lang+showDep (Pkg pn vr) = "requires pkg-config package "+                      ++ display pn ++ display vr+                      ++ ", not found in the pkg-config database"++-- | Options for goal qualification (used in 'qualifyDeps')+--+-- See also 'defaultQualifyOptions'+data QualifyOptions = QO {+    -- | Do we have a version of base relying on another version of base?+    qoBaseShim :: Bool++    -- Should dependencies of the setup script be treated as independent?+  , qoSetupIndependent :: Bool+  }+  deriving Show++-- | Apply built-in rules for package qualifiers+--+-- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions',+-- it is important that these 'QualifyOptions' are _static_. Qualification+-- does NOT depend on flag assignment; in other words, it behaves the same no+-- matter which choices the solver makes (modulo the global 'QualifyOptions');+-- we rely on this in 'linkDeps' (see comment there).+--+-- NOTE: It's the _dependencies_ of a package that may or may not be independent+-- from the package itself. Package flag choices must of course be consistent.+qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN+qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go+  where+    go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN+    go = map go1++    go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN+    go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)+    go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)+    go1 (Simple dep comp)    = Simple (goD dep comp) comp++    -- Suppose package B has a setup dependency on package A.+    -- This will be recorded as something like+    --+    -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason])+    --+    -- Observe that when we qualify this dependency, we need to turn that+    -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier+    -- to the goal or the goal reason chain.+    goD :: Dep PN -> Component -> Dep QPN+    goD (Ext  ext)    _    = Ext  ext+    goD (Lang lang)   _    = Lang lang+    goD (Pkg pkn vr)  _    = Pkg pkn vr+    goD (Dep is_exe dep ci) comp+      | is_exe      = Dep is_exe (Q (PackagePath ns (Exe pn dep)) dep) (fmap (Q pp) ci)+      | qBase  dep  = Dep is_exe (Q (PackagePath ns (Base  pn)) dep) (fmap (Q pp) ci)+      | qSetup comp = Dep is_exe (Q (PackagePath ns (Setup pn)) dep) (fmap (Q pp) ci)+      | otherwise   = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci)++    -- If P has a setup dependency on Q, and Q has a regular dependency on R, then+    -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup+    -- dependency on R. We do not do this for the base qualifier however.+    --+    -- The inherited qualifier is only used for regular dependencies; for setup+    -- and base deppendencies we override the existing qualifier. See #3160 for+    -- a detailed discussion.+    inheritedQ :: Qualifier+    inheritedQ = case q of+                   Setup _     -> q+                   Exe _ _     -> q+                   Unqualified -> q+                   Base _      -> Unqualified++    -- Should we qualify this goal with the 'Base' package path?+    qBase :: PN -> Bool+    qBase dep = qoBaseShim && unPackageName dep == "base"++    -- Should we qualify this goal with the 'Setup' package path?+    qSetup :: Component -> Bool+    qSetup comp = qoSetupIndependent && comp == ComponentSetup++-- | Remove qualifiers from set of dependencies+--+-- This is used during link validation: when we link package @Q.A@ to @Q'.A@,+-- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute+-- what to link these dependencies to, we need to requalify @Q.B@ to become+-- @Q'.B@; we do this by first removing all qualifiers and then calling+-- 'qualifyDeps' again.+unqualifyDeps :: FlaggedDeps comp QPN -> FlaggedDeps comp PN+unqualifyDeps = go+  where+    go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN+    go = map go1++    go1 :: FlaggedDep comp QPN -> FlaggedDep comp PN+    go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f)+    go1 (Stanza  sn     t)   = Stanza  (fmap unq sn)     (go t)+    go1 (Simple dep comp)    = Simple (goD dep) comp++    goD :: Dep QPN -> Dep PN+    goD (Dep is_exe qpn ci) = Dep is_exe (unq qpn) (fmap unq ci)+    goD (Ext  ext)   = Ext ext+    goD (Lang lang)  = Lang lang+    goD (Pkg pn vr)  = Pkg pn vr++    unq :: QPN -> PN+    unq (Q _ pn) = pn++{-------------------------------------------------------------------------------+  Setting/forgetting the Component+-------------------------------------------------------------------------------}++forgetCompOpenGoal :: OpenGoal Component -> OpenGoal ()+forgetCompOpenGoal = mapCompOpenGoal $ const ()++setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn+setCompFlaggedDeps = mapCompFlaggedDeps . const++{-------------------------------------------------------------------------------+  Auxiliary: Mapping over the Component goal++  We don't export these, because the only type instantiations for 'a' and 'b'+  here should be () or Component. (We could express this at the type level+  if we relied on newer versions of GHC.)+-------------------------------------------------------------------------------}++mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b+mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr++mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn+mapCompFlaggedDeps = L.map . mapCompFlaggedDep++mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn+mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo   t f+mapCompFlaggedDep _ (Stanza  sn     t  ) = Stanza  sn       t+mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)++{-------------------------------------------------------------------------------+  Reverse dependency map+-------------------------------------------------------------------------------}++-- | A map containing reverse dependencies between qualified+-- package names.+type RevDepMap = Map QPN [(Component, QPN)]++{-------------------------------------------------------------------------------+  Goals+-------------------------------------------------------------------------------}++-- | A goal is just a solver variable paired with a reason.+-- The reason is only used for tracing.+data Goal qpn = Goal (Var qpn) (GoalReason qpn)+  deriving (Eq, Show, Functor)++-- | Reason why a goal is being added to a goal set.+data GoalReason qpn =+    UserGoal+  | PDependency (PI qpn)+  | FDependency (FN qpn) Bool+  | SDependency (SN qpn)+  deriving (Eq, Show, Functor)++type QGoalReason = GoalReason QPN++class ResetVar f where+  resetVar :: Var qpn -> f qpn -> f qpn++instance ResetVar CI where+  resetVar v (Fixed i _)       = Fixed i v+  resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs)++instance ResetVar Dep where+  resetVar v (Dep is_exe qpn ci) = Dep is_exe qpn (resetVar v ci)+  resetVar _ (Ext ext)    = Ext ext+  resetVar _ (Lang lang)  = Lang lang+  resetVar _ (Pkg pn vr)  = Pkg pn vr++instance ResetVar Var where+  resetVar = const++goalToVar :: Goal a -> Var a+goalToVar (Goal v _) = v++-- | Compute a singleton conflict set from a goal, containing just+-- the goal variable.+--+-- NOTE: This is just a call to 'varToConflictSet' under the hood;+-- the 'GoalReason' is ignored.+goalVarToConflictSet :: Goal qpn -> ConflictSet qpn+goalVarToConflictSet (Goal g _gr) = varToConflictSet g++-- | Compute a singleton conflict set from a 'Var'+varToConflictSet :: Var qpn -> ConflictSet qpn+varToConflictSet = CS.singleton++-- | A goal reason is mostly just a variable paired with the+-- decision we made for that variable (except for user goals,+-- where we cannot really point to a solver variable). This+-- function drops the decision and recovers the list of+-- variables (which will be empty or contain one element).+--+goalReasonToVars :: GoalReason qpn -> [Var qpn]+goalReasonToVars UserGoal                 = []+goalReasonToVars (PDependency (PI qpn _)) = [P qpn]+goalReasonToVars (FDependency qfn _)      = [F qfn]+goalReasonToVars (SDependency qsn)        = [S qsn]++{-------------------------------------------------------------------------------+  Open goals+-------------------------------------------------------------------------------}++-- | For open goals as they occur during the build phase, we need to store+-- additional information about flags.+data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason+  deriving (Eq, Show)++-- | Closes a goal, i.e., removes all the extraneous information that we+-- need only during the build phase.+close :: OpenGoal comp -> Goal QPN+close (OpenGoal (Simple (Dep _ qpn _) _) gr) = Goal (P qpn) gr+close (OpenGoal (Simple (Ext     _) _) _ ) =+  error "Distribution.Solver.Modular.Dependency.close: called on Ext goal"+close (OpenGoal (Simple (Lang    _) _) _ ) =+  error "Distribution.Solver.Modular.Dependency.close: called on Lang goal"+close (OpenGoal (Simple (Pkg   _ _) _) _ ) =+  error "Distribution.Solver.Modular.Dependency.close: called on Pkg goal"+close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr+close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr++{-------------------------------------------------------------------------------+  Version ranges paired with origins+-------------------------------------------------------------------------------}++type VROrigin qpn = (VR, Var qpn)++-- | Helper function to collapse a list of version ranges with origins into+-- a single, simplified, version range.+collapse :: [VROrigin qpn] -> VR+collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR
+ cabal/cabal-install/Distribution/Solver/Modular/Explore.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.Explore+    ( backjump+    , backjumpAndExplore+    ) where++import Data.Foldable as F+import Data.List as L (foldl')+import Data.Map as M++import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Log+import Distribution.Solver.Modular.Message+import qualified Distribution.Solver.Modular.PSQ as P+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Modular.RetryLog+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.WeightedPSQ as W+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..))++-- | This function takes the variable we're currently considering, an+-- initial conflict set and a+-- list of children's logs. Each log yields either a solution or a+-- conflict set. The result is a combined log for the parent node that+-- has explored a prefix of the children.+--+-- We can stop traversing the children's logs if we find an individual+-- conflict set that does not contain the current variable. In this+-- case, we can just lift the conflict set to the current level,+-- because the current level cannot possibly have contributed to this+-- conflict, so no other choice at the current level would avoid the+-- conflict.+--+-- If any of the children might contain a successful solution, we can+-- return it immediately. If all children contain conflict sets, we can+-- take the union as the combined conflict set.+--+-- The initial conflict set corresponds to the justification that we+-- have to choose this goal at all. There is a reason why we have+-- introduced the goal in the first place, and this reason is in conflict+-- with the (virtual) option not to choose anything for the current+-- variable. See also the comments for 'avoidSet'.+--+backjump :: EnableBackjumping -> Var QPN+         -> ConflictSet QPN -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a)+         -> ConflictMap -> ConflictSetLog a+backjump (EnableBackjumping enableBj) var initial xs =+    F.foldr combine logBackjump xs initial+  where+    combine :: forall a . (ConflictMap -> ConflictSetLog a)+            -> (ConflictSet QPN -> ConflictMap -> ConflictSetLog a)+            ->  ConflictSet QPN -> ConflictMap -> ConflictSetLog a+    combine x f csAcc cm = retry (x cm) next+      where+        next :: (ConflictSet QPN, ConflictMap) -> ConflictSetLog a+        next (cs, cm')+          | enableBj && not (var `CS.member` cs) = logBackjump cs cm'+          | otherwise                            = f (csAcc `CS.union` cs) cm'++    logBackjump :: ConflictSet QPN -> ConflictMap -> ConflictSetLog a+    logBackjump cs cm = failWith (Failure cs Backjump) (cs, updateCM initial cm)+                                   -- 'intial' instead of 'cs' here ---^+                                   -- since we do not want to double-count the+                                   -- additionally accumulated conflicts.++type ConflictSetLog = RetryLog Message (ConflictSet QPN, ConflictMap)++type ConflictMap = Map (Var QPN) Int++getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)+getBestGoal cm =+  P.maximumBy+    ( flip (M.findWithDefault 0) cm+    . (\ (Goal v _) -> v)+    )++getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a)+getFirstGoal ts =+  P.casePSQ ts+    (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error+    (\ k v _xs -> (k, v))  -- commit to the first goal choice++updateCM :: ConflictSet QPN -> ConflictMap -> ConflictMap+updateCM cs cm =+  L.foldl' (\ cmc k -> M.alter inc k cmc) cm (CS.toList cs)+  where+    inc Nothing  = Just 1+    inc (Just n) = Just $! n + 1++-- | Record complete assignments on 'Done' nodes.+assign :: Tree d c -> Tree Assignment c+assign tree = cata go tree $ A M.empty M.empty M.empty+  where+    go :: TreeF d c (Assignment -> Tree Assignment c)+                 -> (Assignment -> Tree Assignment c)+    go (FailF c fr)            _            = Fail c fr+    go (DoneF rdm _)           a            = Done rdm a+    go (PChoiceF qpn y     ts) (A pa fa sa) = PChoice qpn y     $ W.mapWithKey f ts+        where f (POption k _) r = r (A (M.insert qpn k pa) fa sa)+    go (FChoiceF qfn y t m ts) (A pa fa sa) = FChoice qfn y t m $ W.mapWithKey f ts+        where f k             r = r (A pa (M.insert qfn k fa) sa)+    go (SChoiceF qsn y t   ts) (A pa fa sa) = SChoice qsn y t   $ W.mapWithKey f ts+        where f k             r = r (A pa fa (M.insert qsn k sa))+    go (GoalChoiceF        ts) a            = GoalChoice $ fmap ($ a) ts++-- | A tree traversal that simultaneously propagates conflict sets up+-- the tree from the leaves and creates a log.+exploreLog :: EnableBackjumping -> CountConflicts -> Tree Assignment QGoalReason+           -> ConflictSetLog (Assignment, RevDepMap)+exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty+  where+    getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a)+    getBestGoal'+      | countConflicts = \ ts cm -> getBestGoal cm ts+      | otherwise      = \ ts _  -> getFirstGoal ts++    go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))+                                    -> (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))+    go (FailF c fr)                          = \ cm -> let failure = failWith (Failure c fr)+                                                       in if countConflicts+                                                          then failure (c, updateCM c cm)+                                                          else failure (c, cm)+    go (DoneF rdm a)                         = \ _  -> succeedWith Success (a, rdm)+    go (PChoiceF qpn gr     ts)              =+      backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,+        W.mapWithKey                                -- when descending ...+          (\ k r cm -> tryWith (TryP qpn k) (r cm))+          ts+    go (FChoiceF qfn gr _ _ ts)              =+      backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,+        W.mapWithKey                                -- when descending ...+          (\ k r cm -> tryWith (TryF qfn k) (r cm))+          ts+    go (SChoiceF qsn gr _   ts)              =+      backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,+        W.mapWithKey                                -- when descending ...+          (\ k r cm -> tryWith (TryS qsn k) (r cm))+          ts+    go (GoalChoiceF         ts)              = \ cm ->+      let (k, v) = getBestGoal' ts cm+      in continueWith (Next k) (v cm)++-- | Build a conflict set corresponding to the (virtual) option not to+-- choose a solution for a goal at all.+--+-- In the solver, the set of goals is not statically determined, but depends+-- on the choices we make. Therefore, when dealing with conflict sets, we+-- always have to consider that we could perhaps make choices that would+-- avoid the existence of the goal completely.+--+-- Whenever we actual introduce a choice in the tree, we have already established+-- that the goal cannot be avoided. This is tracked in the "goal reason".+-- The choice to avoid the goal therefore is a conflict between the goal itself+-- and its goal reason. We build this set here, and pass it to the 'backjump'+-- function as the initial conflict set.+--+-- This has two effects:+--+-- - In a situation where there are no choices available at all (this happens+-- if an unknown package is requested), the initial conflict set becomes the+-- actual conflict set.+--+-- - In a situation where all of the children's conflict sets contain the+-- current variable, the goal reason of the current node will be added to the+-- conflict set.+--+avoidSet :: Var QPN -> QGoalReason -> ConflictSet QPN+avoidSet var gr =+  CS.fromList (var : goalReasonToVars gr)++-- | Interface.+backjumpAndExplore :: EnableBackjumping+                   -> CountConflicts+                   -> Tree d QGoalReason -> Log Message (Assignment, RevDepMap)+backjumpAndExplore enableBj countConflicts =+    toLog . exploreLog enableBj countConflicts . assign+  where+    toLog :: RetryLog step fail done -> Log step done+    toLog = toProgress . mapFailure (const ())
+ cabal/cabal-install/Distribution/Solver/Modular/Flag.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Flag+    ( FInfo(..)+    , Flag+    , FlagInfo+    , FN(..)+    , QFN+    , QSN+    , SN(..)+    , WeakOrTrivial(..)+    , mkFlag+    , showFBool+    , showQFN+    , showQFNBool+    , showQSN+    , showQSNBool+    ) where++import Data.Map as M+import Prelude hiding (pi)++import Distribution.PackageDescription hiding (Flag) -- from Cabal++import Distribution.Solver.Modular.Package+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath++-- | Flag name. Consists of a package instance and the flag identifier itself.+data FN qpn = FN (PI qpn) Flag+  deriving (Eq, Ord, Show, Functor)++-- | Flag identifier. Just a string.+type Flag = FlagName++unFlag :: Flag -> String+unFlag = unFlagName++mkFlag :: String -> Flag+mkFlag = mkFlagName++-- | Flag info. Default value, whether the flag is manual, and+-- whether the flag is weak. Manual flags can only be set explicitly.+-- Weak flags are typically deferred by the solver.+data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: WeakOrTrivial }+  deriving (Eq, Ord, Show)++-- | Flag defaults.+type FlagInfo = Map Flag FInfo++-- | Qualified flag name.+type QFN = FN QPN++-- | Stanza name. Paired with a package name, much like a flag.+data SN qpn = SN (PI qpn) OptionalStanza+  deriving (Eq, Ord, Show, Functor)++-- | Qualified stanza name.+type QSN = SN QPN++-- | A property of flag and stanza choices that determines whether the+-- choice should be deferred in the solving process.+--+-- A choice is called weak if we do want to defer it. This is the+-- case for flags that should be implied by what's currently installed on+-- the system, as opposed to flags that are used to explicitly enable or+-- disable some functionality.+--+-- A choice is called trivial if it clearly does not matter. The+-- special case of triviality we actually consider is if there are no new+-- dependencies introduced by the choice.+newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }+  deriving (Eq, Ord, Show)++unStanza :: OptionalStanza -> String+unStanza TestStanzas  = "test"+unStanza BenchStanzas = "bench"++showQFNBool :: QFN -> Bool -> String+showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b++showQSNBool :: QSN -> Bool -> String+showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b++showFBool :: FN qpn -> Bool -> String+showFBool (FN _ f) True  = "+" ++ unFlag f+showFBool (FN _ f) False = "-" ++ unFlag f++showSBool :: SN qpn -> Bool -> String+showSBool (SN _ s) True  = "*" ++ unStanza s+showSBool (SN _ s) False = "!" ++ unStanza s++showQFN :: QFN -> String+showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f++showQSN :: QSN -> String+showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f
+ cabal/cabal-install/Distribution/Solver/Modular/Index.hs view
@@ -0,0 +1,52 @@+module Distribution.Solver.Modular.Index+    ( Index+    , PInfo(..)+    , defaultQualifyOptions+    , mkIndex+    ) where++import Data.List as L+import Data.Map as M+import Prelude hiding (pi)++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree++import Distribution.Solver.Types.ComponentDeps (Component)++-- | An index contains information about package instances. This is a nested+-- dictionary. Package names are mapped to instances, which in turn is mapped+-- to info.+type Index = Map PN (Map I PInfo)++-- | Info associated with a package instance.+-- Currently, dependencies, flags and failure reasons.+-- Packages that have a failure reason recorded for them are disabled+-- globally, for reasons external to the solver. We currently use this+-- for shadowing which essentially is a GHC limitation, and for+-- installed packages that are broken.+data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason)+  deriving (Show)++mkIndex :: [(PN, I, PInfo)] -> Index+mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))++groupMap :: Ord a => [(a, b)] -> Map a [b]+groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)++defaultQualifyOptions :: Index -> QualifyOptions+defaultQualifyOptions idx = QO {+      qoBaseShim         = or [ dep == base+                              | -- Find all versions of base ..+                                Just is <- [M.lookup base idx]+                                -- .. which are installed ..+                              , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is+                                -- .. and flatten all their dependencies ..+                              , (Dep _is_exe dep _ci, _comp) <- flattenFlaggedDeps deps+                              ]+    , qoSetupIndependent = True+    }+  where+    base = mkPackageName "base"
+ cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs view
@@ -0,0 +1,318 @@+module Distribution.Solver.Modular.IndexConversion+    ( convPIs+    ) where++import Data.List as L+import Data.Map as M+import Data.Maybe+import Data.Monoid as Mon+import Data.Set as S+import Prelude hiding (pi)++import Distribution.Compiler+import Distribution.InstalledPackageInfo as IPI+import Distribution.Package                          -- from Cabal+import Distribution.PackageDescription as PD         -- from Cabal+import Distribution.PackageDescription.Configuration as PDC+import qualified Distribution.Simple.PackageIndex as SI+import Distribution.System+import Distribution.Types.ForeignLib++import           Distribution.Solver.Types.ComponentDeps (Component(..))+import           Distribution.Solver.Types.OptionalStanza+import qualified Distribution.Solver.Types.PackageIndex as CI+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SourcePackage++import Distribution.Solver.Modular.Dependency as D+import Distribution.Solver.Modular.Flag as F+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version++-- | Convert both the installed package index and the source package+-- index into one uniform solver index.+--+-- We use 'allPackagesBySourcePackageId' for the installed package index+-- because that returns us several instances of the same package and version+-- in order of preference. This allows us in principle to \"shadow\"+-- packages if there are several installed packages of the same version.+-- There are currently some shortcomings in both GHC and Cabal in+-- resolving these situations. However, the right thing to do is to+-- fix the problem there, so for now, shadowing is only activated if+-- explicitly requested.+convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables ->+           SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index+convPIs os arch comp sip strfl sexes iidx sidx =+  mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sexes sidx)++-- | Convert a Cabal installed package index to the simpler,+-- more uniform index format of the solver.+convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]+convIPI' (ShadowPkgs sip) idx =+    -- apply shadowing whenever there are multiple installed packages with+    -- the same version+    [ maybeShadow (convIP idx pkg)+    | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx+    , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]+  where++    -- shadowing is recorded in the package info+    shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))+    shadow x                                = x++-- | Convert a single installed package into the solver-specific format.+convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)+convIP idx ipi =+  case mapM (convIPId pn idx) (IPI.depends ipi) of+        Nothing  -> (pn, i, PInfo []            M.empty (Just Broken))+        Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing)+ where+  -- We assume that all dependencies of installed packages are _library_ deps+  ipid = IPI.installedUnitId ipi+  i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)+  pn = pkgName (sourcePackageId ipi)+  setComp = setCompFlaggedDeps ComponentLib+-- TODO: Installed packages should also store their encapsulations!++-- | Convert dependencies specified by an installed package id into+-- flagged dependencies of the solver.+--+-- May return Nothing if the package can't be found in the index. That+-- indicates that the original package having this dependency is broken+-- and should be ignored.+convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN)+convIPId pn' idx ipid =+  case SI.lookupUnitId idx ipid of+    Nothing  -> Nothing+    Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)+                    pn = pkgName (sourcePackageId ipi)+                in  Just (D.Simple (Dep False pn (Fixed i (P pn'))) ())+                -- NB: something we pick up from the+                -- InstalledPackageIndex is NEVER an executable++-- | Convert a cabal-install source package index to the simpler,+-- more uniform index format of the solver.+convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables ->+            CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]+convSPI' os arch cinfo strfl sexes = L.map (convSP os arch cinfo strfl sexes) . CI.allPackages++-- | Convert a single source package into the solver-specific format.+convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)+convSP os arch cinfo strfl sexes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =+  let i = I pv InRepo+  in  (pn, i, convGPD os arch cinfo strfl sexes (PI pn i) gpd)++-- We do not use 'flattenPackageDescription' or 'finalizePD'+-- from 'Distribution.PackageDescription.Configuration' here, because we+-- want to keep the condition tree, but simplify much of the test.++-- | Convert a generic package description to a solver-specific 'PInfo'.+convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables ->+           PI PN -> GenericPackageDescription -> PInfo+convGPD os arch cinfo strfl sexes pi+        (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) =+  let+    fds  = flagInfo strfl flags++    -- | We have to be careful to filter out dependencies on+    -- internal libraries, since they don't refer to real packages+    -- and thus cannot actually be solved over.  We'll do this+    -- by creating a set of package names which are "internal"+    -- and dropping them as we convert.++    ipns = S.fromList $ [ unqualComponentNameToPackageName nm+                        | (nm, _) <- sub_libs ]++    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) ->+            CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN+    conv comp getInfo = convCondTree os arch cinfo pi fds comp getInfo ipns sexes .+                        PDC.addBuildableCondition getInfo++    flagged_deps+        = concatMap (\ds -> conv ComponentLib libBuildInfo ds) (maybeToList mlib)+       ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm)   libBuildInfo       ds) sub_libs+       ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm)  foreignLibBuildInfo ds) flibs+       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)   buildInfo          ds) exes+       ++ prefix (Stanza (SN pi TestStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentTest nm)  testBuildInfo      ds) tests)+       ++ prefix (Stanza (SN pi BenchStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs)+       ++ maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)++  in+    PInfo flagged_deps fds Nothing++-- | Create a flagged dependency tree from a list @fds@ of flagged+-- dependencies, using @f@ to form the tree node (@f@ will be+-- something like @Stanza sn@).+prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn)+       -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn+prefix _ []  = []+prefix f fds = [f (concat fds)]++-- | Convert flag information. Automatic flags are now considered weak+-- unless strong flags have been selected explicitly.+flagInfo :: StrongFlags -> [PD.Flag] -> FlagInfo+flagInfo (StrongFlags strfl) =+    M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (weak m)))+  where+    weak m = WeakOrTrivial $ not (strfl || m)++-- | Internal package names, which should not be interpreted as true+-- dependencies.+type IPNs = Set PN++-- | Convenience function to delete a 'FlaggedDep' if it's+-- for a 'PN' that isn't actually real.+filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN+filterIPNs ipns (Dependency pn _) fd+    | S.notMember pn ipns = [fd]+    | otherwise           = []++-- | Convert condition trees to flagged dependencies.  Mutually+-- recursive with 'convBranch'.  See 'convBranch' for an explanation+-- of all arguments preceeding the input 'CondTree'.+convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->+                Component ->+                (a -> BuildInfo) ->+                IPNs ->+                SolveExecutables ->+                CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN+convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes@(SolveExecutables sexes') (CondNode info ds branches) =+                 concatMap+                    (\d -> filterIPNs ipns d (D.Simple (convLibDep pn d) comp))+                    ds  -- unconditional package dependencies+              ++ L.map (\e -> D.Simple (Ext  e) comp) (PD.allExtensions bi) -- unconditional extension dependencies+              ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages  bi) -- unconditional language dependencies+              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies+              ++ concatMap (convBranch os arch cinfo pi fds comp getInfo ipns sexes) branches+              -- build-tools dependencies+              -- NB: Only include these dependencies if SolveExecutables+              -- is True.  It might be false in the legacy solver+              -- codepath, in which case there won't be any record of+              -- an executable we need.+              ++ [ D.Simple (convExeDep pn (Dependency pn' vr)) comp+                 | sexes'+                 , LegacyExeDependency exe vr <- PD.buildTools bi+                 , Just pn' <- return $ packageProvidingBuildTool exe+                 ]+  where+    bi = getInfo info++-- | This function maps known @build-tools@ entries to Haskell package+-- names which provide them.  This mapping corresponds exactly to+-- those build-tools that Cabal understands by default+-- ('builtinPrograms'), and are cabal install'able.  This mapping is+-- purely for legacy; for other executables, @tool-depends@ should be+-- used instead.+--+packageProvidingBuildTool :: String -> Maybe PackageName+packageProvidingBuildTool s =+    if s `elem` ["hscolour", "haddock", "happy", "alex", "hsc2hs",+                 "c2hs", "cpphs", "greencard"]+        then Just (mkPackageName s)+        else Nothing++-- | Branch interpreter.  Mutually recursive with 'convCondTree'.+--+-- Here, we try to simplify one of Cabal's condition tree branches into the+-- solver's flagged dependency format, which is weaker. Condition trees can+-- contain complex logical expression composed from flag choices and special+-- flags (such as architecture, or compiler flavour). We try to evaluate the+-- special flags and subsequently simplify to a tree that only depends on+-- simple flag choices.+--+-- This function takes a number of arguments:+--+--      1. Some pre dependency-solving known information ('OS', 'Arch',+--         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,+--+--      2. The package instance @'PI' 'PN'@ which this condition tree+--         came from, so that we can correctly associate @flag()@+--         variables with the correct package name qualifier,+--+--      3. The flag defaults 'FlagInfo' so that we can populate+--         'Flagged' dependencies with 'FInfo',+--+--      4. The name of the component 'Component' so we can record where+--         the fine-grained information about where the component came+--         from (see 'convCondTree'), and+--+--      5. A selector to extract the 'BuildInfo' from the leaves of+--         the 'CondTree' (which actually contains the needed+--         dependency information.)+--+--      6. The set of package names which should be considered internal+--         dependencies, and thus not handled as dependencies.+convBranch :: OS -> Arch -> CompilerInfo ->+              PI PN -> FlagInfo ->+              Component ->+              (a -> BuildInfo) ->+              IPNs ->+              SolveExecutables ->+              (Condition ConfVar,+               CondTree ConfVar [Dependency] a,+               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN+convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (c', t', mf') =+  go c' (          convCondTree os arch cinfo pi fds comp getInfo ipns sexes  t')+        (maybe [] (convCondTree os arch cinfo pi fds comp getInfo ipns sexes) mf')+  where+    go :: Condition ConfVar ->+          FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN+    go (Lit True)  t _ = t+    go (Lit False) _ f = f+    go (CNot c)    t f = go c f t+    go (CAnd c d)  t f = go c (go d t f) f+    go (COr  c d)  t f = go c t (go d t f)+    go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f]+    go (Var (OS os')) t f+      | os == os'      = t+      | otherwise      = f+    go (Var (Arch arch')) t f+      | arch == arch'  = t+      | otherwise      = f+    go (Var (Impl cf cvr)) t f+      | matchImpl (compilerInfoId cinfo) ||+            -- fixme: Nothing should be treated as unknown, rather than empty+            --        list. This code should eventually be changed to either+            --        support partial resolution of compiler flags or to+            --        complain about incompletely configured compilers.+        any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t+      | otherwise      = f+      where+        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv++    -- If both branches contain the same package as a simple dep, we lift it to+    -- the next higher-level, but without constraints. This heuristic together+    -- with deferring flag choices will then usually first resolve this package,+    -- and try an already installed version before imposing a default flag choice+    -- that might not be what we want.+    --+    -- Note that we make assumptions here on the form of the dependencies that+    -- can occur at this point. In particular, no occurrences of Fixed, and no+    -- occurrences of multiple version ranges, as all dependencies below this+    -- point have been generated using 'convLibDep'.+    --+    -- WARNING: This is quadratic!+    extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN+    extractCommon ps ps' = [ D.Simple (Dep is_exe1 pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp+                           | D.Simple (Dep is_exe1 pn1 (Constrained [(vr1, _)])) _ <- ps+                           , D.Simple (Dep is_exe2 pn2 (Constrained [(vr2, _)])) _ <- ps'+                           , pn1 == pn2+                           , is_exe1 == is_exe2+                           ]++-- | Convert a Cabal dependency on a library to a solver-specific dependency.+convLibDep :: PN -> Dependency -> Dep PN+convLibDep pn' (Dependency pn vr) = Dep False {- not exe -} pn (Constrained [(vr, P pn')])++-- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency.+convExeDep :: PN -> Dependency -> Dep PN+convExeDep pn' (Dependency pn vr) = Dep True pn (Constrained [(vr, P pn')])++-- | Convert setup dependencies+convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN+convSetupBuildInfo (PI pn _i) nfo =+    L.map (\d -> D.Simple (convLibDep pn d) ComponentSetup) (PD.setupDepends nfo)
+ cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs view
@@ -0,0 +1,116 @@+-- | Wrapper around Data.Graph with support for edge labels+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.LabeledGraph (+    -- * Graphs+    Graph+  , Vertex+    -- ** Building graphs+  , graphFromEdges+  , graphFromEdges'+  , buildG+  , transposeG+    -- ** Graph properties+  , vertices+  , edges+    -- ** Operations on the underlying unlabeled graph+  , forgetLabels+  , topSort+  ) where++import Data.Array+import Data.Graph (Vertex, Bounds)+import Data.List (sortBy)+import Data.Maybe (mapMaybe)+import qualified Data.Graph as G++{-------------------------------------------------------------------------------+  Types+-------------------------------------------------------------------------------}++type Graph e = Array Vertex [(e, Vertex)]+type Edge  e = (Vertex, e, Vertex)++{-------------------------------------------------------------------------------+  Building graphs+-------------------------------------------------------------------------------}++-- | Construct an edge-labeled graph+--+-- This is a simple adaptation of the definition in Data.Graph+graphFromEdges :: forall key node edge. Ord key+               => [ (node, key, [(edge, key)]) ]+               -> ( Graph edge+                  , Vertex -> (node, key, [(edge, key)])+                  , key -> Maybe Vertex+                  )+graphFromEdges edges0 =+    (graph, \v -> vertex_map ! v, key_vertex)+  where+    max_v        = length edges0 - 1+    bounds0      = (0, max_v) :: (Vertex, Vertex)+    sorted_edges = sortBy lt edges0+    edges1       = zipWith (,) [0..] sorted_edges++    graph        = array bounds0 [(v, (mapMaybe mk_edge ks))+                                 | (v, (_, _, ks)) <- edges1]+    key_map      = array bounds0 [(v, k                    )+                                 | (v, (_, k, _ )) <- edges1]+    vertex_map   = array bounds0 edges1++    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2++    mk_edge :: (edge, key) -> Maybe (edge, Vertex)+    mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)++    --  returns Nothing for non-interesting vertices+    key_vertex :: key -> Maybe Vertex+    key_vertex k = findVertex 0 max_v+      where+        findVertex a b+          | a > b     = Nothing+          | otherwise = case compare k (key_map ! mid) of+              LT -> findVertex a (mid-1)+              EQ -> Just mid+              GT -> findVertex (mid+1) b+          where+            mid = a + (b - a) `div` 2++graphFromEdges' :: Ord key+                => [ (node, key, [(edge, key)]) ]+                -> ( Graph edge+                   , Vertex -> (node, key, [(edge, key)])+                   )+graphFromEdges' x = (a,b)+  where+    (a,b,_) = graphFromEdges x++transposeG :: Graph e -> Graph e+transposeG g = buildG (bounds g) (reverseE g)++buildG :: Bounds -> [Edge e] -> Graph e+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)+  where+    reassoc (v, e, w) = (v, (e, w))++reverseE :: Graph e -> [Edge e]+reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]++{-------------------------------------------------------------------------------+  Graph properties+-------------------------------------------------------------------------------}++vertices :: Graph e -> [Vertex]+vertices = indices++edges :: Graph e -> [Edge e]+edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]++{-------------------------------------------------------------------------------+  Operations on the underlying unlabelled graph+-------------------------------------------------------------------------------}++forgetLabels :: Graph e -> G.Graph+forgetLabels = fmap (map snd)++topSort :: Graph e -> [Vertex]+topSort = G.topSort . forgetLabels
+ cabal/cabal-install/Distribution/Solver/Modular/Linking.hs view
@@ -0,0 +1,578 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.Linking (+    addLinking+  , validateLinking+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get,put)++import Control.Exception (assert)+import Control.Monad.Reader+import Control.Monad.State+import Data.Map ((!))+import Data.Set (Set)+import qualified Data.Map         as M+import qualified Data.Set         as S+import qualified Data.Traversable as T++import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.ConflictSet as CS+import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.ComponentDeps (Component)++{-------------------------------------------------------------------------------+  Add linking+-------------------------------------------------------------------------------}++type RelatedGoals = Map (PN, I) [PackagePath]+type Linker       = Reader RelatedGoals++-- | Introduce link nodes into the tree+--+-- Linking is a traversal of the solver tree that adapts package choice nodes+-- and adds the option to link wherever appropriate: Package goals are called+-- "related" if they are for the same instance of the same package (but have+-- different prefixes). A link option is available in a package choice node+-- whenever we can choose an instance that has already been chosen for a related+-- goal at a higher position in the tree. We only create link options for+-- related goals that are not themselves linked, because the choice to link to a+-- linked goal is the same as the choice to link to the target of that goal's+-- linking.+--+-- The code here proceeds by maintaining a finite map recording choices that+-- have been made at higher positions in the tree. For each pair of package name+-- and instance, it stores the prefixes at which we have made a choice for this+-- package instance. Whenever we make an unlinked choice, we extend the map.+-- Whenever we find a choice, we look into the map in order to find out what+-- link options we have to add.+addLinking :: Tree d c -> Tree d c+addLinking = (`runReader` M.empty) .  cata go+  where+    go :: TreeF d c (Linker (Tree d c)) -> Linker (Tree d c)++    -- The only nodes of interest are package nodes+    go (PChoiceF qpn gr cs) = do+      env <- ask+      let linkedCs = W.fromList $ concatMap (linkChoices env qpn) (W.toList cs)+          unlinkedCs = W.mapWithKey (goP qpn) cs+      allCs <- T.sequence $ unlinkedCs `W.union` linkedCs+      return $ PChoice qpn gr allCs+    go _otherwise =+      innM _otherwise++    -- Recurse underneath package choices. Here we just need to make sure+    -- that we record the package choice so that it is available below+    goP :: QPN -> POption -> Linker (Tree d c) -> Linker (Tree d c)+    goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])+    goP _ _ = alreadyLinked++linkChoices :: forall a w . RelatedGoals+            -> QPN+            -> (w, POption, a)+            -> [(w, POption, a)]+linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =+    map aux (M.findWithDefault [] (pn, i) related)+  where+    aux :: PackagePath -> (w, POption, a)+    aux pp = (weight, POption i (Just pp), subtree)+linkChoices _ _ (_, POption _ (Just _), _) =+    alreadyLinked++alreadyLinked :: a+alreadyLinked = error "addLinking called on tree that already contains linked nodes"++{-------------------------------------------------------------------------------+  Validation++  Validation of links is a separate pass that's performed after normal+  validation. Validation of links checks that if the tree indicates that a+  package is linked, then everything underneath that choice really matches the+  package we have linked to.++  This is interesting because it isn't unidirectional. Consider that we've+  chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.+  Now foo depends on bar. Because a.foo and b.foo are linked, it's required that+  a.bar and b.bar are also linked. However, it's not required that we actually+  choose a.bar before b.bar. Goal choice order is relatively free. It's possible+  that we choose a.bar first, but also possible that we choose b.bar first. In+  both cases, we have to recognize that we have freedom of choice for the first+  of the two, but no freedom of choice for the second.++  This is what LinkGroups are all about. Using LinkGroup, we can record (in the+  situation above) that a.bar and b.bar need to be linked even if we haven't+  chosen either of them yet.+-------------------------------------------------------------------------------}++data ValidateState = VS {+      vsIndex    :: Index+    , vsLinks    :: Map QPN LinkGroup+    , vsFlags    :: FAssignment+    , vsStanzas  :: SAssignment+    , vsQualifyOptions :: QualifyOptions+    }+    deriving Show++type Validate = Reader ValidateState++-- | Validate linked packages+--+-- Verify that linked packages have+--+-- * Linked dependencies,+-- * Equal flag assignments+-- * Equal stanza assignments+validateLinking :: Index -> Tree d c -> Tree d c+validateLinking index = (`runReader` initVS) . cata go+  where+    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)++    go (PChoiceF qpn gr cs) =+      PChoice qpn gr     <$> T.sequence (W.mapWithKey (goP qpn) cs)+    go (FChoiceF qfn gr t m cs) =+      FChoice qfn gr t m <$> T.sequence (W.mapWithKey (goF qfn) cs)+    go (SChoiceF qsn gr t cs) =+      SChoice qsn gr t   <$> T.sequence (W.mapWithKey (goS qsn) cs)++    -- For the other nodes we just recurse+    go (GoalChoiceF         cs)       = GoalChoice          <$> T.sequence cs+    go (DoneF revDepMap s)            = return $ Done revDepMap s+    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason++    -- Package choices+    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)+    goP qpn@(Q _pp pn) opt@(POption i _) r = do+      vs <- ask+      let PInfo deps _ _ = vsIndex vs ! pn ! i+          qdeps          = qualifyDeps (vsQualifyOptions vs) qpn deps+      case execUpdateState (pickPOption qpn opt qdeps) vs of+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)+        Right vs'       -> local (const vs') r++    -- Flag choices+    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goF qfn b r = do+      vs <- ask+      case execUpdateState (pickFlag qfn b) vs of+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)+        Right vs'       -> local (const vs') r++    -- Stanza choices (much the same as flag choices)+    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goS qsn b r = do+      vs <- ask+      case execUpdateState (pickStanza qsn b) vs of+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)+        Right vs'       -> local (const vs') r++    initVS :: ValidateState+    initVS = VS {+        vsIndex   = index+      , vsLinks   = M.empty+      , vsFlags   = M.empty+      , vsStanzas = M.empty+      , vsQualifyOptions = defaultQualifyOptions index+      }++{-------------------------------------------------------------------------------+  Updating the validation state+-------------------------------------------------------------------------------}++type Conflict = (ConflictSet QPN, String)++newtype UpdateState a = UpdateState {+    unUpdateState :: StateT ValidateState (Either Conflict) a+  }+  deriving (Functor, Applicative, Monad)++instance MonadState ValidateState UpdateState where+  get    = UpdateState $ get+  put st = UpdateState $ do+             assert (lgInvariant $ vsLinks st) $ return ()+             put st++lift' :: Either Conflict a -> UpdateState a+lift' = UpdateState . lift++conflict :: Conflict -> UpdateState a+conflict = lift' . Left++execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState+execUpdateState = execStateT . unUpdateState++pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState ()+pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i+pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps++pickConcrete :: QPN -> I -> UpdateState ()+pickConcrete qpn@(Q pp _) i = do+    vs <- get+    case M.lookup qpn (vsLinks vs) of+      -- Package is not yet in a LinkGroup. Create a new singleton link group.+      Nothing -> do+        let lg = lgSingleton qpn (Just $ PI pp i)+        updateLinkGroup lg++      -- Package is already in a link group. Since we are picking a concrete+      -- instance here, it must by definition be the canonical package.+      Just lg ->+        makeCanonical lg qpn i++pickLink :: QPN -> I -> PackagePath -> FlaggedDeps Component QPN -> UpdateState ()+pickLink qpn@(Q _pp pn) i pp' deps = do+    vs <- get++    -- The package might already be in a link group+    -- (because one of its reverse dependencies is)+    let lgSource = case M.lookup qpn (vsLinks vs) of+                     Nothing -> lgSingleton qpn Nothing+                     Just lg -> lg++    -- Find the link group for the package we are linking to+    --+    -- Since the builder never links to a package without having first picked a+    -- concrete instance for that package, and since we create singleton link+    -- groups for concrete instances, this link group must exist (and must+    -- in fact already have a canonical member).+    let target   = Q pp' pn+        lgTarget = vsLinks vs ! target++    -- Verify here that the member we add is in fact for the same package and+    -- matches the version of the canonical instance. However, violations of+    -- these checks would indicate a bug in the linker, not a true conflict.+    let sanityCheck :: Maybe (PI PackagePath) -> Bool+        sanityCheck Nothing              = False+        sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI+    assert (sanityCheck (lgCanon lgTarget)) $ return ()++    -- Merge the two link groups (updateLinkGroup will propagate the change)+    lgTarget' <- lift' $ lgMerge [] lgSource lgTarget+    updateLinkGroup lgTarget'++    -- Make sure all dependencies are linked as well+    linkDeps target [P qpn] deps++makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()+makeCanonical lg qpn@(Q pp _) i =+    case lgCanon lg of+      -- There is already a canonical member. Fail.+      Just _ ->+        conflict ( CS.insert (P qpn) (lgConflictSet lg)+                 ,    "cannot make " ++ showQPN qpn+                   ++ " canonical member of " ++ showLinkGroup lg+                 )+      Nothing -> do+        let lg' = lg { lgCanon = Just (PI pp i) }+        updateLinkGroup lg'++-- | Link the dependencies of linked parents.+--+-- When we decide to link one package against another we walk through the+-- package's direct depedencies and make sure that they're all linked to each+-- other by merging their link groups (or creating new singleton link groups if+-- they don't have link groups yet). We do not need to do this recursively,+-- because having the direct dependencies in a link group means that we must+-- have already made or will make sooner or later a link choice for one of these+-- as well, and cover their dependencies at that point.+linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState ()+linkDeps target = \blame deps -> do+    -- linkDeps is called in two places: when we first link one package to+    -- another, and when we discover more dependencies of an already linked+    -- package after doing some flag assignment. It is therefore important that+    -- flag assignments cannot influence _how_ dependencies are qualified;+    -- fortunately this is a documented property of 'qualifyDeps'.+    rdeps <- requalify deps+    go blame deps rdeps+  where+    go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState ()+    go = zipWithM_ . go1++    go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState ()+    go1 blame dep rdep = case (dep, rdep) of+      (Simple (Dep _ qpn _) _, ~(Simple (Dep _ qpn' _) _)) -> do+        vs <- get+        let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs+            lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs+        lg'' <- lift' $ lgMerge blame lg lg'+        updateLinkGroup lg''+      (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do+        vs <- get+        case M.lookup fn (vsFlags vs) of+          Nothing    -> return () -- flag assignment not yet known+          Just True  -> go (F fn:blame) t t'+          Just False -> go (F fn:blame) f f'+      (Stanza sn t, ~(Stanza _ t')) -> do+        vs <- get+        case M.lookup sn (vsStanzas vs) of+          Nothing    -> return () -- stanza assignment not yet known+          Just True  -> go (S sn:blame) t t'+          Just False -> return () -- stanza not enabled; no new deps+    -- For extensions and language dependencies, there is nothing to do.+    -- No choice is involved, just checking, so there is nothing to link.+    -- The same goes for for pkg-config constraints.+      (Simple (Ext  _)   _, _) -> return ()+      (Simple (Lang _)   _, _) -> return ()+      (Simple (Pkg  _ _) _, _) -> return ()++    requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN)+    requalify deps = do+      vs <- get+      return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)++pickFlag :: QFN -> Bool -> UpdateState ()+pickFlag qfn b = do+    modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }+    verifyFlag qfn+    linkNewDeps (F qfn) b++pickStanza :: QSN -> Bool -> UpdateState ()+pickStanza qsn b = do+    modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }+    verifyStanza qsn+    linkNewDeps (S qsn) b++-- | Link dependencies that we discover after making a flag choice.+--+-- When we make a flag choice for a package, then new dependencies for that+-- package might become available. If the package under consideration is in a+-- non-trivial link group, then these new dependencies have to be linked as+-- well. In linkNewDeps, we compute such new dependencies and make sure they are+-- linked.+linkNewDeps :: Var QPN -> Bool -> UpdateState ()+linkNewDeps var b = do+    vs <- get+    let (qpn@(Q pp pn), Just i) = varPI var+        PInfo deps _ _          = vsIndex vs ! pn ! i+        qdeps                   = qualifyDeps (vsQualifyOptions vs) qpn deps+        lg                      = vsLinks vs ! qpn+        (parents, newDeps)      = findNewDeps vs qdeps+        linkedTo                = S.delete pp (lgMembers lg)+    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps+  where+    findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)+    findNewDeps vs = concatMapUnzip (findNewDeps' vs)++    findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)+    findNewDeps' _  (Simple _ _)        = ([], [])+    findNewDeps' vs (Flagged qfn _ t f) =+      case (F qfn == var, M.lookup qfn (vsFlags vs)) of+        (True, _)    -> ([F qfn], if b then t else f)+        (_, Nothing) -> ([], []) -- not yet known+        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f)+                        in (F qfn:parents, deps)+    findNewDeps' vs (Stanza qsn t) =+      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of+        (True, _)    -> ([S qsn], if b then t else [])+        (_, Nothing) -> ([], []) -- not yet known+        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else [])+                        in (S qsn:parents, deps)++updateLinkGroup :: LinkGroup -> UpdateState ()+updateLinkGroup lg = do+    verifyLinkGroup lg+    modify $ \vs -> vs {+        vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))+                  `M.union` vsLinks vs+      }+  where+    aux pp = (Q pp (lgPackage lg), lg)++{-------------------------------------------------------------------------------+  Verification+-------------------------------------------------------------------------------}++verifyLinkGroup :: LinkGroup -> UpdateState ()+verifyLinkGroup lg =+    case lgInstance lg of+      -- No instance picked yet. Nothing to verify+      Nothing ->+        return ()++      -- We picked an instance. Verify flags and stanzas+      -- TODO: The enumeration of OptionalStanza names is very brittle;+      -- if a constructor is added to the datatype we won't notice it here+      Just i -> do+        vs <- get+        let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i+            flags   = M.keys finfo+            stanzas = [TestStanzas, BenchStanzas]+        forM_ flags $ \fn -> do+          let flag = FN (PI (lgPackage lg) i) fn+          verifyFlag' flag lg+        forM_ stanzas $ \sn -> do+          let stanza = SN (PI (lgPackage lg) i) sn+          verifyStanza' stanza lg++verifyFlag :: QFN -> UpdateState ()+verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do+    vs <- get+    -- We can only pick a flag after picking an instance; link group must exist+    verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)++verifyStanza :: QSN -> UpdateState ()+verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do+    vs <- get+    -- We can only pick a stanza after picking an instance; link group must exist+    verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn)++-- | Verify that all packages in the link group agree on flag assignments+--+-- For the given flag and the link group, obtain all assignments for the flag+-- that have already been made for link group members, and check that they are+-- equal.+verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()+verifyFlag' (FN (PI pn i) fn) lg = do+    vs <- get+    let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg))+        vals  = map (`M.lookup` vsFlags vs) flags+    if allEqual (catMaybes vals) -- We ignore not-yet assigned flags+      then return ()+      else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg+                    , "flag " ++ show fn ++ " incompatible"+                    )++-- | Verify that all packages in the link group agree on stanza assignments+--+-- For the given stanza and the link group, obtain all assignments for the+-- stanza that have already been made for link group members, and check that+-- they are equal.+--+-- This function closely mirrors 'verifyFlag''.+verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()+verifyStanza' (SN (PI pn i) sn) lg = do+    vs <- get+    let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg))+        vals    = map (`M.lookup` vsStanzas vs) stanzas+    if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas+      then return ()+      else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg+                    , "stanza " ++ show sn ++ " incompatible"+                    )++{-------------------------------------------------------------------------------+  Link groups+-------------------------------------------------------------------------------}++-- | Set of packages that must be linked together+--+-- A LinkGroup is between several qualified package names. In the validation+-- state, we maintain a map vsLinks from qualified package names to link groups.+-- There is an invariant that for all members of a link group, vsLinks must map+-- to the same link group. The function updateLinkGroup can be used to+-- re-establish this invariant after creating or expanding a LinkGroup.+data LinkGroup = LinkGroup {+      -- | The name of the package of this link group+      lgPackage :: PN++      -- | The canonical member of this link group (the one where we picked+      -- a concrete instance). Once we have picked a canonical member, all+      -- other packages must link to this one.+      --+      -- We may not know this yet (if we are constructing link groups+      -- for dependencies)+    , lgCanon :: Maybe (PI PackagePath)++      -- | The members of the link group+    , lgMembers :: Set PackagePath++      -- | The set of variables that should be added to the conflict set if+      -- something goes wrong with this link set (in addition to the members+      -- of the link group itself)+    , lgBlame :: ConflictSet QPN+    }+    deriving (Show, Eq)++-- | Invariant for the set of link groups: every element in the link group+-- must be pointing to the /same/ link group+lgInvariant :: Map QPN LinkGroup -> Bool+lgInvariant links = all invGroup (M.elems links)+  where+    invGroup :: LinkGroup -> Bool+    invGroup lg = allEqual $ map (`M.lookup` links) members+      where+        members :: [QPN]+        members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg)++-- | Package version of this group+--+-- This is only known once we have picked a canonical element.+lgInstance :: LinkGroup -> Maybe I+lgInstance = fmap (\(PI _ i) -> i) . lgCanon++showLinkGroup :: LinkGroup -> String+showLinkGroup lg =+    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"+  where+    showMember :: PackagePath -> String+    showMember pp = case lgCanon lg of+                      Just (PI pp' _i) | pp == pp' -> "*"+                      _otherwise                   -> ""+                 ++ case lgInstance lg of+                      Nothing -> showQPN (qpn pp)+                      Just i  -> showPI (PI (qpn pp) i)++    qpn :: PackagePath -> QPN+    qpn pp = Q pp (lgPackage lg)++-- | Creates a link group that contains a single member.+lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup+lgSingleton (Q pp pn) canon = LinkGroup {+      lgPackage = pn+    , lgCanon   = canon+    , lgMembers = S.singleton pp+    , lgBlame   = CS.empty+    }++lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup+lgMerge blame lg lg' = do+    canon <- pick (lgCanon lg) (lgCanon lg')+    return LinkGroup {+        lgPackage = lgPackage lg+      , lgCanon   = canon+      , lgMembers = lgMembers lg `S.union` lgMembers lg'+      , lgBlame   = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg']+      }+  where+    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)+    pick Nothing  Nothing  = Right Nothing+    pick (Just x) Nothing  = Right $ Just x+    pick Nothing  (Just y) = Right $ Just y+    pick (Just x) (Just y) =+      if x == y then Right $ Just x+                else Left ( CS.unions [+                               CS.fromList blame+                             , lgConflictSet lg+                             , lgConflictSet lg'+                             ]+                          ,    "cannot merge " ++ showLinkGroup lg+                            ++ " and " ++ showLinkGroup lg'+                          )++lgConflictSet :: LinkGroup -> ConflictSet QPN+lgConflictSet lg =+               CS.fromList (map aux (S.toList (lgMembers lg)))+    `CS.union` lgBlame lg+  where+    aux pp = P (Q pp (lgPackage lg))++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++allEqual :: Eq a => [a] -> Bool+allEqual []       = True+allEqual [_]      = True+allEqual (x:y:ys) = x == y && allEqual (y:ys)++concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c])+concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f
+ cabal/cabal-install/Distribution/Solver/Modular/Log.hs view
@@ -0,0 +1,88 @@+module Distribution.Solver.Modular.Log+    ( Log+    , logToProgress+    ) where++import Control.Applicative+import Data.List as L+import Data.Maybe (isNothing)++import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Progress++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.Tree (FailReason(..))+import qualified Distribution.Solver.Modular.ConflictSet as CS++-- | The 'Log' datatype.+--+-- Represents the progress of a computation lazily.+--+-- Parameterized over the type of actual messages and the final result.+type Log m a = Progress m () a++messages :: Progress step fail done -> [step]+messages = foldProgress (:) (const []) (const [])++-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.+-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the+-- limit is 'Just 0', backtracking is completely disabled.+logToProgress :: Maybe Int -> Log Message a -> Progress String String a+logToProgress mbj l = let+                        es = proc (Just 0) l -- catch first error (always)+                        ms = useFirstError (proc mbj l)+                      in go es es -- trace for first error+                            (showMessages (const True) True ms) -- run with backjump limit applied+  where+    -- Proc takes the allowed number of backjumps and a 'Progress' and explores the+    -- messages until the maximum number of backjumps has been reached. It filters out+    -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates+    -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the+    -- original success result or replaces the original failure with 'Nothing'.+    proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b+    proc _        (Done x)                          = Done x+    proc _        (Fail _)                          = Fail Nothing+    proc mbj'     (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))+      | cs == cs'                                   = Step x (proc mbj'           xs) -- repeated backjumps count as one+    proc (Just 0) (Step   (Failure cs Backjump)  _) = Fail (Just cs)+    proc (Just n) (Step x@(Failure _  Backjump) xs) = Step x (proc (Just (n - 1)) xs)+    proc mbj'     (Step x                       xs) = Step x (proc mbj'           xs)++    -- Sets the conflict set from the first backjump as the final error, and records+    -- whether the search was exhaustive.+    useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b+                  -> Progress Message (Bool, Maybe (ConflictSet QPN)) b+    useFirstError = replace Nothing+      where+        replace _       (Done x)                          = Done x+        replace cs'     (Fail cs)                         = -- 'Nothing' means backjump limit not reached.+                                                            -- Prefer first error over later error.+                                                            Fail (isNothing cs, cs' <|> cs)+        replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs+        replace cs'     (Step x                       xs) = Step x $ replace cs' xs++    -- The first two arguments are both supposed to be the log up to the first error.+    -- That's the error that will always be printed in case we do not find a solution.+    -- We pass this log twice, because we evaluate it in parallel with the full log,+    -- but we also want to retain the reference to its beginning for when we print it.+    -- This trick prevents a space leak!+    --+    -- The third argument is the full log, ending with either the solution or the+    -- exhaustiveness and first conflict set.+    go :: Progress Message a b+       -> Progress Message a b+       -> Progress String (Bool, Maybe (ConflictSet QPN)) b+       -> Progress String String b+    go ms (Step _ ns) (Step x xs)           = Step x (go ms ns xs)+    go ms r           (Step x xs)           = Step x (go ms r  xs)+    go ms _           (Fail (exh, Just cs)) = Fail $+                                              "Could not resolve dependencies:\n" +++                                              unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) +++                                              (if exh then "Dependency tree exhaustively searched.\n"+                                                      else "Backjump limit reached (" ++ currlimit mbj +++                                                               "change with --max-backjumps or try to run with --reorder-goals).\n")+                                                  where currlimit (Just n) = "currently " ++ show n ++ ", "+                                                        currlimit Nothing  = ""+    go _  _           (Done s)              = Done s+    go _  _           (Fail (_, Nothing))   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
+ cabal/cabal-install/Distribution/Solver/Modular/Message.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}++module Distribution.Solver.Modular.Message (+    Message(..),+    showMessages+  ) where++import qualified Data.List as L+import Prelude hiding (pi)++import Distribution.Text -- from Cabal++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+         ( FailReason(..), POption(..) )+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Progress++data Message =+    Enter           -- ^ increase indentation level+  | Leave           -- ^ decrease indentation level+  | TryP QPN POption+  | TryF QFN Bool+  | TryS QSN Bool+  | Next (Goal QPN)+  | Success+  | Failure (ConflictSet QPN) FailReason++-- | Transforms the structured message type to actual messages (strings).+--+-- Takes an additional relevance predicate. The predicate gets a stack of goal+-- variables and can decide whether messages regarding these goals are relevant.+-- You can plug in 'const True' if you're interested in a full trace. If you+-- want a slice of the trace concerning a particular conflict set, then plug in+-- a predicate returning 'True' on the empty stack and if the head is in the+-- conflict set.+--+-- The second argument indicates if the level numbers should be shown. This is+-- recommended for any trace that involves backtracking, because only the level+-- numbers will allow to keep track of backjumps.+showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b+showMessages p sl = go [] 0+  where+    -- The stack 'v' represents variables that are currently assigned by the+    -- solver.  'go' pushes a variable for a recursive call when it encounters+    -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'.+    -- When 'go' processes a package goal, or a package goal followed by a+    -- 'Failure', it calls 'atLevel' with the goal variable at the head of the+    -- stack so that the predicate can also select messages relating to package+    -- goal choices.+    go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b+    go !_ !_ (Done x)                           = Done x+    go !_ !_ (Fail x)                           = Fail x+    -- complex patterns+    go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        goPReject v l qpn [i] c fr ms+    go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)+    go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =+        (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) =+        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms+        -- the previous case potentially arises in the error output, because we remove the backjump itself+        -- if we cut the log after the first error+    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) =+        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms+    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =+        let v' = add (P qpn) v+        in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)+    go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))+        | c == c' = go v l ms+    -- standard display+    go !v !l (Step Enter                    ms) = go v          (l+1) ms+    go !v !l (Step Leave                    ms) = go (drop 1 v) (l-1) ms+    go !v !l (Step (TryP qpn i)             ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)+    go !v !l (Step (TryF qfn b)             ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)+    go !v !l (Step (TryS qsn b)             ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)+    go !v !l (Step (Next _)                 ms) = go v l ms -- ignore flag goals in the log+    go !v !l (Step (Success)                ms) = (atLevel v l $ "done") (go v l ms)+    go !v !l (Step (Failure c fr)           ms) = (atLevel v l $ showFailure c fr) (go v l ms)++    showPackageGoal :: QPN -> QGoalReason -> String+    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr++    showFailure :: ConflictSet QPN -> FailReason -> String+    showFailure c fr = "fail" ++ showFR c fr++    add :: Var QPN -> [Var QPN] -> [Var QPN]+    add v vs = simplifyVar v : vs++    -- special handler for many subsequent package rejections+    goPReject :: [Var QPN]+              -> Int+              -> QPN+              -> [POption]+              -> ConflictSet QPN+              -> FailReason+              -> Progress Message a b+              -> Progress String a b+    goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))+      | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms+    goPReject v l qpn is c fr ms =+        (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)++    -- write a message, but only if it's relevant; we can also enable or disable the display of the current level+    atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b+    atLevel v l x xs+      | sl && p v = let s = show l+                    in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs+      | p v       = Step x xs+      | otherwise = xs++showQPNPOpt :: QPN -> POption -> String+showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =+  case linkedTo of+    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption+    Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)++showGR :: QGoalReason -> String+showGR UserGoal            = " (user goal)"+showGR (PDependency pi)    = " (dependency of " ++ showPI pi            ++ ")"+showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b    ++ ")"+showGR (SDependency qsn)   = " (dependency of " ++ showQSNBool qsn True ++ ")"++showFR :: ConflictSet QPN -> FailReason -> String+showFR _ InconsistentInitialConstraints   = " (inconsistent initial constraints)"+showFR _ (Conflicting ds)                 = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"+showFR _ CannotInstall                    = " (only already installed instances can be used)"+showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"+showFR _ Shadowed                         = " (shadowed by another installed package with same version)"+showFR _ Broken                           = " (package is broken)"+showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display vr ++ ")"+showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"+showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"+showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"+showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"+showFR c Backjump                         = " (backjumping, conflict set: " ++ showCS c ++ ")"+showFR _ MultipleInstances                = " (multiple instances)"+showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")"+showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")"+-- The following are internal failures. They should not occur. In the+-- interest of not crashing unnecessarily, we still just print an error+-- message though.+showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"+showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"+showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"++constraintSource :: ConstraintSource -> String+constraintSource src = "constraint from " ++ showConstraintSource src
+ cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Solver.Modular.PSQ+    ( PSQ(..)  -- Unit test needs constructor access+    , casePSQ+    , cons+    , degree+    , delete+    , dminimumBy+    , length+    , lookup+    , filter+    , filterKeys+    , firstOnly+    , fromList+    , isZeroOrOne+    , keys+    , map+    , mapKeys+    , mapWithKey+    , mapWithKeyState+    , maximumBy+    , minimumBy+    , null+    , prefer+    , preferByKeys+    , preferOrElse+    , snoc+    , sortBy+    , sortByKeys+    , splits+    , toList+    , union+    ) where++-- Priority search queues.+--+-- I am not yet sure what exactly is needed. But we need a data structure with+-- key-based lookup that can be sorted. We're using a sequence right now with+-- (inefficiently implemented) lookup, because I think that queue-based+-- operations and sorting turn out to be more efficiency-critical in practice.++import Distribution.Solver.Modular.Degree++import Control.Arrow (first, second)++import qualified Data.Foldable as F+import Data.Function+import qualified Data.List as S+import Data.Ord (comparing)+import Data.Traversable+import Prelude hiding (foldr, length, lookup, filter, null, map)++newtype PSQ k v = PSQ [(k, v)]+  deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP++keys :: PSQ k v -> [k]+keys (PSQ xs) = fmap fst xs++lookup :: Eq k => k -> PSQ k v -> Maybe v+lookup k (PSQ xs) = S.lookup k xs++map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2+map f (PSQ xs) = PSQ (fmap (second f) xs)++mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v+mapKeys f (PSQ xs) = PSQ (fmap (first f) xs)++mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b+mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)++mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b+mapWithKeyState p (PSQ xs) s0 =+  PSQ (F.foldr (\ (k, v) r s -> case p s k v of+                                  (w, n) -> (k, w) : (r n))+               (const []) xs s0)++delete :: Eq k => k -> PSQ k a -> PSQ k a+delete k (PSQ xs) = PSQ (snd (S.partition ((== k) . fst) xs))++fromList :: [(k, a)] -> PSQ k a+fromList = PSQ++cons :: k -> a -> PSQ k a -> PSQ k a+cons k x (PSQ xs) = PSQ ((k, x) : xs)++snoc :: PSQ k a -> k -> a -> PSQ k a+snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])++casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r+casePSQ (PSQ xs) n c =+  case xs of+    []          -> n+    (k, v) : ys -> c k v (PSQ ys)++splits :: PSQ k a -> PSQ k (a, PSQ k a)+splits = go id+  where+    go f xs = casePSQ xs+        (PSQ [])+        (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys))++sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a+sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)++sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a+sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)++-- | Given a measure in form of a pseudo-peano-natural number,+-- determine the approximate minimum. This is designed to stop+-- even traversing the list as soon as we find any element with+-- measure 'ZeroOrOne'.+--+-- Always returns a one-element queue (except if the queue is+-- empty, then we return an empty queue again).+--+dminimumBy :: (a -> Degree) -> PSQ k a -> PSQ k a+dminimumBy _   (PSQ [])       = PSQ []+dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs+  where+    go ZeroOrOne v _ = PSQ [v]+    go _ v []        = PSQ [v]+    go c v (y : ys)  = case compare c d of+      LT -> go c v ys+      EQ -> go c v ys+      GT -> go d y ys+      where+        d = sel (snd y)++maximumBy :: (k -> Int) -> PSQ k a -> (k, a)+maximumBy sel (PSQ xs) =+  S.minimumBy (flip (comparing (sel . fst))) xs++minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a+minimumBy sel (PSQ xs) =+  PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]++-- | Will partition the list according to the predicate. If+-- there is any element that satisfies the precidate, then only+-- the elements satisfying the predicate are returned.+-- Otherwise, the rest is returned.+--+prefer :: (a -> Bool) -> PSQ k a -> PSQ k a+prefer p (PSQ xs) =+  let+    (pro, con) = S.partition (p . snd) xs+  in+    if S.null pro then PSQ con else PSQ pro++-- | Variant of 'prefer' that takes a continuation for the case+-- that there are none of the desired elements.+preferOrElse :: (a -> Bool) -> (PSQ k a -> PSQ k a) -> PSQ k a -> PSQ k a+preferOrElse p k (PSQ xs) =+  let+    (pro, con) = S.partition (p . snd) xs+  in+    if S.null pro then k (PSQ con) else PSQ pro++-- | Variant of 'prefer' that takes a predicate on the keys+-- rather than on the values.+--+preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+preferByKeys p (PSQ xs) =+  let+    (pro, con) = S.partition (p . fst) xs+  in+    if S.null pro then PSQ con else PSQ pro++filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)++filter :: (a -> Bool) -> PSQ k a -> PSQ k a+filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)++length :: PSQ k a -> Int+length (PSQ xs) = S.length xs++degree :: PSQ k a -> Degree+degree (PSQ [])     = ZeroOrOne+degree (PSQ [_])    = ZeroOrOne+degree (PSQ [_, _]) = Two+degree (PSQ _)      = Other++null :: PSQ k a -> Bool+null (PSQ xs) = S.null xs++isZeroOrOne :: PSQ k a -> Bool+isZeroOrOne (PSQ [])  = True+isZeroOrOne (PSQ [_]) = True+isZeroOrOne _         = False++firstOnly :: PSQ k a -> PSQ k a+firstOnly (PSQ [])      = PSQ []+firstOnly (PSQ (x : _)) = PSQ [x]++toList :: PSQ k a -> [(k, a)]+toList (PSQ xs) = xs++union :: PSQ k a -> PSQ k a -> PSQ k a+union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys)
+ cabal/cabal-install/Distribution/Solver/Modular/Package.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Package+  ( I(..)+  , Loc(..)+  , PackageId+  , PackageIdentifier(..)+  , PackageName, mkPackageName, unPackageName+  , PkgconfigName, mkPkgconfigName, unPkgconfigName+  , PI(..)+  , PN+  , QPV+  , instI+  , makeIndependent+  , primaryPP+  , showI+  , showPI+  , unPN+  ) where++import Data.List as L++import Distribution.Package -- from Cabal+import Distribution.Text (display)++import Distribution.Solver.Modular.Version+import Distribution.Solver.Types.PackagePath++-- | A package name.+type PN = PackageName++-- | Unpacking a package name.+unPN :: PN -> String+unPN = unPackageName++-- | Package version. A package name plus a version number.+type PV = PackageId++-- | Qualified package version.+type QPV = Qualified PV++-- | Package id. Currently just a black-box string.+type PId = UnitId++-- | Location. Info about whether a package is installed or not, and where+-- exactly it is located. For installed packages, uniquely identifies the+-- package instance via its 'PId'.+--+-- TODO: More information is needed about the repo.+data Loc = Inst PId | InRepo+  deriving (Eq, Ord, Show)++-- | Instance. A version number and a location.+data I = I Ver Loc+  deriving (Eq, Ord, Show)++-- | String representation of an instance.+showI :: I -> String+showI (I v InRepo)   = showVer v+showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid+  where+    -- A hack to extract the beginning of the package ABI hash+    shortId = snip (splitAt 4) (++ "...")+            . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)+            . display+    snip p f xs = case p xs of+                    (ys, zs) -> (if L.null zs then id else f) ys++-- | Package instance. A package name and an instance.+data PI qpn = PI qpn I+  deriving (Eq, Ord, Show, Functor)++-- | String representation of a package instance.+showPI :: PI QPN -> String+showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i++instI :: I -> Bool+instI (I _ (Inst _)) = True+instI _              = False++-- | Is the package in the primary group of packages.  This is used to+-- determine (1) if we should try to establish stanza preferences+-- for this goal, and (2) whether or not a user specified @--constraint@+-- should apply to this dependency (grep 'primaryPP' to see the+-- use sites).  In particular this does not include packages pulled in+-- as setup deps.+--+primaryPP :: PackagePath -> Bool+primaryPP (PackagePath _ns q) = go q+  where+    go Unqualified = True+    go (Base  _)   = True+    go (Setup _)   = False+    go (Exe _ _)   = False++-- | Create artificial parents for each of the package names, making+-- them all independent.+makeIndependent :: [PN] -> [QPN]+makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]+                               , let pp = PackagePath (Independent i) Unqualified+                     ]
+ cabal/cabal-install/Distribution/Solver/Modular/Preference.hs view
@@ -0,0 +1,441 @@+-- | Reordering or pruning the tree in order to prefer or make certain choices.+module Distribution.Solver.Modular.Preference+    ( avoidReinstalls+    , deferSetupChoices+    , deferWeakFlagChoices+    , enforceManualFlags+    , enforcePackageConstraints+    , enforceSingleInstanceRestriction+    , firstGoal+    , preferBaseGoalChoice+    , preferEasyGoalChoices+    , preferLinked+    , preferPackagePreferences+    , preferReallyEasyGoalChoices+    , requireInstalled+    , sortGoals+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Data.Function (on)+import qualified Data.List as L+import qualified Data.Map as M+import Control.Monad.Reader hiding (sequence)+import Data.Traversable (sequence)++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.InstalledPreference+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.Variable++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import qualified Distribution.Solver.Modular.PSQ as P+import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version+import qualified Distribution.Solver.Modular.ConflictSet as CS+import qualified Distribution.Solver.Modular.WeightedPSQ as W++-- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a+-- list of weight-calculating functions in order to avoid sorting the package+-- choices multiple times. Each function takes the package name, sorted list of+-- children's versions, and package option. 'addWeights' prepends the new+-- weights to the existing weights, which gives precedence to preferences that+-- are applied later.+addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c+addWeights fs = trav go+  where+    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)+    go (PChoiceF qpn@(Q _ pn) x cs) =+      let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs)+          weights k = [f pn sortedVersions k | f <- fs]++          elemsToWhnf :: [a] -> ()+          elemsToWhnf = foldr seq ()+      in  PChoiceF qpn x+          -- Evaluate the children's versions before evaluating any of the+          -- subtrees, so that 'sortedVersions' doesn't hold onto all of the+          -- subtrees (referenced by cs) and cause a space leak.+          (elemsToWhnf sortedVersions `seq`+             W.mapWeightsWithKey (\k w -> weights k ++ w) cs)+    go x                            = x++addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c+addWeight f = addWeights [f]++version :: POption -> Ver+version (POption (I v _) _) = v++-- | Prefer to link packages whenever possible.+preferLinked :: Tree d c -> Tree d c+preferLinked = addWeight (const (const linked))+  where+    linked (POption _ Nothing)  = 1+    linked (POption _ (Just _)) = 0++-- Works by setting weights on choice nodes. Also applies stanza preferences.+preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c+preferPackagePreferences pcs =+    preferPackageStanzaPreferences pcs .+    addWeights [+          \pn _  opt -> preferred pn opt++        -- Note that we always rank installed before uninstalled, and later+        -- versions before earlier, but we can change the priority of the+        -- two orderings.+        , \pn vs opt -> case preference pn of+                          PreferInstalled -> installed opt+                          PreferLatest    -> latest vs opt+        , \pn vs opt -> case preference pn of+                          PreferInstalled -> latest vs opt+                          PreferLatest    -> installed opt+        ]+  where+    -- Prefer packages with higher version numbers over packages with+    -- lower version numbers.+    latest :: [Ver] -> POption -> Weight+    latest sortedVersions opt =+      let l = length sortedVersions+          index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions+      in  fromIntegral index / fromIntegral l++    preference :: PN -> InstalledPreference+    preference pn =+      let PackagePreferences _ ipref _ = pcs pn+      in  ipref++    -- | Prefer versions satisfying more preferred version ranges.+    preferred :: PN -> POption -> Weight+    preferred pn opt =+      let PackagePreferences vrs _ _ = pcs pn+      in fromIntegral . negate . L.length $+         L.filter (flip checkVR (version opt)) vrs++    -- Prefer installed packages over non-installed packages.+    installed :: POption -> Weight+    installed (POption (I _ (Inst _)) _) = 0+    installed _                          = 1++-- | Traversal that tries to establish package stanza enable\/disable+-- preferences. Works by reordering the branches of stanza choices.+preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c+preferPackageStanzaPreferences pcs = trav go+  where+    go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts)+      | primaryPP pp && enableStanzaPref pn s =+          -- move True case first to try enabling the stanza+          let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts+              weight k = if k then 0 else 1+          -- defer the choice by setting it to weak+          in  SChoiceF qsn gr (WeakOrTrivial True) ts'+    go x = x++    enableStanzaPref :: PN -> OptionalStanza -> Bool+    enableStanzaPref pn s =+      let PackagePreferences _ _ spref = pcs pn+      in  s `elem` spref++-- | Helper function that tries to enforce a single package constraint on a+-- given instance for a P-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintP :: PackagePath+                          -> ConflictSet QPN+                          -> I+                          -> LabeledPackageConstraint+                          -> Tree d c+                          -> Tree d c+processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r+  | src == ConstraintSourceUserTarget && not (primaryPP pp)         = r+    -- the constraints arising from targets, like "foo-1.0" only apply to+    -- the main packages in the solution, they don't constrain setup deps++processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc+  where+    go (I v _) (PackageConstraintVersion _ vr)+        | checkVR vr v  = r+        | otherwise     = Fail c (GlobalConstraintVersion vr src)+    go _       (PackageConstraintInstalled _)+        | instI i       = r+        | otherwise     = Fail c (GlobalConstraintInstalled src)+    go _       (PackageConstraintSource    _)+        | not (instI i) = r+        | otherwise     = Fail c (GlobalConstraintSource src)+    go _       _ = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintF :: Flag+                          -> ConflictSet QPN+                          -> Bool+                          -> LabeledPackageConstraint+                          -> Tree d c+                          -> Tree d c+processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc+  where+    go (PackageConstraintFlags _ fa) =+        case L.lookup f fa of+          Nothing            -> r+          Just b | b == b'   -> r+                 | otherwise -> Fail c (GlobalConstraintFlag src)+    go _                             = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintS :: OptionalStanza+                          -> ConflictSet QPN+                          -> Bool+                          -> LabeledPackageConstraint+                          -> Tree d c+                          -> Tree d c+processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc+  where+    go (PackageConstraintStanzas _ ss) =+        if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)+                                 else r+    go _                               = r++-- | Traversal that tries to establish various kinds of user constraints. Works+-- by selectively disabling choices that have been ruled out by global user+-- constraints.+enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]+                          -> Tree d c+                          -> Tree d c+enforcePackageConstraints pcs = trav go+  where+    go (PChoiceF qpn@(Q pp pn)              gr      ts) =+      let c = varToConflictSet (P qpn)+          -- compose the transformation functions for each of the relevant constraint+          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP pp c i pc) id+                           (M.findWithDefault [] pn pcs)+      in PChoiceF qpn gr      (W.mapWithKey g ts)+    go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =+      let c = varToConflictSet (F qfn)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id+                           (M.findWithDefault [] pn pcs)+      in FChoiceF qfn gr tr m (W.mapWithKey g ts)+    go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr   ts) =+      let c = varToConflictSet (S qsn)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id+                           (M.findWithDefault [] pn pcs)+      in SChoiceF qsn gr tr   (W.mapWithKey g ts)+    go x = x++-- | Transformation that tries to enforce manual flags. Manual flags+-- can only be re-set explicitly by the user. This transformation should+-- be run after user preferences have been enforced. For manual flags,+-- it checks if a user choice has been made. If not, it disables all but+-- the first choice.+enforceManualFlags :: Tree d c -> Tree d c+enforceManualFlags = trav go+  where+    go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $+      let c = varToConflictSet (F qfn)+      in  case span isDisabled (W.toList ts) of+            ([], y : ys) -> W.fromList (y : L.map (\ (w, b, _) -> (w, b, Fail c ManualFlag)) ys)+            _            -> ts -- something has been manually selected, leave things alone+      where+        isDisabled (_, _, Fail _ (GlobalConstraintFlag _)) = True+        isDisabled _                                       = False+    go x                                                   = x++-- | Require installed packages.+requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c+requireInstalled p = trav go+  where+    go (PChoiceF v@(Q _ pn) gr cs)+      | p pn      = PChoiceF v gr (W.mapWithKey installed cs)+      | otherwise = PChoiceF v gr                         cs+      where+        installed (POption (I _ (Inst _)) _) x = x+        installed _ _ = Fail (varToConflictSet (P v)) CannotInstall+    go x          = x++-- | Avoid reinstalls.+--+-- This is a tricky strategy. If a package version is installed already and the+-- same version is available from a repo, the repo version will never be chosen.+-- This would result in a reinstall (either destructively, or potentially,+-- shadowing). The old instance won't be visible or even present anymore, but+-- other packages might have depended on it.+--+-- TODO: It would be better to actually check the reverse dependencies of installed+-- packages. If they're not depended on, then reinstalling should be fine. Even if+-- they are, perhaps this should just result in trying to reinstall those other+-- packages as well. However, doing this all neatly in one pass would require to+-- change the builder, or at least to change the goal set after building.+avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c+avoidReinstalls p = trav go+  where+    go (PChoiceF qpn@(Q _ pn) gr cs)+      | p pn      = PChoiceF qpn gr disableReinstalls+      | otherwise = PChoiceF qpn gr cs+      where+        disableReinstalls =+          let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]+          in  W.mapWithKey (notReinstall installed) cs++        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =+          Fail (varToConflictSet (P qpn)) CannotReinstall+        notReinstall _ _ x =+          x+    go x          = x++-- | Sort all goals using the provided function.+sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c+sortGoals variableOrder = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys goalOrder xs)+    go x                = x++    goalOrder :: Goal QPN -> Goal QPN -> Ordering+    goalOrder = variableOrder `on` (varToVariable . goalToVar)++    varToVariable :: Var QPN -> Variable QPN+    varToVariable (P qpn)                    = PackageVar qpn+    varToVariable (F (FN (PI qpn _) fn))     = FlagVar qpn fn+    varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza++-- | Always choose the first goal in the list next, abandoning all+-- other choices.+--+-- This is unnecessary for the default search strategy, because+-- it descends only into the first goal choice anyway,+-- but may still make sense to just reduce the tree size a bit.+firstGoal :: Tree d c -> Tree d c+firstGoal = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs)+    go x                = x+    -- Note that we keep empty choice nodes, because they mean success.++-- | Transformation that tries to make a decision on base as early as+-- possible. In nearly all cases, there's a single choice for the base+-- package. Also, fixing base early should lead to better error messages.+preferBaseGoalChoice :: Tree d c -> Tree d c+preferBaseGoalChoice = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs)+    go x                = x++    isBase :: Goal QPN -> Bool+    isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base"+    isBase _                       = False++-- | Deal with setup dependencies after regular dependencies, so that we can+-- will link setup dependencies against package dependencies when possible+deferSetupChoices :: Tree d c -> Tree d c+deferSetupChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs)+    go x                = x++    noSetup :: Goal QPN -> Bool+    noSetup (Goal (P (Q (PackagePath _ns (Setup _)) _)) _) = False+    noSetup _                                              = True++-- | Transformation that tries to avoid making weak flag choices early.+-- Weak flags are trivial flags (not influencing dependencies) or such+-- flags that are explicitly declared to be weak in the index.+deferWeakFlagChoices :: Tree d c -> Tree d c+deferWeakFlagChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs))+    go x                = x++    noWeakStanza :: Tree d c -> Bool+    noWeakStanza (SChoice _ _ (WeakOrTrivial True) _) = False+    noWeakStanza _                                    = True++    noWeakFlag :: Tree d c -> Bool+    noWeakFlag (FChoice _ _ (WeakOrTrivial True) _ _) = False+    noWeakFlag _                                      = True++-- | Transformation that sorts choice nodes so that+-- child nodes with a small branching degree are preferred.+--+-- Only approximates the number of choices in the branches+-- using dchoices which classifies every goal by the number+-- of active choices:+--+-- - 0 (guaranteed failure) or 1 (no other option) active choice+-- - 2 active choices+-- - 3 or more active choices+--+-- We pick the minimum goal according to this approximation.+-- In particular, if we encounter any goal in the first class+-- (0 or 1 option), we do not look any further and choose it+-- immediately.+--+-- Returns at most one choice.+--+preferEasyGoalChoices :: Tree d c -> Tree d c+preferEasyGoalChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs)+      -- (a different implementation that seems slower):+      -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs))+    go x                = x++-- | A variant of 'preferEasyGoalChoices' that just keeps the+-- ones with a branching degree of 0 or 1. Note that unlike+-- 'preferEasyGoalChoices', this may return more than one+-- choice.+--+preferReallyEasyGoalChoices :: Tree d c -> Tree d c+preferReallyEasyGoalChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.prefer zeroOrOneChoices xs)+    go x                = x++-- | Monad used internally in enforceSingleInstanceRestriction+--+-- For each package instance we record the goal for which we picked a concrete+-- instance. The SIR means that for any package instance there can only be one.+type EnforceSIR = Reader (Map (PI PN) QPN)++-- | Enforce ghc's single instance restriction+--+-- From the solver's perspective, this means that for any package instance+-- (that is, package name + package version) there can be at most one qualified+-- goal resolving to that instance (there may be other goals _linking_ to that+-- instance however).+enforceSingleInstanceRestriction :: Tree d c -> Tree d c+enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go+  where+    go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c)++    -- We just verify package choices.+    go (PChoiceF qpn gr cs) =+      PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) cs)+    go _otherwise =+      innM _otherwise++    -- The check proper+    goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)+    goP qpn@(Q _ pn) (POption i linkedTo) r = do+      let inst = PI pn i+      env <- ask+      case (linkedTo, M.lookup inst env) of+        (Just _, _) ->+          -- For linked nodes we don't check anything+          r+        (Nothing, Nothing) ->+          -- Not linked, not already used+          local (M.insert inst qpn) r+        (Nothing, Just qpn') -> do+          -- Not linked, already used. This is an error+          return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances
+ cabal/cabal-install/Distribution/Solver/Modular/RetryLog.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE Rank2Types #-}+module Distribution.Solver.Modular.RetryLog+    ( RetryLog+    , toProgress+    , fromProgress+    , mapFailure+    , retry+    , failWith+    , succeedWith+    , continueWith+    , tryWith+    ) where++import Distribution.Solver.Modular.Message+import Distribution.Solver.Types.Progress++-- | 'Progress' as a difference list that allows efficient appends at failures.+newtype RetryLog step fail done = RetryLog {+    unRetryLog :: forall fail2 . (fail -> Progress step fail2 done)+               -> Progress step fail2 done+  }++-- | /O(1)/. Convert a 'RetryLog' to a 'Progress'.+toProgress :: RetryLog step fail done -> Progress step fail done+toProgress (RetryLog f) = f Fail++-- | /O(N)/. Convert a 'Progress' to a 'RetryLog'.+fromProgress :: Progress step fail done -> RetryLog step fail done+fromProgress l = RetryLog $ \f -> go f l+  where+    go :: (fail1 -> Progress step fail2 done)+       -> Progress step fail1 done+       -> Progress step fail2 done+    go _ (Done d) = Done d+    go f (Fail failure) = f failure+    go f (Step m ms) = Step m (go f ms)++-- | /O(1)/. Apply a function to the failure value in a log.+mapFailure :: (fail1 -> fail2)+           -> RetryLog step fail1 done+           -> RetryLog step fail2 done+mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure)++-- | /O(1)/. If the first log leads to failure, continue with the second.+retry :: RetryLog step fail1 done+      -> (fail1 -> RetryLog step fail2 done)+      -> RetryLog step fail2 done+retry (RetryLog f) g =+    RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog++-- | /O(1)/. Create a log with one message before a failure.+failWith :: step -> fail -> RetryLog step fail done+failWith m failure = RetryLog $ \f -> Step m (f failure)++-- | /O(1)/. Create a log with one message before a success.+succeedWith :: step -> done -> RetryLog step fail done+succeedWith m d = RetryLog $ const $ Step m (Done d)++-- | /O(1)/. Prepend a message to a log.+continueWith :: step+             -> RetryLog step fail done+             -> RetryLog step fail done+continueWith m (RetryLog f) = RetryLog $ Step m . f++-- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert+-- 'Leave' before the failure if the log fails.+tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done+tryWith m f =+  RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave))
+ cabal/cabal-install/Distribution/Solver/Modular/Solver.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE CPP #-}+#ifdef DEBUG_TRACETREE+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#endif+module Distribution.Solver.Modular.Solver+    ( SolverConfig(..)+    , solve+    ) where++import Data.Map as M+import Data.List as L+import Data.Set as S+import Distribution.Version++import Distribution.Compiler (CompilerInfo)++import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.Variable++import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Builder+import Distribution.Solver.Modular.Cycles+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Explore+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Log+import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.Package+import qualified Distribution.Solver.Modular.Preference as P+import Distribution.Solver.Modular.Validate+import Distribution.Solver.Modular.Linking+import Distribution.Solver.Modular.PSQ (PSQ)+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.PSQ as PSQ++import Distribution.Simple.Setup (BooleanFlag(..))++#ifdef DEBUG_TRACETREE+import Distribution.Solver.Modular.Flag+import qualified Distribution.Solver.Modular.ConflictSet as CS+import qualified Distribution.Solver.Modular.WeightedPSQ as W+import qualified Distribution.Text as T++import Debug.Trace.Tree (gtraceJson)+import Debug.Trace.Tree.Simple+import Debug.Trace.Tree.Generic+import Debug.Trace.Tree.Assoc (Assoc(..))+#endif++-- | Various options for the modular solver.+data SolverConfig = SolverConfig {+  reorderGoals          :: ReorderGoals,+  countConflicts        :: CountConflicts,+  independentGoals      :: IndependentGoals,+  avoidReinstalls       :: AvoidReinstalls,+  shadowPkgs            :: ShadowPkgs,+  strongFlags           :: StrongFlags,+  maxBackjumps          :: Maybe Int,+  enableBackjumping     :: EnableBackjumping,+  solveExecutables      :: SolveExecutables,+  goalOrder             :: Maybe (Variable QPN -> Variable QPN -> Ordering)+}++-- | Run all solver phases.+--+-- In principle, we have a valid tree after 'validationPhase', which+-- means that every 'Done' node should correspond to valid solution.+--+-- There is one exception, though, and that is cycle detection, which+-- has been added relatively recently. Cycles are only removed directly+-- before exploration.+--+-- Semantically, there is no difference. Cycle detection, as implemented+-- now, only occurs for 'Done' nodes we encounter during exploration,+-- and cycle detection itself does not change the shape of the tree,+-- it only marks some 'Done' nodes as 'Fail', if they contain cyclic+-- solutions.+--+-- There is a tiny performance impact, however, in doing cycle detection+-- directly after validation. Probably because cycle detection maintains+-- some information, and the various reorderings implemented by+-- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more+-- costly if that information is already around during the reorderings.+--+-- With the current positioning directly before the 'explorePhase', there+-- seems to be no statistically significant performance impact of cycle+-- detection in the common case where there are no cycles.+--+solve :: SolverConfig                         -- ^ solver parameters+      -> CompilerInfo+      -> Index                                -- ^ all available packages as an index+      -> PkgConfigDb                          -- ^ available pkg-config pkgs+      -> (PN -> PackagePreferences)           -- ^ preferences+      -> Map PN [LabeledPackageConstraint]    -- ^ global constraints+      -> Set PN                               -- ^ global goals+      -> Log Message (Assignment, RevDepMap)+solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =+  explorePhase     $+  detectCycles     $+  heuristicsPhase  $+  preferencesPhase $+  validationPhase  $+  prunePhase       $+  buildPhase+  where+    explorePhase     = backjumpAndExplore (enableBackjumping sc) (countConflicts sc)+    detectCycles     = traceTree "cycles.json" id . detectCyclesPhase+    heuristicsPhase  =+      let heuristicsTree = traceTree "heuristics.json" id+      in case goalOrder sc of+           Nothing -> goalChoiceHeuristics .+                      heuristicsTree .+                      P.deferWeakFlagChoices .+                      P.deferSetupChoices .+                      P.preferBaseGoalChoice+           Just order -> P.firstGoal .+                         heuristicsTree .+                         P.sortGoals order+    preferencesPhase = P.preferLinked .+                       P.preferPackagePreferences userPrefs+    validationPhase  = traceTree "validated.json" id .+                       P.enforceManualFlags . -- can only be done after user constraints+                       P.enforcePackageConstraints userConstraints .+                       P.enforceSingleInstanceRestriction .+                       validateLinking idx .+                       validateTree cinfo idx pkgConfigDB+    prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .+                       -- packages that can never be "upgraded":+                       P.requireInstalled (`elem` [ mkPackageName "base"+                                                  , mkPackageName "ghc-prim"+                                                  , mkPackageName "integer-gmp"+                                                  , mkPackageName "integer-simple"+                                                  ])+    buildPhase       = traceTree "build.json" id+                     $ addLinking+                     $ buildTree idx (independentGoals sc) (S.toList userGoals)++    -- Counting conflicts and reordering goals interferes, as both are strategies to+    -- change the order of goals.+    --+    -- We therefore change the strategy based on whether --count-conflicts is set or+    -- not:+    --+    -- - when --count-conflicts is set, we use preferReallyEasyGoalChoices, which+    --   prefers (keeps) goals only if the have 0 or 1 enabled choice.+    --+    -- - when --count-conflicts is not set, we use preferEasyGoalChoices, which+    --   (next to preferring goals with 0 or 1 enabled choice)+    --   also prefers goals that have 2 enabled choices over goals with more than+    --   two enabled choices.+    --+    -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes+    -- to just a single option. This was a way to work around a space leak that was+    -- unnecessary and is now fixed, so we no longer do it.+    --+    -- If --count-conflicts is active, it will then choose among the remaining goals+    -- the one that has been responsible for the most conflicts so far.+    --+    -- Otherwise, we simply choose the first remaining goal.+    --+    goalChoiceHeuristics+      | asBool (reorderGoals sc) && asBool (countConflicts sc) = P.preferReallyEasyGoalChoices+      | asBool (reorderGoals sc)                               = P.preferEasyGoalChoices+      | otherwise                                              = id {- P.firstGoal -}++-- | Dump solver tree to a file (in debugging mode)+--+-- This only does something if the @debug-tracetree@ configure argument was+-- given; otherwise this is just the identity function.+traceTree ::+#ifdef DEBUG_TRACETREE+  GSimpleTree a =>+#endif+     FilePath  -- ^ Output file+  -> (a -> a)  -- ^ Function to summarize the tree before dumping+  -> a -> a+#ifdef DEBUG_TRACETREE+traceTree = gtraceJson+#else+traceTree _ _ = id+#endif++#ifdef DEBUG_TRACETREE+instance GSimpleTree (Tree d QGoalReason) where+  fromGeneric = go+    where+      go :: Tree d QGoalReason -> SimpleTree+      go (PChoice qpn _     psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList  psq+      go (FChoice _   _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq+      go (SChoice _   _ _   psq) = Node "S" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq+      go (GoalChoice        psq) = Node "G" $ Assoc $ L.map (uncurry goG)       $ PSQ.toList psq+      go (Done _rdm _s)          = Node "D" $ Assoc []+      go (Fail cs _reason)       = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]++      psqToList :: W.WeightedPSQ w k v -> [(k, v)]+      psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList++      -- Show package choice+      goP :: QPN -> POption -> Tree d QGoalReason -> (String, SimpleTree)+      goP _        (POption (I ver _loc) Nothing)  subtree = (T.display ver, go subtree)+      goP (Q _ pn) (POption _           (Just pp)) subtree = (showQPN (Q pp pn), go subtree)++      -- Show flag or stanza choice+      goFS :: Bool -> Tree d QGoalReason -> (String, SimpleTree)+      goFS val subtree = (show val, go subtree)++      -- Show goal choice+      goG :: Goal QPN -> Tree d QGoalReason -> (String, SimpleTree)+      goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)++      -- Variation on 'showGR' that produces shorter strings+      -- (Actually, QGoalReason records more info than necessary: we only need+      -- to know the variable that introduced the goal, not the value assigned+      -- to that variable)+      shortGR :: QGoalReason -> String+      shortGR UserGoal               = "user"+      shortGR (PDependency (PI nm _)) = showQPN nm+      shortGR (FDependency nm _)      = showQFN nm+      shortGR (SDependency nm)        = showQSN nm++      -- Show conflict set+      goCS :: ConflictSet QPN -> String+      goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"+#endif++-- | Replace all goal reasons with a dummy goal reason in the tree+--+-- This is useful for debugging (when experimenting with the impact of GRs)+_removeGR :: Tree d QGoalReason -> Tree d QGoalReason+_removeGR = trav go+  where+   go :: TreeF d QGoalReason (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)+   go (PChoiceF qpn _     psq) = PChoiceF qpn dummy     psq+   go (FChoiceF qfn _ a b psq) = FChoiceF qfn dummy a b psq+   go (SChoiceF qsn _ a   psq) = SChoiceF qsn dummy a   psq+   go (GoalChoiceF        psq) = GoalChoiceF            (goG psq)+   go (DoneF rdm s)            = DoneF rdm s+   go (FailF cs reason)        = FailF cs reason++   goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)+   goG = PSQ.fromList+       . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))+       . PSQ.toList++   dummy :: QGoalReason+   dummy = PDependency+         $ PI (Q (PackagePath DefaultNamespace Unqualified) (mkPackageName "$"))+              (I (mkVersion [1]) InRepo)
+ cabal/cabal-install/Distribution/Solver/Modular/Tree.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Solver.Modular.Tree+    ( FailReason(..)+    , POption(..)+    , Tree(..)+    , TreeF(..)+    , Weight+    , ana+    , cata+    , dchoices+    , inn+    , innM+    , para+    , trav+    , zeroOrOneChoices+    ) where++import Control.Monad hiding (mapM, sequence)+import Data.Foldable+import Data.Traversable+import Prelude hiding (foldr, mapM, sequence)++import Distribution.Solver.Modular.Degree+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.PSQ (PSQ)+import Distribution.Solver.Modular.Version+import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ)+import qualified Distribution.Solver.Modular.WeightedPSQ as W+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.PackagePath++type Weight = Double++-- | Type of the search tree. Inlining the choice nodes for now. Weights on+-- package, flag, and stanza choices control the traversal order.+--+-- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes+-- (type 'c'). For example, during the final traversal, choice nodes contain the+-- variables that introduced the choices, and 'Done' nodes contain the+-- assignments for all variables.+--+-- TODO: The weight type should be changed from [Double] to Double to avoid+-- giving too much weight to preferences that are applied later.+data Tree d c =+    -- | Choose a version for a package (or choose to link)+    PChoice QPN c (WeightedPSQ [Weight] POption (Tree d c))++    -- | Choose a value for a flag+    --+    -- The Bool indicates whether it's manual.+  | FChoice QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree d c))++    -- | Choose whether or not to enable a stanza+  | SChoice QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c))++    -- | Choose which choice to make next+    --+    -- Invariants:+    --+    -- * PSQ should never be empty+    -- * For each choice we additionally record the 'QGoalReason' why we are+    --   introducing that goal into tree. Note that most of the time we are+    --   working with @Tree QGoalReason@; in that case, we must have the+    --   invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice'+    --   or 'SChoice' directly below a 'GoalChoice' node must equal the reason+    --   recorded on that 'GoalChoice' node.+  | GoalChoice (PSQ (Goal QPN) (Tree d c))++    -- | We're done -- we found a solution!+  | Done RevDepMap d++    -- | We failed to find a solution in this path through the tree+  | Fail (ConflictSet QPN) FailReason+  deriving (Eq, Show)++-- | A package option is a package instance with an optional linking annotation+--+-- The modular solver has a number of package goals to solve for, and can only+-- pick a single package version for a single goal. In order to allow to+-- install multiple versions of the same package as part of a single solution+-- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both+-- be qualified goals for @P@, allowing to pick a difference version of package+-- @P@ for @0.P@ and @1.P@.+--+-- Linking is an essential part of this story. In addition to picking a specific+-- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or+-- vice versa). It means that @1.P@ and @0.P@ really must be the very same package+-- (and hence must have the same build time configuration, and their+-- dependencies must also be the exact same).+--+-- See <http://www.well-typed.com/blog/2015/03/qualified-goals/> for details.+data POption = POption I (Maybe PackagePath)+  deriving (Eq, Show)++data FailReason = InconsistentInitialConstraints+                | Conflicting [Dep QPN]+                | CannotInstall+                | CannotReinstall+                | Shadowed+                | Broken+                | GlobalConstraintVersion VR ConstraintSource+                | GlobalConstraintInstalled ConstraintSource+                | GlobalConstraintSource ConstraintSource+                | GlobalConstraintFlag ConstraintSource+                | ManualFlag+                | MalformedFlagChoice QFN+                | MalformedStanzaChoice QSN+                | EmptyGoalChoice+                | Backjump+                | MultipleInstances+                | DependenciesNotLinked String+                | CyclicDependencies+  deriving (Eq, Show)++-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'+-- have the same meaning as in 'Tree'.+data TreeF d c a =+    PChoiceF    QPN c                    (WeightedPSQ [Weight] POption a)+  | FChoiceF    QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool    a)+  | SChoiceF    QSN c WeakOrTrivial      (WeightedPSQ [Weight] Bool    a)+  | GoalChoiceF                          (PSQ (Goal QPN) a)+  | DoneF       RevDepMap d+  | FailF       (ConflictSet QPN) FailReason+  deriving (Functor, Foldable, Traversable)++out :: Tree d c -> TreeF d c (Tree d c)+out (PChoice    p i     ts) = PChoiceF    p i     ts+out (FChoice    p i b m ts) = FChoiceF    p i b m ts+out (SChoice    p i b   ts) = SChoiceF    p i b   ts+out (GoalChoice         ts) = GoalChoiceF         ts+out (Done       x s       ) = DoneF       x s+out (Fail       c x       ) = FailF       c x++inn :: TreeF d c (Tree d c) -> Tree d c+inn (PChoiceF    p i     ts) = PChoice    p i     ts+inn (FChoiceF    p i b m ts) = FChoice    p i b m ts+inn (SChoiceF    p i b   ts) = SChoice    p i b   ts+inn (GoalChoiceF         ts) = GoalChoice         ts+inn (DoneF       x s       ) = Done       x s+inn (FailF       c x       ) = Fail       c x++innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)+innM (PChoiceF    p i     ts) = liftM (PChoice    p i    ) (sequence ts)+innM (FChoiceF    p i b m ts) = liftM (FChoice    p i b m) (sequence ts)+innM (SChoiceF    p i b   ts) = liftM (SChoice    p i b  ) (sequence ts)+innM (GoalChoiceF         ts) = liftM (GoalChoice        ) (sequence ts)+innM (DoneF       x s       ) = return $ Done     x s+innM (FailF       c x       ) = return $ Fail     c x++-- | Determines whether a tree is active, i.e., isn't a failure node.+active :: Tree d c -> Bool+active (Fail _ _) = False+active _          = True++-- | Approximates the number of active choices that are available in a node.+-- Note that we count goal choices as having one choice, always.+dchoices :: Tree d c -> Degree+dchoices (PChoice    _ _     ts) = W.degree (W.filter active ts)+dchoices (FChoice    _ _ _ _ ts) = W.degree (W.filter active ts)+dchoices (SChoice    _ _ _   ts) = W.degree (W.filter active ts)+dchoices (GoalChoice         _ ) = ZeroOrOne+dchoices (Done       _ _       ) = ZeroOrOne+dchoices (Fail       _ _       ) = ZeroOrOne++-- | Variant of 'dchoices' that traverses fewer children.+zeroOrOneChoices :: Tree d c -> Bool+zeroOrOneChoices (PChoice    _ _     ts) = W.isZeroOrOne (W.filter active ts)+zeroOrOneChoices (FChoice    _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)+zeroOrOneChoices (SChoice    _ _ _   ts) = W.isZeroOrOne (W.filter active ts)+zeroOrOneChoices (GoalChoice         _ ) = True+zeroOrOneChoices (Done       _ _       ) = True+zeroOrOneChoices (Fail       _ _       ) = True++-- | Catamorphism on trees.+cata :: (TreeF d c a -> a) -> Tree d c -> a+cata phi x = (phi . fmap (cata phi) . out) x++trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a+trav psi x = cata (inn . psi) x++-- | Paramorphism on trees.+para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a+para phi = phi . fmap (\ x -> (para phi x, x)) . out++-- | Anamorphism on trees.+ana :: (a -> TreeF d c a) -> a -> Tree d c+ana psi = inn . fmap (ana psi) . psi
+ cabal/cabal-install/Distribution/Solver/Modular/Validate.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Distribution.Solver.Modular.Validate (validateTree) where++-- Validation of the tree.+--+-- The task here is to make sure all constraints hold. After validation, any+-- assignment returned by exploration of the tree should be a complete valid+-- assignment, i.e., actually constitute a solution.++import Control.Applicative+import Control.Monad.Reader hiding (sequence)+import Data.List as L+import Data.Map as M+import Data.Set as S+import Data.Traversable+import Prelude hiding (sequence)++import Language.Haskell.Extension (Extension, Language)++import Distribution.Compiler (CompilerInfo(..))++import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version (VR)+import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Distribution.Solver.Types.ComponentDeps (Component)++import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)++-- In practice, most constraints are implication constraints (IF we have made+-- a number of choices, THEN we also have to ensure that). We call constraints+-- that for which the preconditions are fulfilled ACTIVE. We maintain a set+-- of currently active constraints that we pass down the node.+--+-- We aim at detecting inconsistent states as early as possible.+--+-- Whenever we make a choice, there are two things that need to happen:+--+--   (1) We must check that the choice is consistent with the currently+--       active constraints.+--+--   (2) The choice increases the set of active constraints. For the new+--       active constraints, we must check that they are consistent with+--       the current state.+--+-- We can actually merge (1) and (2) by saying the the current choice is+-- a new active constraint, fixing the choice.+--+-- If a test fails, we have detected an inconsistent state. We can+-- disable the current subtree and do not have to traverse it any further.+--+-- We need a good way to represent the current state, i.e., the current+-- set of active constraints. Since the main situation where we have to+-- search in it is (1), it seems best to store the state by package: for+-- every package, we store which versions are still allowed. If for any+-- package, we have inconsistent active constraints, we can also stop.+-- This is a particular way to read task (2):+--+--   (2, weak) We only check if the new constraints are consistent with+--       the choices we've already made, and add them to the active set.+--+--   (2, strong) We check if the new constraints are consistent with the+--       choices we've already made, and the constraints we already have.+--+-- It currently seems as if we're implementing the weak variant. However,+-- when used together with 'preferEasyGoalChoices', we will find an+-- inconsistent state in the very next step.+--+-- What do we do about flags?+--+-- Like for packages, we store the flag choices we have already made.+-- Now, regarding (1), we only have to test whether we've decided the+-- current flag before. Regarding (2), the interesting bit is in discovering+-- the new active constraints. To this end, we look up the constraints for+-- the package the flag belongs to, and traverse its flagged dependencies.+-- Wherever we find the flag in question, we start recording dependencies+-- underneath as new active dependencies. If we encounter other flags, we+-- check if we've chosen them already and either proceed or stop.++-- | The state needed during validation.+data ValidateState = VS {+  supportedExt  :: Extension -> Bool,+  supportedLang :: Language  -> Bool,+  presentPkgs   :: PkgconfigName -> VR  -> Bool,+  index :: Index,+  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies+  pa    :: PreAssignment,+  qualifyOptions :: QualifyOptions+}++newtype Validate a = Validate (Reader ValidateState a)+  deriving (Functor, Applicative, Monad, MonadReader ValidateState)++runValidate :: Validate a -> ValidateState -> a+runValidate (Validate r) = runReader r++validate :: Tree d c -> Validate (Tree d c)+validate = cata go+  where+    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)++    go (PChoiceF qpn gr     ts) = PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) ts)+    go (FChoiceF qfn gr b m ts) =+      do+        -- Flag choices may occur repeatedly (because they can introduce new constraints+        -- in various places). However, subsequent choices must be consistent. We thereby+        -- collapse repeated flag choice nodes.+        PA _ pfa _ <- asks pa -- obtain current flag-preassignment+        case M.lookup qfn pfa of+          Just rb -> -- flag has already been assigned; collapse choice to the correct branch+                     case W.lookup rb ts of+                       Just t  -> goF qfn rb t+                       Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)+          Nothing -> -- flag choice is new, follow both branches+                     FChoice qfn gr b m <$> sequence (W.mapWithKey (goF qfn) ts)+    go (SChoiceF qsn gr b   ts) =+      do+        -- Optional stanza choices are very similar to flag choices.+        PA _ _ psa <- asks pa -- obtain current stanza-preassignment+        case M.lookup qsn psa of+          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch+                     case W.lookup rb ts of+                       Just t  -> goS qsn rb t+                       Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn)+          Nothing -> -- stanza choice is new, follow both branches+                     SChoice qsn gr b <$> sequence (W.mapWithKey (goS qsn) ts)++    -- We don't need to do anything for goal choices or failure nodes.+    go (GoalChoiceF              ts) = GoalChoice <$> sequence ts+    go (DoneF    rdm s             ) = pure (Done rdm s)+    go (FailF    c fr              ) = pure (Fail c fr)++    -- What to do for package nodes ...+    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)+    goP qpn@(Q _pp pn) (POption i _) r = do+      PA ppa pfa psa <- asks pa    -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs+      idx            <- asks index -- obtain the index+      svd            <- asks saved -- obtain saved dependencies+      qo             <- asks qualifyOptions+      -- obtain dependencies and index-dictated exclusions introduced by the choice+      let (PInfo deps _ mfr) = idx ! pn ! i+      -- qualify the deps in the current scope+      let qdeps = qualifyDeps qo qpn deps+      -- the new active constraints are given by the instance we have chosen,+      -- plus the dependency information we have for that instance+      -- TODO: is the False here right?+      let newactives = Dep False {- not exe -} qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps)+      -- We now try to extend the partial assignment with the new active constraints.+      let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives+      -- In case we continue, we save the scoped dependencies+      let nsvd = M.insert qpn qdeps svd+      case mfr of+        Just fr -> -- The index marks this as an invalid choice. We can stop.+                   return (Fail (varToConflictSet (P qpn)) fr)+        _       -> case mnppa of+                     Left (c, d) -> -- We have an inconsistency. We can stop.+                                    return (Fail c (Conflicting d))+                     Right nppa  -> -- We have an updated partial assignment for the recursive validation.+                                    local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r++    -- What to do for flag nodes ...+    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goF qfn@(FN (PI qpn _i) _f) b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs   -- obtain the present pkg-config pkgs+      svd <- asks saved         -- obtain saved dependencies+      -- Note that there should be saved dependencies for the package in question,+      -- because while building, we do not choose flags before we see the packages+      -- that define them.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npfa = M.insert qfn b pfa+      -- We now try to get the new active dependencies we might learn about because+      -- we have chosen a new flag.+      let newactives = extractNewDeps (F qfn) b npfa psa qdeps+      -- As in the package case, we try to extend the partial assignment.+      case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of+        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found+        Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r++    -- What to do for stanza nodes (similar to flag nodes) ...+    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goS qsn@(SN (PI qpn _i) _f) b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs+      svd <- asks saved         -- obtain saved dependencies+      -- Note that there should be saved dependencies for the package in question,+      -- because while building, we do not choose flags before we see the packages+      -- that define them.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npsa = M.insert qsn b psa+      -- We now try to get the new active dependencies we might learn about because+      -- we have chosen a new flag.+      let newactives = extractNewDeps (S qsn) b pfa npsa qdeps+      -- As in the package case, we try to extend the partial assignment.+      case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of+        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found+        Right nppa  -> local (\ s -> s { pa = PA nppa pfa npsa }) r++-- | We try to extract as many concrete dependencies from the given flagged+-- dependencies as possible. We make use of all the flag knowledge we have+-- already acquired.+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]+extractDeps fa sa deps = do+  d <- deps+  case d of+    Simple sd _         -> return sd+    Flagged qfn _ td fd -> case M.lookup qfn fa of+                             Nothing    -> mzero+                             Just True  -> extractDeps fa sa td+                             Just False -> extractDeps fa sa fd+    Stanza qsn td       -> case M.lookup qsn sa of+                             Nothing    -> mzero+                             Just True  -> extractDeps fa sa td+                             Just False -> []++-- | We try to find new dependencies that become available due to the given+-- flag or stanza choice. We therefore look for the choice in question, and then call+-- 'extractDeps' for everything underneath.+extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]+extractNewDeps v b fa sa = go+  where+    go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)+    go deps = do+      d <- deps+      case d of+        Simple _ _           -> mzero+        Flagged qfn' _ td fd+          | v == F qfn'      -> L.map (resetVar v) $+                                if b then extractDeps fa sa td else extractDeps fa sa fd+          | otherwise        -> case M.lookup qfn' fa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> go fd+        Stanza qsn' td+          | v == S qsn'      -> L.map (resetVar v) $+                                if b then extractDeps fa sa td else []+          | otherwise        -> case M.lookup qsn' sa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> []++-- | Interface.+validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c+validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {+    supportedExt   = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported+                           (\ es -> let s = S.fromList es in \ x -> S.member x s)+                           (compilerInfoExtensions cinfo)+  , supportedLang  = maybe (const True)+                           (flip L.elem) -- use list lookup because language list is small and no Ord instance+                           (compilerInfoLanguages  cinfo)+  , presentPkgs    = pkgConfigPkgIsPresent pkgConfigDb+  , index          = idx+  , saved          = M.empty+  , pa             = PA M.empty M.empty M.empty+  , qualifyOptions = defaultQualifyOptions idx+  }
+ cabal/cabal-install/Distribution/Solver/Modular/Var.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Var (+    Var(..)+  , simplifyVar+  , showVar+  , varPI+  ) where++import Prelude hiding (pi)++import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Types.PackagePath++{-------------------------------------------------------------------------------+  Variables+-------------------------------------------------------------------------------}++-- | The type of variables that play a role in the solver.+-- Note that the tree currently does not use this type directly,+-- and rather has separate tree nodes for the different types of+-- variables. This fits better with the fact that in most cases,+-- these have to be treated differently.+data Var qpn = P qpn | F (FN qpn) | S (SN qpn)+  deriving (Eq, Ord, Show, Functor)++-- | For computing conflict sets, we map flag choice vars to a+-- single flag choice. This means that all flag choices are treated+-- as interdependent. So if one flag of a package ends up in a+-- conflict set, then all flags are being treated as being part of+-- the conflict set.+simplifyVar :: Var qpn -> Var qpn+simplifyVar (P qpn)       = P qpn+simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))+simplifyVar (S qsn)       = S qsn++showVar :: Var QPN -> String+showVar (P qpn) = showQPN qpn+showVar (F qfn) = showQFN qfn+showVar (S qsn) = showQSN qsn++-- | Extract the package instance from a Var+varPI :: Var QPN -> (QPN, Maybe I)+varPI (P qpn)               = (qpn, Nothing)+varPI (F (FN (PI qpn i) _)) = (qpn, Just i)+varPI (S (SN (PI qpn i) _)) = (qpn, Just i)
+ cabal/cabal-install/Distribution/Solver/Modular/Version.hs view
@@ -0,0 +1,53 @@+module Distribution.Solver.Modular.Version+    ( Ver+    , VR+    , anyVR+    , checkVR+    , eqVR+    , showVer+    , showVR+    , simplifyVR+    , (.&&.)+    , (.||.)+    ) where++import qualified Distribution.Version as CV -- from Cabal+import Distribution.Text -- from Cabal++-- | Preliminary type for versions.+type Ver = CV.Version++-- | String representation of a version.+showVer :: Ver -> String+showVer = display++-- | Version range. Consists of a lower and upper bound.+type VR = CV.VersionRange++-- | String representation of a version range.+showVR :: VR -> String+showVR = display++-- | Unconstrained version range.+anyVR :: VR+anyVR = CV.anyVersion++-- | Version range fixing a single version.+eqVR :: Ver -> VR+eqVR = CV.thisVersion++-- | Intersect two version ranges.+(.&&.) :: VR -> VR -> VR+(.&&.) = CV.intersectVersionRanges++-- | Union of two version ranges.+(.||.) :: VR -> VR -> VR+(.||.) = CV.unionVersionRanges++-- | Simplify a version range.+simplifyVR :: VR -> VR+simplifyVR = CV.simplifyVersionRange++-- | Checking a version against a version range.+checkVR :: VR -> Ver -> Bool+checkVR = flip CV.withinRange
+ cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Solver.Modular.WeightedPSQ (+    WeightedPSQ+  , fromList+  , toList+  , keys+  , weights+  , degree+  , isZeroOrOne+  , filter+  , lookup+  , mapWithKey+  , mapWeightsWithKey+  , union+  ) where++import qualified Data.Foldable as F+import qualified Data.List as L+import Data.Ord (comparing)+import qualified Data.Traversable as T+import Prelude hiding (filter, lookup)++import Distribution.Solver.Modular.Degree++-- | An association list that is sorted by weight.+--+-- Each element has a key ('k'), value ('v'), and weight ('w'). All operations+-- that add elements or modify weights stably sort the elements by weight.+newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)]+  deriving (Eq, Show, Functor, F.Foldable, T.Traversable)++-- | /O(N)/.+filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v+filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs)++-- | /O(1)/. Return the length as a 'Degree' after traversing as few elements+-- as possible.+degree :: WeightedPSQ w k v -> Degree+degree (WeightedPSQ [])     = ZeroOrOne+degree (WeightedPSQ [_])    = ZeroOrOne+degree (WeightedPSQ [_, _]) = Two+degree (WeightedPSQ _)      = Other++-- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements.+isZeroOrOne :: WeightedPSQ w k v -> Bool+isZeroOrOne (WeightedPSQ [])  = True+isZeroOrOne (WeightedPSQ [_]) = True+isZeroOrOne _                 = False++-- | /O(1)/. Return the elements in order.+toList :: WeightedPSQ w k v -> [(w, k, v)]+toList (WeightedPSQ xs) = xs++-- | /O(N log N)/.+fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v+fromList = WeightedPSQ . L.sortBy (comparing triple_1)++-- | /O(N)/. Return the weights in order.+weights :: WeightedPSQ w k v -> [w]+weights (WeightedPSQ xs) = L.map triple_1 xs++-- | /O(N)/. Return the keys in order.+keys :: WeightedPSQ w k v -> [k]+keys (WeightedPSQ xs) = L.map triple_2 xs++-- | /O(N)/. Return the value associated with the first occurrence of the give+-- key, if it exists.+lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v+lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs++-- | /O(N log N)/. Update the weights.+mapWeightsWithKey :: Ord w2+                  => (k -> w1 -> w2)+                  -> WeightedPSQ w1 k v+                  -> WeightedPSQ w2 k v+mapWeightsWithKey f (WeightedPSQ xs) = fromList $+                                       L.map (\ (w, k, v) -> (f k w, k, v)) xs++-- | /O(N)/. Update the values.+mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2+mapWithKey f (WeightedPSQ xs) = WeightedPSQ $+                                L.map (\ (w, k, v) -> (w, k, f k v)) xs++-- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all+-- elements. Elements from the first @WeightedPSQ@ come before elements in the+-- second when they have the same weight.+union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v+union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys)++triple_1 :: (x, y, z) -> x+triple_1 (x, _, _) = x++triple_2 :: (x, y, z) -> y+triple_2 (_, y, _) = y++triple_3 :: (x, y, z) -> z+triple_3 (_, _, z) = z
+ cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Fine-grained package dependencies+--+-- Like many others, this module is meant to be "double-imported":+--+-- > import Distribution.Solver.Types.ComponentDeps (+-- >     Component+-- >   , ComponentDep+-- >   , ComponentDeps+-- >   )+-- > import qualified Distribution.Solver.Types.ComponentDeps as CD+module Distribution.Solver.Types.ComponentDeps (+    -- * Fine-grained package dependencies+    Component(..)+  , componentNameToComponent+  , ComponentDep+  , ComponentDeps -- opaque+    -- ** Constructing ComponentDeps+  , empty+  , fromList+  , singleton+  , insert+  , zip+  , filterDeps+  , fromLibraryDeps+  , fromSetupDeps+  , fromInstalled+    -- ** Deconstructing ComponentDeps+  , toList+  , flatDeps+  , nonSetupDeps+  , libraryDeps+  , setupDeps+  , select+  ) where++import Prelude ()+import Distribution.Package (UnqualComponentName)+import Distribution.Client.Compat.Prelude hiding (empty,zip)++import qualified Data.Map as Map+import Data.Foldable (fold)++import qualified Distribution.Types.ComponentName as CN++{-------------------------------------------------------------------------------+  Types+-------------------------------------------------------------------------------}++-- | Component of a package.+data Component =+    ComponentLib+  | ComponentSubLib UnqualComponentName+  | ComponentFLib   UnqualComponentName+  | ComponentExe    UnqualComponentName+  | ComponentTest   UnqualComponentName+  | ComponentBench  UnqualComponentName+  | ComponentSetup+  deriving (Show, Eq, Ord, Generic)++instance Binary Component++-- | Dependency for a single component.+type ComponentDep a = (Component, a)++-- | Fine-grained dependencies for a package.+--+-- Typically used as @ComponentDeps [Dependency]@, to represent the list of+-- dependencies for each named component within a package.+--+newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }+  deriving (Show, Functor, Eq, Ord, Generic)++instance Semigroup a => Monoid (ComponentDeps a) where+  mempty = ComponentDeps Map.empty+  mappend = (<>)++instance Semigroup a => Semigroup (ComponentDeps a) where+  ComponentDeps d <> ComponentDeps d' =+      ComponentDeps (Map.unionWith (<>) d d')++instance Foldable ComponentDeps where+  foldMap f = foldMap f . unComponentDeps++instance Traversable ComponentDeps where+  traverse f = fmap ComponentDeps . traverse f . unComponentDeps++instance Binary a => Binary (ComponentDeps a)++componentNameToComponent :: CN.ComponentName -> Component+componentNameToComponent (CN.CLibName)      = ComponentLib+componentNameToComponent (CN.CSubLibName s) = ComponentSubLib s+componentNameToComponent (CN.CFLibName s)   = ComponentFLib s+componentNameToComponent (CN.CExeName s)    = ComponentExe s+componentNameToComponent (CN.CTestName s)   = ComponentTest s+componentNameToComponent (CN.CBenchName s)  = ComponentBench s++{-------------------------------------------------------------------------------+  Construction+-------------------------------------------------------------------------------}++empty :: ComponentDeps a+empty = ComponentDeps $ Map.empty++fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a+fromList = ComponentDeps . Map.fromListWith mappend++singleton :: Component -> a -> ComponentDeps a+singleton comp = ComponentDeps . Map.singleton comp++insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a+insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps+  where+    aux Nothing   = Just a+    aux (Just a') = Just $ a `mappend` a'++-- | Zip two 'ComponentDeps' together by 'Component', using 'mempty'+-- as the neutral element when a 'Component' is present only in one.+zip :: (Monoid a, Monoid b) => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)+{- TODO/FIXME: Once we can expect containers>=0.5, switch to the more efficient version below:++zip (ComponentDeps d1) (ComponentDeps d2) =+    ComponentDeps $+      Map.mergeWithKey+        (\_ a b -> Just (a,b))+        (fmap (\a -> (a, mempty)))+        (fmap (\b -> (mempty, b)))+        d1 d2++-}+zip (ComponentDeps d1) (ComponentDeps d2) =+    ComponentDeps $+      Map.unionWith+        mappend+        (Map.map (\a -> (a, mempty)) d1)+        (Map.map (\b -> (mempty, b)) d2)+++-- | Keep only selected components (and their associated deps info).+filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a+filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps++-- | ComponentDeps containing library dependencies only+fromLibraryDeps :: a -> ComponentDeps a+fromLibraryDeps = singleton ComponentLib++-- | ComponentDeps containing setup dependencies only.+fromSetupDeps :: a -> ComponentDeps a+fromSetupDeps = singleton ComponentSetup++-- | ComponentDeps for installed packages.+--+-- We assume that installed packages only record their library dependencies.+fromInstalled :: a -> ComponentDeps a+fromInstalled = fromLibraryDeps++{-------------------------------------------------------------------------------+  Deconstruction+-------------------------------------------------------------------------------}++toList :: ComponentDeps a -> [ComponentDep a]+toList = Map.toList . unComponentDeps++-- | All dependencies of a package.+--+-- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more+-- obvious than a use of 'fold', and moreover this avoids introducing lots of+-- @#ifdef@s for 7.10 just for the use of 'fold'.+flatDeps :: Monoid a => ComponentDeps a -> a+flatDeps = fold++-- | All dependencies except the setup dependencies.+--+-- Prior to the introduction of setup dependencies in version 1.24 this+-- would have been _all_ dependencies.+nonSetupDeps :: Monoid a => ComponentDeps a -> a+nonSetupDeps = select (/= ComponentSetup)++-- | Library dependencies proper only.  (Includes dependencies+-- of internal libraries.)+libraryDeps :: Monoid a => ComponentDeps a -> a+libraryDeps = select (\c -> case c of ComponentSubLib _ -> True+                                      ComponentLib -> True+                                      _ -> False)++-- | Setup dependencies.+setupDeps :: Monoid a => ComponentDeps a -> a+setupDeps = select (== ComponentSetup)++-- | Select dependencies satisfying a given predicate.+select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a+select p = foldMap snd . filter (p . fst) . toList
+ cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.ConstraintSource+    ( ConstraintSource(..)+    , showConstraintSource+    ) where++import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..))++-- | Source of a 'PackageConstraint'.+data ConstraintSource =++  -- | Main config file, which is ~/.cabal/config by default.+  ConstraintSourceMainConfig FilePath++  -- | Local cabal.project file+  | ConstraintSourceProjectConfig FilePath++  -- | Sandbox config file, which is ./cabal.sandbox.config by default.+  | ConstraintSourceSandboxConfig FilePath++  -- | User config file, which is ./cabal.config by default.+  | ConstraintSourceUserConfig FilePath++  -- | Flag specified on the command line.+  | ConstraintSourceCommandlineFlag++  -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@+  -- implies @package==0.1.0.0@.+  | ConstraintSourceUserTarget++  -- | Internal requirement to use installed versions of packages like ghc-prim.+  | ConstraintSourceNonUpgradeablePackage++  -- | Internal requirement to use the add-source version of a package when that+  -- version is installed and the source is modified.+  | ConstraintSourceModifiedAddSourceDep++  -- | Internal constraint used by @cabal freeze@.+  | ConstraintSourceFreeze++  -- | Constraint specified by a config file, a command line flag, or a user+  -- target, when a more specific source is not known.+  | ConstraintSourceConfigFlagOrTarget++  -- | The source of the constraint is not specified.+  | ConstraintSourceUnknown++  -- | Custom setup requires a minimum lower bound on Cabal+  | ConstraintNewBuildCustomSetupLowerBoundCabal+  deriving (Eq, Show, Generic)++instance Binary ConstraintSource++-- | Description of a 'ConstraintSource'.+showConstraintSource :: ConstraintSource -> String+showConstraintSource (ConstraintSourceMainConfig path) =+    "main config " ++ path+showConstraintSource (ConstraintSourceProjectConfig path) =+    "project config " ++ path+showConstraintSource (ConstraintSourceSandboxConfig path) =+    "sandbox config " ++ path+showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path+showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"+showConstraintSource ConstraintSourceUserTarget = "user target"+showConstraintSource ConstraintSourceNonUpgradeablePackage =+    "non-upgradeable package"+showConstraintSource ConstraintSourceModifiedAddSourceDep =+    "modified add-source dependency"+showConstraintSource ConstraintSourceFreeze = "cabal freeze"+showConstraintSource ConstraintSourceConfigFlagOrTarget =+    "config file, command line flag, or user target"+showConstraintSource ConstraintSourceUnknown = "unknown source"+showConstraintSource ConstraintNewBuildCustomSetupLowerBoundCabal = "new-build's support of Custom Setup (issue #3932)"
+ cabal/cabal-install/Distribution/Solver/Types/DependencyResolver.hs view
@@ -0,0 +1,36 @@+module Distribution.Solver.Types.DependencyResolver+    ( DependencyResolver+    ) where++import Data.Set (Set)++import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb )+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.PackageIndex ( PackageIndex )+import Distribution.Solver.Types.Progress+import Distribution.Solver.Types.ResolverPackage+import Distribution.Solver.Types.SourcePackage++import Distribution.Simple.PackageIndex ( InstalledPackageIndex )+import Distribution.Package ( PackageName )+import Distribution.Compiler ( CompilerInfo )+import Distribution.System ( Platform )++-- | A dependency resolver is a function that works out an installation plan+-- given the set of installed and available packages and a set of deps to+-- solve for.+--+-- The reason for this interface is because there are dozens of approaches to+-- solving the package dependency problem and we want to make it easy to swap+-- in alternatives.+--+type DependencyResolver loc = Platform+                           -> CompilerInfo+                           -> InstalledPackageIndex+                           -> PackageIndex (SourcePackage loc)+                           -> PkgConfigDb+                           -> (PackageName -> PackagePreferences)+                           -> [LabeledPackageConstraint]+                           -> Set PackageName+                           -> Progress String String [ResolverPackage loc]
+ cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.InstSolverPackage +    ( InstSolverPackage(..)+    ) where++import Distribution.Compat.Binary (Binary(..))+import Distribution.Package ( Package(..), HasUnitId(..) )+import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )+import Distribution.Solver.Types.SolverId+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import GHC.Generics (Generic)++-- | An 'InstSolverPackage' is a pre-existing installed pacakge+-- specified by the dependency solver.+data InstSolverPackage = InstSolverPackage {+      instSolverPkgIPI :: InstalledPackageInfo,+      instSolverPkgLibDeps :: ComponentDeps [SolverId],+      instSolverPkgExeDeps :: ComponentDeps [SolverId]+    }+  deriving (Eq, Show, Generic)++instance Binary InstSolverPackage++instance Package InstSolverPackage where+    packageId = packageId . instSolverPkgIPI++instance HasUnitId InstSolverPackage where+    installedUnitId = installedUnitId . instSolverPkgIPI
+ cabal/cabal-install/Distribution/Solver/Types/InstalledPreference.hs view
@@ -0,0 +1,9 @@+module Distribution.Solver.Types.InstalledPreference+    ( InstalledPreference(..),+    ) where++-- | Whether we prefer an installed version of a package or simply the latest+-- version.+--+data InstalledPreference = PreferInstalled | PreferLatest+  deriving Show
+ cabal/cabal-install/Distribution/Solver/Types/LabeledPackageConstraint.hs view
@@ -0,0 +1,14 @@+module Distribution.Solver.Types.LabeledPackageConstraint+    ( LabeledPackageConstraint(..)+    , unlabelPackageConstraint+    ) where++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.PackageConstraint++-- | 'PackageConstraint' labeled with its source.+data LabeledPackageConstraint+   = LabeledPackageConstraint PackageConstraint ConstraintSource++unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint+unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc
+ cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Distribution.Solver.Types.OptionalStanza+    ( OptionalStanza(..)+    , enableStanzas+    ) where++import GHC.Generics (Generic)+import Data.Typeable+import Distribution.Compat.Binary (Binary(..))+import Distribution.Types.ComponentRequestedSpec+            (ComponentRequestedSpec(..), defaultComponentRequestedSpec)+import Data.List (foldl')++data OptionalStanza+    = TestStanzas+    | BenchStanzas+  deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable)++-- | Convert a list of 'OptionalStanza' into the corresponding+-- 'ComponentRequestedSpec' which records what components are enabled.+enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec+enableStanzas = foldl' addStanza defaultComponentRequestedSpec+  where+    addStanza enabled TestStanzas  = enabled { testsRequested = True }+    addStanza enabled BenchStanzas = enabled { benchmarksRequested = True }++instance Binary OptionalStanza
+ cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.PackageConstraint (+    PackageConstraint(..),+    showPackageConstraint,+  ) where++import Distribution.Compat.Binary (Binary(..))+import Distribution.PackageDescription (FlagAssignment, unFlagName)+import Distribution.Package (PackageName)+import Distribution.Solver.Types.OptionalStanza+import Distribution.Text (display)+import Distribution.Version (VersionRange, simplifyVersionRange)+import GHC.Generics (Generic)++-- | Per-package constraints. Package constraints must be respected by the+-- solver. Multiple constraints for each package can be given, though obviously+-- it is possible to construct conflicting constraints (eg impossible version+-- range or inconsistent flag assignment).+--+data PackageConstraint+   = PackageConstraintVersion   PackageName VersionRange+   | PackageConstraintInstalled PackageName+   | PackageConstraintSource    PackageName+   | PackageConstraintFlags     PackageName FlagAssignment+   | PackageConstraintStanzas   PackageName [OptionalStanza]+  deriving (Eq, Show, Generic)++instance Binary PackageConstraint++-- | Provide a textual representation of a package constraint+-- for debugging purposes.+--+showPackageConstraint :: PackageConstraint -> String+showPackageConstraint (PackageConstraintVersion pn vr) =+  display pn ++ " " ++ display (simplifyVersionRange vr)+showPackageConstraint (PackageConstraintInstalled pn) =+  display pn ++ " installed"+showPackageConstraint (PackageConstraintSource pn) =+  display pn ++ " source"+showPackageConstraint (PackageConstraintFlags pn fs) =+  "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs)+  where+    showFlag f True  = "+" ++ unFlagName f+    showFlag f False = "-" ++ unFlagName f+showPackageConstraint (PackageConstraintStanzas pn ss) =+  "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss)+  where+    showStanza TestStanzas  = "test"+    showStanza BenchStanzas = "bench"
+ cabal/cabal-install/Distribution/Solver/Types/PackageFixedDeps.hs view
@@ -0,0 +1,23 @@+module Distribution.Solver.Types.PackageFixedDeps+    ( PackageFixedDeps(..)+    ) where++import           Distribution.InstalledPackageInfo ( InstalledPackageInfo )+import           Distribution.Package+                   ( Package(..), UnitId, installedDepends)+import           Distribution.Solver.Types.ComponentDeps ( ComponentDeps )+import qualified Distribution.Solver.Types.ComponentDeps as CD++-- | Subclass of packages that have specific versioned dependencies.+--+-- So for example a not-yet-configured package has dependencies on version+-- ranges, not specific versions. A configured or an already installed package+-- depends on exact versions. Some operations or data structures (like+--  dependency graphs) only make sense on this subclass of package types.+--+class Package pkg => PackageFixedDeps pkg where+  depends :: pkg -> ComponentDeps [UnitId]++instance PackageFixedDeps InstalledPackageInfo where+  depends pkg = CD.fromInstalled (installedDepends pkg)+
+ cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Solver.Types.PackageIndex+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- An index of packages.+--+module Distribution.Solver.Types.PackageIndex (+  -- * Package index data type+  PackageIndex,++  -- * Creating an index+  fromList,++  -- * Updates+  merge,+  insert,+  deletePackageName,+  deletePackageId,+  deleteDependency,++  -- * Queries++  -- ** Precise lookups+  elemByPackageId,+  elemByPackageName,+  lookupPackageName,+  lookupPackageId,+  lookupDependency,++  -- ** Case-insensitive searches+  searchByName,+  SearchResult(..),+  searchByNameSubstring,++  -- ** Bulk queries+  allPackages,+  allPackagesByName,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (lookup)++import Control.Exception (assert)+import qualified Data.Map as Map+import Data.List (groupBy, isInfixOf)++import Distribution.Package+         ( PackageName, unPackageName, PackageIdentifier(..)+         , Package(..), packageName, packageVersion+         , Dependency(Dependency) )+import Distribution.Version+         ( withinRange )+import Distribution.Simple.Utils+         ( lowercase, comparing )+++-- | The collection of information about packages from one or more 'PackageDB's.+--+-- It can be searched efficiently by package name and version.+--+newtype PackageIndex pkg = PackageIndex+  -- This index package names to all the package records matching that package+  -- name case-sensitively. It includes all versions.+  --+  -- This allows us to find all versions satisfying a dependency.+  -- Most queries are a map lookup followed by a linear scan of the bucket.+  --+  (Map PackageName [pkg])++  deriving (Eq, Show, Read, Functor, Generic)+--FIXME: the Functor instance here relies on no package id changes++instance Package pkg => Semigroup (PackageIndex pkg) where+  (<>) = merge++instance Package pkg => Monoid (PackageIndex pkg) where+  mempty  = PackageIndex Map.empty+  mappend = (<>)+  --save one mappend with empty in the common case:+  mconcat [] = mempty+  mconcat xs = foldr1 mappend xs++instance Binary pkg => Binary (PackageIndex pkg)++invariant :: Package pkg => PackageIndex pkg -> Bool+invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)+  where+    goodBucket _    [] = False+    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0+      where+        check pkgid []          = packageName pkgid == name+        check pkgid (pkg':pkgs) = packageName pkgid == name+                               && pkgid < pkgid'+                               && check pkgid' pkgs+          where pkgid' = packageId pkg'++--+-- * Internal helpers+--++mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg+mkPackageIndex index = assert (invariant (PackageIndex index))+                                         (PackageIndex index)++internalError :: String -> a+internalError name = error ("PackageIndex." ++ name ++ ": internal error")++-- | Lookup a name in the index to get all packages that match that name+-- case-sensitively.+--+lookup :: PackageIndex pkg -> PackageName -> [pkg]+lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m++--+-- * Construction+--++-- | Build an index out of a bunch of packages.+--+-- If there are duplicates, later ones mask earlier ones.+--+fromList :: Package pkg => [pkg] -> PackageIndex pkg+fromList pkgs = mkPackageIndex+              . Map.map fixBucket+              . Map.fromListWith (++)+              $ [ (packageName pkg, [pkg])+                | pkg <- pkgs ]+  where+    fixBucket = -- out of groups of duplicates, later ones mask earlier ones+                -- but Map.fromListWith (++) constructs groups in reverse order+                map head+                -- Eq instance for PackageIdentifier is wrong, so use Ord:+              . groupBy (\a b -> EQ == comparing packageId a b)+                -- relies on sortBy being a stable sort so we+                -- can pick consistently among duplicates+              . sortBy (comparing packageId)++--+-- * Updates+--++-- | Merge two indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+merge i1@(PackageIndex m1) i2@(PackageIndex m2) =+  assert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)++-- | Elements in the second list mask those in the first.+mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]+mergeBuckets []     ys     = ys+mergeBuckets xs     []     = xs+mergeBuckets xs@(x:xs') ys@(y:ys') =+      case packageId x `compare` packageId y of+        GT -> y : mergeBuckets xs  ys'+        EQ -> y : mergeBuckets xs' ys'+        LT -> x : mergeBuckets xs' ys++-- | Inserts a single package into the index.+--+-- This is equivalent to (but slightly quicker than) using 'mappend' or+-- 'merge' with a singleton index.+--+insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg+insert pkg (PackageIndex index) = mkPackageIndex $+  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index+  where+    pkgid = packageId pkg+    insertNoDup []                = [pkg]+    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of+      LT -> pkg  : pkgs+      EQ -> pkg  : pkgs'+      GT -> pkg' : insertNoDup pkgs'++-- | Internal delete helper.+--+delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg+delete name p (PackageIndex index) = mkPackageIndex $+  Map.update filterBucket name index+  where+    filterBucket = deleteEmptyBucket+                 . filter (not . p)+    deleteEmptyBucket []        = Nothing+    deleteEmptyBucket remaining = Just remaining++-- | Removes a single package from the index.+--+deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg+deletePackageId pkgid =+  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)++-- | Removes all packages with this (case-sensitive) name from the index.+--+deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg+deletePackageName name =+  delete name (\pkg -> packageName pkg == name)++-- | Removes all packages satisfying this dependency from the index.+--+deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg+deleteDependency (Dependency name verstionRange) =+  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)++--+-- * Bulk queries+--++-- | Get all the packages from the index.+--+allPackages :: PackageIndex pkg -> [pkg]+allPackages (PackageIndex m) = concat (Map.elems m)++-- | Get all the packages from the index.+--+-- They are grouped by package name, case-sensitively.+--+allPackagesByName :: PackageIndex pkg -> [[pkg]]+allPackagesByName (PackageIndex m) = Map.elems m++--+-- * Lookups+--++elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool+elemByPackageId index = isJust . lookupPackageId index++elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool+elemByPackageName index = not . null . lookupPackageName index+++-- | Does a lookup by package id (name & version).+--+-- Since multiple package DBs mask each other case-sensitively by package name,+-- then we get back at most one package.+--+lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg+lookupPackageId index pkgid =+  case [ pkg | pkg <- lookup index (packageName pkgid)+             , packageId pkg == pkgid ] of+    []    -> Nothing+    [pkg] -> Just pkg+    _     -> internalError "lookupPackageIdentifier"++-- | Does a case-sensitive search by package name.+--+lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookupPackageName index name =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name ]++-- | Does a case-sensitive search by package name and a range of versions.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]+lookupDependency index (Dependency name versionRange) =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name+        , packageVersion pkg `withinRange` versionRange ]++--+-- * Case insensitive name lookups+--++-- | Does a case-insensitive search by package name.+--+-- If there is only one package that compares case-insensitively to this name+-- then the search is unambiguous and we get back all versions of that package.+-- If several match case-insensitively but one matches exactly then it is also+-- unambiguous.+--+-- If however several match case-insensitively and none match exactly then we+-- have an ambiguous result, and we get back all the versions of all the+-- packages. The list of ambiguous results is split by exact package name. So+-- it is a non-empty list of non-empty lists.+--+searchByName :: PackageIndex pkg+             -> String -> [(PackageName, [pkg])]+searchByName (PackageIndex m) name =+    [ pkgs+    | pkgs@(pname,_) <- Map.toList m+    , lowercase (unPackageName pname) == lname ]+  where+    lname = lowercase name++data SearchResult a = None | Unambiguous a | Ambiguous [a]++-- | Does a case-insensitive substring search by package name.+--+-- That is, all packages that contain the given string in their name.+--+searchByNameSubstring :: PackageIndex pkg+                      -> String -> [(PackageName, [pkg])]+searchByNameSubstring (PackageIndex m) searchterm =+    [ pkgs+    | pkgs@(pname, _) <- Map.toList m+    , lsearchterm `isInfixOf` lowercase (unPackageName pname) ]+  where+    lsearchterm = lowercase searchterm
+ cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs view
@@ -0,0 +1,99 @@+module Distribution.Solver.Types.PackagePath+    ( PackagePath(..)+    , Namespace(..)+    , Qualifier(..)+    , QPN+    , Qualified(..)+    , showQPN+    ) where++import Distribution.Package+import Distribution.Text++-- | A package path consists of a namespace and a package path inside that+-- namespace.+data PackagePath = PackagePath Namespace Qualifier+  deriving (Eq, Ord, Show)++-- | Top-level namespace+--+-- Package choices in different namespaces are considered completely independent+-- by the solver.+data Namespace =+    -- | The default namespace+    DefaultNamespace++    -- | Independent namespace+    --+    -- For now we just number these (rather than giving them more structure).+  | Independent Int+  deriving (Eq, Ord, Show)++-- | Qualifier of a package within a namespace (see 'PackagePath')+data Qualifier =+    -- | Top-level dependency in this namespace+    Unqualified++    -- | Any dependency on base is considered independent+    --+    -- This makes it possible to have base shims.+  | Base PackageName++    -- | Setup dependency+    --+    -- By rights setup dependencies ought to be nestable; after all, the setup+    -- dependencies of a package might themselves have setup dependencies, which+    -- are independent from everything else. However, this very quickly leads to+    -- infinite search trees in the solver. Therefore we limit ourselves to+    -- a single qualifier (within a given namespace).+  | Setup PackageName++    -- | If we depend on an executable from a package (via+    -- @build-tools@), we should solve for the dependencies of that+    -- package separately (since we're not going to actually try to+    -- link it.)  We qualify for EACH package separately; e.g.,+    -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on+    -- @pn2@ from package @pn1@.  (If we tracked only @pn1@, that+    -- would require a consistent dependency resolution for all+    -- of the depended upon executables from a package; if we+    -- tracked only @pn2@, that would require us to pick only one+    -- version of an executable over the entire install plan.)+  | Exe PackageName PackageName+  deriving (Eq, Ord, Show)++-- | String representation of a package path.+--+-- NOTE: The result of 'showPP' is either empty or results in a period, so that+-- it can be prepended to a package name.+showPP :: PackagePath -> String+showPP (PackagePath ns q) =+    case ns of+      DefaultNamespace -> go q+      Independent i    -> show i ++ "." ++ go q+  where+    -- Print the qualifier+    --+    -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is+    -- there to make sure different dependencies on base are all independent.+    -- So we want to print something like @"A.base"@, where the @"A."@ part+    -- is the qualifier and @"base"@ is the actual dependency (which, for the+    -- 'Base' qualifier, will always be @base@).+    go Unqualified = ""+    go (Setup pn)  = display pn ++ "-setup."+    go (Exe   pn pn2) = display pn ++ "-" ++ display pn2 ++ "-exe."+    go (Base  pn)  = display pn ++ "."++-- | A qualified entity. Pairs a package path with the entity.+data Qualified a = Q PackagePath a+  deriving (Eq, Ord, Show)++-- | Standard string representation of a qualified entity.+showQ :: (a -> String) -> (Qualified a -> String)+showQ showa (Q pp x) = showPP pp ++ showa x++-- | Qualified package name.+type QPN = Qualified PackageName++-- | String representation of a qualified package path.+showQPN :: QPN -> String+showQPN = showQ display
+ cabal/cabal-install/Distribution/Solver/Types/PackagePreferences.hs view
@@ -0,0 +1,22 @@+module Distribution.Solver.Types.PackagePreferences+    ( PackagePreferences(..)+    ) where++import Distribution.Solver.Types.InstalledPreference+import Distribution.Solver.Types.OptionalStanza+import Distribution.Version (VersionRange)++-- | Per-package preferences on the version. It is a soft constraint that the+-- 'DependencyResolver' should try to respect where possible. It consists of+-- an 'InstalledPreference' which says if we prefer versions of packages+-- that are already installed. It also has (possibly multiple)+-- 'PackageVersionPreference's which are suggested constraints on the version+-- number. The resolver should try to use package versions that satisfy+-- the maximum number of the suggested version constraints.+--+-- It is not specified if preferences on some packages are more important than+-- others.+--+data PackagePreferences = PackagePreferences [VersionRange]+                                             InstalledPreference+                                             [OptionalStanza]
+ cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Solver.Types.PkgConfigDb+-- Copyright   :  (c) Iñaki García Etxebarria 2016+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Read the list of packages available to pkg-config.+-----------------------------------------------------------------------------+module Distribution.Solver.Types.PkgConfigDb+    ( PkgConfigDb+    , readPkgConfigDb+    , pkgConfigDbFromList+    , pkgConfigPkgIsPresent+    , pkgConfigDbPkgVersion+    , getPkgConfigDbDirs+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Control.Exception (IOException, handle)+import qualified Data.Map as M+import Data.Version (parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S)+import System.FilePath (splitSearchPath)++import Distribution.Package+    ( PkgconfigName, mkPkgconfigName )+import Distribution.Verbosity+    ( Verbosity )+import Distribution.Version+    ( Version, mkVersion', VersionRange, withinRange )++import Distribution.Compat.Environment+    ( lookupEnv )+import Distribution.Simple.Program+    ( ProgramDb, pkgConfigProgram, getProgramOutput, requireProgram )+import Distribution.Simple.Utils+    ( info )++-- | The list of packages installed in the system visible to+-- @pkg-config@. This is an opaque datatype, to be constructed with+-- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`.+data PkgConfigDb =  PkgConfigDb (M.Map PkgconfigName (Maybe Version))+                 -- ^ If an entry is `Nothing`, this means that the+                 -- package seems to be present, but we don't know the+                 -- exact version (because parsing of the version+                 -- number failed).+                 | NoPkgConfigDb+                 -- ^ For when we could not run pkg-config successfully.+     deriving (Show, Generic, Typeable)++instance Binary PkgConfigDb++-- | Query pkg-config for the list of installed packages, together+-- with their versions. Return a `PkgConfigDb` encapsulating this+-- information.+readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb+readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do+  (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb+  pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]+  -- The output of @pkg-config --list-all@ also includes a description+  -- for each package, which we do not need.+  let pkgNames = map (takeWhile (not . isSpace)) pkgList+  pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig+                             ("--modversion" : pkgNames)+  (return . pkgConfigDbFromList . zip pkgNames) pkgVersions+      where+        -- For when pkg-config invocation fails (possibly because of a+        -- too long command line).+        ioErrorHandler :: IOException -> IO PkgConfigDb+        ioErrorHandler e = do+          info verbosity ("Failed to query pkg-config, Cabal will continue"+                          ++ " without solving for pkg-config constraints: "+                          ++ show e)+          return NoPkgConfigDb++-- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs.+pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb+pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs+    where+      convert :: (String, String) -> (PkgconfigName, Maybe Version)+      convert (n,vs) = (mkPkgconfigName n,+                        case (reverse . readP_to_S parseVersion) vs of+                          (v, "") : _ -> Just (mkVersion' v)+                          _           -> Nothing -- Version not (fully)+                                                 -- understood.+                       )++-- | Check whether a given package range is satisfiable in the given+-- @pkg-config@ database.+pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> VersionRange -> Bool+pkgConfigPkgIsPresent (PkgConfigDb db) pn vr =+    case M.lookup pn db of+      Nothing       -> False    -- Package not present in the DB.+      Just Nothing  -> True     -- Package present, but version unknown.+      Just (Just v) -> withinRange v vr+-- If we could not read the pkg-config database successfully we allow+-- the check to succeed. The plan found by the solver may fail to be+-- executed later on, but we have no grounds for rejecting the plan at+-- this stage.+pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True+++-- | Query the version of a package in the @pkg-config@ database.+-- @Nothing@ indicates the package is not in the database, while+-- @Just Nothing@ indicates that the package is in the database,+-- but its version is not known.+pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe Version)+pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db+-- NB: Since the solver allows solving to succeed if there is+-- NoPkgConfigDb, we should report that we *guess* that there+-- is a matching pkg-config configuration, but that we just+-- don't know about it.+pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing+++-- | Query pkg-config for the locations of pkg-config's package files. Use this+-- to monitor for changes in the pkg-config DB.+--+getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath]+getPkgConfigDbDirs verbosity progdb =+    (++) <$> getEnvPath <*> getDefPath+ where+    -- According to @man pkg-config@:+    --+    -- PKG_CONFIG_PATH+    -- A  colon-separated  (on Windows, semicolon-separated) list of directories+    -- to search for .pc files.  The default directory will always be searched+    -- after searching the path+    --+    getEnvPath = maybe [] parseSearchPath+             <$> lookupEnv "PKG_CONFIG_PATH"++    -- Again according to @man pkg-config@:+    --+    -- pkg-config can be used to query itself for the default search path,+    -- version number and other information, for instance using:+    --+    -- > pkg-config --variable pc_path pkg-config+    --+    getDefPath = handle ioErrorHandler $ do+      (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb+      parseSearchPath <$>+        getProgramOutput verbosity pkgConfig+                         ["--variable", "pc_path", "pkg-config"]++    parseSearchPath str =+      case lines str of+        [p] | not (null p) -> splitSearchPath p+        _                  -> []++    ioErrorHandler :: IOException -> IO [FilePath]+    ioErrorHandler _e = return []
+ cabal/cabal-install/Distribution/Solver/Types/Progress.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Types.Progress+    ( Progress(..)+    , foldProgress+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (fail)++-- | A type to represent the unfolding of an expensive long running+-- calculation that may fail. We may get intermediate steps before the final+-- result which may be used to indicate progress and\/or logging messages.+--+data Progress step fail done = Step step (Progress step fail done)+                             | Fail fail+                             | Done done+  deriving (Functor)++-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two+-- base cases, one for a final result and one for failure.+--+-- Eg to convert into a simple 'Either' result use:+--+-- > foldProgress (flip const) Left Right+--+foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)+             -> Progress step fail done -> a+foldProgress step fail done = fold+  where fold (Step s p) = step s (fold p)+        fold (Fail f)   = fail f+        fold (Done r)   = done r++instance Monad (Progress step fail) where+  return   = pure+  p >>= f  = foldProgress Step Fail f p++instance Applicative (Progress step fail) where+  pure a  = Done a+  p <*> x = foldProgress Step Fail (flip fmap x) p++instance Monoid fail => Alternative (Progress step fail) where+  empty   = Fail mempty+  p <|> q = foldProgress Step (const q) Done p
+ cabal/cabal-install/Distribution/Solver/Types/ResolverPackage.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.ResolverPackage+    ( ResolverPackage(..)+    , resolverPackageLibDeps+    , resolverPackageExeDeps+    ) where++import Distribution.Solver.Types.InstSolverPackage+import Distribution.Solver.Types.SolverId+import Distribution.Solver.Types.SolverPackage+import qualified Distribution.Solver.Types.ComponentDeps as CD++import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Graph (IsNode(..))+import Distribution.Package (Package(..), HasUnitId(..))+import Distribution.Simple.Utils (ordNub)+import GHC.Generics (Generic)++-- | The dependency resolver picks either pre-existing installed packages+-- or it picks source packages along with package configuration.+--+-- This is like the 'InstallPlan.PlanPackage' but with fewer cases.+--+data ResolverPackage loc = PreExisting InstSolverPackage+                         | Configured  (SolverPackage loc)+  deriving (Eq, Show, Generic)++instance Binary loc => Binary (ResolverPackage loc)++instance Package (ResolverPackage loc) where+  packageId (PreExisting ipkg)     = packageId ipkg+  packageId (Configured  spkg)     = packageId spkg++resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]+resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg+resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg++resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]+resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg+resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg++instance IsNode (ResolverPackage loc) where+  type Key (ResolverPackage loc) = SolverId+  nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg)+  nodeKey (Configured spkg) = PlannedId (packageId spkg)+  -- Use dependencies for ALL components+  nodeNeighbors pkg =+    ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) +++             CD.flatDeps (resolverPackageExeDeps pkg)
+ cabal/cabal-install/Distribution/Solver/Types/Settings.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Distribution.Solver.Types.Settings+    ( ReorderGoals(..)+    , IndependentGoals(..)+    , AvoidReinstalls(..)+    , ShadowPkgs(..)+    , StrongFlags(..)+    , EnableBackjumping(..)+    , CountConflicts(..)+    , SolveExecutables(..)+    ) where++import Distribution.Simple.Setup ( BooleanFlag(..) )+import Distribution.Compat.Binary (Binary(..))+import GHC.Generics (Generic)++newtype ReorderGoals = ReorderGoals Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype CountConflicts = CountConflicts Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype IndependentGoals = IndependentGoals Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype AvoidReinstalls = AvoidReinstalls Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype ShadowPkgs = ShadowPkgs Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype StrongFlags = StrongFlags Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype EnableBackjumping = EnableBackjumping Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype SolveExecutables = SolveExecutables Bool+  deriving (BooleanFlag, Eq, Generic, Show)++instance Binary ReorderGoals+instance Binary CountConflicts+instance Binary IndependentGoals+instance Binary AvoidReinstalls+instance Binary ShadowPkgs+instance Binary StrongFlags+instance Binary SolveExecutables
+ cabal/cabal-install/Distribution/Solver/Types/SolverId.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.SolverId+    ( SolverId(..)+    )++where++import Distribution.Compat.Binary (Binary(..))+import Distribution.Package (PackageId, Package(..), UnitId)+import GHC.Generics (Generic)++-- | The solver can produce references to existing packages or+-- packages we plan to install.  Unlike 'ConfiguredId' we don't+-- yet know the 'UnitId' for planned packages, because it's+-- not the solver's job to compute them.+--+data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId }+              | PlannedId     { solverSrcId :: PackageId }+  deriving (Eq, Ord, Generic)++instance Binary SolverId++instance Show SolverId where+    show = show . solverSrcId++instance Package SolverId where+  packageId = solverSrcId
+ cabal/cabal-install/Distribution/Solver/Types/SolverPackage.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.SolverPackage+    ( SolverPackage(..)+    ) where++import Distribution.Compat.Binary (Binary(..))+import Distribution.Package ( Package(..) )+import Distribution.PackageDescription ( FlagAssignment )+import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.SolverId+import Distribution.Solver.Types.SourcePackage+import GHC.Generics (Generic)++-- | A 'SolverPackage' is a package specified by the dependency solver.+-- It will get elaborated into a 'ConfiguredPackage' or even an+-- 'ElaboratedConfiguredPackage'.+--+-- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc',+-- but for symmetry we have the parameter.  (Maybe it can be removed.)+--+data SolverPackage loc = SolverPackage {+        solverPkgSource :: SourcePackage loc,+        solverPkgFlags :: FlagAssignment,+        solverPkgStanzas :: [OptionalStanza],+        solverPkgLibDeps :: ComponentDeps [SolverId],+        solverPkgExeDeps :: ComponentDeps [SolverId]+    }+  deriving (Eq, Show, Generic)++instance Binary loc => Binary (SolverPackage loc)++instance Package (SolverPackage loc) where+  packageId = packageId . solverPkgSource
+ cabal/cabal-install/Distribution/Solver/Types/SourcePackage.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Distribution.Solver.Types.SourcePackage+    ( PackageDescriptionOverride+    , SourcePackage(..)+    ) where++import Distribution.Package+         ( PackageId, Package(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(..) )++import Data.ByteString.Lazy (ByteString)+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..))+import Data.Typeable++-- | A package description along with the location of the package sources.+--+data SourcePackage loc = SourcePackage {+    packageInfoId        :: PackageId,+    packageDescription   :: GenericPackageDescription,+    packageSource        :: loc,+    packageDescrOverride :: PackageDescriptionOverride+  }+  deriving (Eq, Show, Generic, Typeable)++instance (Binary loc) => Binary (SourcePackage loc)++instance Package (SourcePackage a) where packageId = packageInfoId++-- | We sometimes need to override the .cabal file in the tarball with+-- the newer one from the package index.+type PackageDescriptionOverride = Maybe ByteString
+ cabal/cabal-install/Distribution/Solver/Types/Variable.hs view
@@ -0,0 +1,14 @@+module Distribution.Solver.Types.Variable where++import Distribution.Solver.Types.OptionalStanza++import Distribution.PackageDescription (FlagName)++-- | Variables used by the dependency solver. This type is similar to the+-- internal 'Var' type, except that flags and stanzas are associated with+-- package names instead of package instances.+data Variable qpn =+    PackageVar qpn+  | FlagVar qpn FlagName+  | StanzaVar qpn OptionalStanza+  deriving Eq
cabal/cabal-install/LICENSE view
@@ -1,8 +1,5 @@-Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren,-                         Bjorn Bringert, Krasimir Angelov,-                         Malcolm Wallace, Ross Patterson,-                         Lemmih, Paolo Martini, Don Stewart,-                         Duncan Coutts+Copyright (c) 2003-2016, Cabal Development Team.+See the AUTHORS file for the full list of copyright holders. All rights reserved.  Redistribution and use in source and binary forms, with or without
cabal/cabal-install/Main.hs view
@@ -19,6 +19,8 @@          ( GlobalFlags(..), globalCommand, withRepoContext          , ConfigFlags(..)          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand+         , reconfigureCommand+         , configCompilerAux', configPackageDB'          , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)          , buildCommand, replCommand, testCommand, benchmarkCommand          , InstallFlags(..), defaultInstallFlags@@ -46,7 +48,8 @@          , manpageCommand          ) import Distribution.Simple.Setup-         ( HaddockFlags(..), haddockCommand, defaultHaddockFlags+         ( HaddockTarget(..)+         , HaddockFlags(..), haddockCommand, defaultHaddockFlags          , HscolourFlags(..), hscolourCommand          , ReplFlags(..)          , CopyFlags(..), copyCommand@@ -57,6 +60,9 @@          , configAbsolutePaths          ) +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)+ import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config@@ -67,13 +73,14 @@ import qualified Distribution.Client.List as List          ( list, info ) ---TODO: temporary import, just to force these modules to be built.--- It will be replaced by import of new build command once merged.-import Distribution.Client.ProjectPlanning ()-import Distribution.Client.ProjectBuilding ()+import qualified Distribution.Client.CmdConfigure as CmdConfigure+import qualified Distribution.Client.CmdBuild     as CmdBuild+import qualified Distribution.Client.CmdRepl      as CmdRepl+import qualified Distribution.Client.CmdFreeze    as CmdFreeze+import qualified Distribution.Client.CmdHaddock   as CmdHaddock  import Distribution.Client.Install            (install)-import Distribution.Client.Configure          (configure)+import Distribution.Client.Configure          (configure, writeConfigFlags) import Distribution.Client.Update             (update) import Distribution.Client.Exec               (exec) import Distribution.Client.Fetch              (fetch)@@ -85,6 +92,7 @@ import Distribution.Client.Run                (run, splitRunArgs) import Distribution.Client.SrcDist            (sdist) import Distribution.Client.Get                (get)+import Distribution.Client.Reconfigure        (Check(..), reconfigure) import Distribution.Client.Sandbox            (sandboxInit                                               ,sandboxAddSource                                               ,sandboxDelete@@ -93,25 +101,18 @@                                               ,sandboxHcPkg                                               ,dumpPackageEnvironment -                                              ,getSandboxConfigFilePath                                               ,loadConfigOrSandboxConfig                                               ,findSavedDistPref                                               ,initPackageDBIfNeeded                                               ,maybeWithSandboxDirOnSearchPath                                               ,maybeWithSandboxPackageInfo-                                              ,WereDepsReinstalled(..)-                                              ,maybeReinstallAddSourceDeps                                               ,tryGetIndexFilePath                                               ,sandboxBuildDir                                               ,updateSandboxConfigFileFlag                                               ,updateInstallDirs -                                              ,configCompilerAux'-                                              ,getPersistOrConfigCompiler-                                              ,configPackageDB')-import Distribution.Client.Sandbox.PackageEnvironment-                                              (setPackageDB-                                              ,userPackageEnvironmentFile)+                                              ,getPersistOrConfigCompiler)+import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord) import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox) import Distribution.Client.Tar                (createTarGzFile)@@ -123,7 +124,7 @@ #if defined(mingw32_HOST_OS)                                               ,relaxEncodingErrors #endif-                                              ,existsAndIsMoreRecentThan)+                                              )  import Distribution.Package (packageId) import Distribution.PackageDescription@@ -139,33 +140,32 @@ import Distribution.Simple.Command          ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)          , CommandType(..), commandsRun, commandAddAction, hiddenCommand-         , commandFromSpec)-import Distribution.Simple.Compiler-         ( Compiler(..) )+         , commandFromSpec, commandShowOptions )+import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) import Distribution.Simple.Configure-         ( checkPersistBuildConfigOutdated, configCompilerAuxEx-         , ConfigStateFileError(..), localBuildInfoFile-         , getPersistBuildConfig, tryGetPersistBuildConfig )+         ( configCompilerAuxEx, ConfigStateFileError(..)+         , getPersistBuildConfig, interpretPackageDbFlags+         , tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Program (defaultProgramConfiguration+import Distribution.Simple.Program (defaultProgramDb                                    ,configureAllKnownPrograms                                    ,simpleProgramInvocation                                    ,getProgramInvocationOutput) import Distribution.Simple.Program.Db (reconfigurePrograms) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils-         ( cabalVersion, die, notice, info, topHandler+         ( cabalVersion, die, info, notice, topHandler          , findPackageDesc, tryFindPackageDesc ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity          ( Verbosity, normal ) import Distribution.Version-         ( Version(..), orLaterVersion )+         ( Version, mkVersion, orLaterVersion ) import qualified Paths_cabal_install (version)  import System.Environment       (getArgs, getProgName)-import System.Exit              (exitFailure)+import System.Exit              (exitFailure, exitSuccess) import System.FilePath          ( dropExtension, splitExtension                                 , takeExtension, (</>), (<.>)) import System.IO                ( BufferMode(LineBuffering), hSetBuffering@@ -174,13 +174,9 @@ #endif                                 , stdout ) import System.Directory         (doesFileExist, getCurrentDirectory)-import Data.List                (intercalate)-import Data.Maybe               (listToMaybe)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid              (Monoid(..))-import Control.Applicative      (pure, (<$>))-#endif-import Control.Monad            (when, unless)+import Data.Monoid              (Any(..))+import Control.Exception        (SomeException(..), try)+import Control.Monad            (mapM_)  -- | Entry point --@@ -257,6 +253,7 @@       , regularCmd runCommand runAction       , regularCmd initCommand initAction       , regularCmd configureExCommand configureAction+      , regularCmd reconfigureCommand reconfigureAction       , regularCmd buildCommand buildAction       , regularCmd replCommand replAction       , regularCmd sandboxCommand sandboxAction@@ -276,6 +273,12 @@       , hiddenCmd  win32SelfUpgradeCommand win32SelfUpgradeAction       , hiddenCmd  actAsSetupCommand actAsSetupAction       , hiddenCmd  manpageCommand (manpageAction commandSpecs)++      , regularCmd  CmdConfigure.configureCommand CmdConfigure.configureAction+      , regularCmd  CmdBuild.buildCommand         CmdBuild.buildAction+      , regularCmd  CmdRepl.replCommand           CmdRepl.replAction+      , regularCmd  CmdFreeze.freezeCommand       CmdFreeze.freezeAction+      , regularCmd  CmdHaddock.haddockCommand     CmdHaddock.haddockAction       ]  type Action = GlobalFlags -> IO ()@@ -305,7 +308,8 @@   commandAddAction command     { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do     let verbosity = fromFlagOrDefault normal (verbosityFlag flags)-    (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+    load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+    let config = either (\(SomeException _) -> mempty) snd load     distPref <- findSavedDistPref config (distPrefFlag flags)     let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }     setupWrapper verbosity setupScriptOptions Nothing@@ -319,10 +323,11 @@   (useSandbox, config) <- fmap                           (updateInstallDirs (configUserInstall configFlags))                           (loadConfigOrSandboxConfig verbosity globalFlags)+  distPref <- findSavedDistPref config (configDistPref configFlags)   let configFlags'   = savedConfigureFlags   config `mappend` configFlags       configExFlags' = savedConfigureExFlags config `mappend` configExFlags       globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAuxEx configFlags'+  (comp, platform, progdb) <- configCompilerAuxEx configFlags'    -- If we're working inside a sandbox and the user has set the -w option, we   -- may need to create a sandbox-local package DB for this compiler and add a@@ -332,8 +337,17 @@         (UseSandbox sandboxDir) -> setPackageDB sandboxDir                                    comp platform configFlags' +  writeConfigFlags verbosity distPref (configFlags'', configExFlags')++  -- What package database(s) to use+  let packageDBs :: PackageDBStack+      packageDBs+        = interpretPackageDbFlags+          (fromFlag (configUserInstall configFlags''))+          (configPackageDBs configFlags'')+   whenUsingSandbox useSandbox $ \sandboxDir -> do-    initPackageDBIfNeeded verbosity configFlags'' comp conf+    initPackageDBIfNeeded verbosity configFlags'' comp progdb     -- NOTE: We do not write the new sandbox package DB location to     -- 'cabal.sandbox.config' here because 'configure -w' must not affect     -- subsequent 'install' (for UI compatibility with non-sandboxed mode).@@ -344,26 +358,52 @@    maybeWithSandboxDirOnSearchPath useSandbox $    withRepoContext verbosity globalFlags' $ \repoContext ->-    configure verbosity-              (configPackageDB' configFlags'')-              repoContext-              comp platform conf configFlags'' configExFlags' extraArgs+    configure verbosity packageDBs repoContext+              comp platform progdb configFlags'' configExFlags' extraArgs +reconfigureAction :: (ConfigFlags, ConfigExFlags)+                  -> [String] -> Action+reconfigureAction flags _ globalFlags = do+  let (configFlags, _) = flags+      verbosity = fromFlag (configVerbosity configFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  dist <- findSavedDistPref config (configDistPref configFlags)+  let checkFlags = Check $ \_ saved -> do+        let flags' = saved <> flags+        unless (saved == flags') $ info verbosity message+        pure (Any True, flags')+        where+          -- This message is correct, but not very specific: it will list all+          -- of the new flags, even if some have not actually changed. The+          -- *minimal* set of changes is more difficult to determine.+          message =+            "flags changed: "+            ++ unwords (commandShowOptions configureExCommand flags)+  _ <-+    reconfigure configureAction+    verbosity dist useSandbox DontSkipAddSourceDepsCheck NoFlag+    checkFlags [] globalFlags config+  pure ()+ buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)       noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck                     (buildOnly buildExFlags) +  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (buildDistPref buildFlags)+   -- Calls 'configureAction' to do the real work, so nothing special has to be   -- done to support sandboxes.-  (useSandbox, config, distPref) <- reconfigure verbosity-                                    (buildDistPref buildFlags)-                                    mempty [] globalFlags noAddSource-                                    (buildNumJobs buildFlags) (const Nothing)+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    mempty [] globalFlags config +   maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags extraArgs+    build verbosity config' distPref buildFlags extraArgs   -- | Actually do the work of building the package. This is separate from@@ -372,9 +412,9 @@ build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () build verbosity config distPref buildFlags extraArgs =   setupWrapper verbosity setupOptions Nothing-               (Cabal.buildCommand progConf) mkBuildFlags extraArgs+               (Cabal.buildCommand progDb) mkBuildFlags extraArgs   where-    progConf     = defaultProgramConfiguration+    progDb       = defaultProgramDb     setupOptions = defaultSetupScriptOptions { useDistPref = distPref }      mkBuildFlags version = filterBuildFlags version config buildFlags'@@ -387,7 +427,7 @@ -- old versions of Cabal. filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags filterBuildFlags version config buildFlags-  | version >= Version [1,19,1] [] = buildFlags_latest+  | version >= mkVersion [1,19,1] = buildFlags_latest   -- Cabal < 1.19.1 doesn't support 'build -j'.   | otherwise                      = buildFlags_pre_1_19_1   where@@ -418,15 +458,18 @@             Flag True -> SkipAddSourceDepsCheck             _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck                          (buildOnly buildExFlags)+      (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+      distPref <- findSavedDistPref config (replDistPref replFlags)+       -- Calls 'configureAction' to do the real work, so nothing special has to       -- be done to support sandboxes.-      (useSandbox, _config, distPref) <--        reconfigure verbosity (replDistPref replFlags)-                    mempty [] globalFlags noAddSource NoFlag-                    (const Nothing)-      let progConf     = defaultProgramConfiguration+      _ <-+        reconfigure configureAction+        verbosity distPref useSandbox noAddSource NoFlag+        mempty [] globalFlags config+      let progDb = defaultProgramDb           setupOptions = defaultSetupScriptOptions-            { useCabalVersion = orLaterVersion $ Version [1,18,0] []+            { useCabalVersion = orLaterVersion $ mkVersion [1,18,0]             , useDistPref     = distPref             }           replFlags'   = replFlags@@ -436,7 +479,7 @@        maybeWithSandboxDirOnSearchPath useSandbox $         setupWrapper verbosity setupOptions Nothing-        (Cabal.replCommand progConf) (const replFlags') extraArgs+        (Cabal.replCommand progDb) (const replFlags') extraArgs      -- No .cabal file in the current directory: just start the REPL (possibly     -- using the sandbox package DB).@@ -451,245 +494,13 @@       startInterpreter verbosity programDb' comp platform                        (configPackageDB' configFlags) --- | Re-configure the package in the current directory if needed. Deciding--- when to reconfigure and with which options is convoluted:------ If we are reconfiguring, we must always run @configure@ with the--- verbosity option we are given; however, that a previous configuration--- uses a different verbosity setting is not reason enough to reconfigure.------ The package should be configured to use the same \"dist\" prefix as--- given to the @build@ command, otherwise the build will probably--- fail. Not only does this determine the \"dist\" prefix setting if we--- need to reconfigure anyway, but an existing configuration should be--- invalidated if its \"dist\" prefix differs.------ If the package has never been configured (i.e., there is no--- LocalBuildInfo), we must configure first, using the default options.------ If the package has been configured, there will be a 'LocalBuildInfo'.--- If there no package description file, we assume that the--- 'PackageDescription' is up to date, though the configuration may need--- to be updated for other reasons (see above). If there is a package--- description file, and it has been modified since the 'LocalBuildInfo'--- was generated, then we need to reconfigure.------ The caller of this function may also have specific requirements--- regarding the flags the last configuration used. For example,--- 'testAction' requires that the package be configured with test suites--- enabled. The caller may pass the required settings to this function--- along with a function to check the validity of the saved 'ConfigFlags';--- these required settings will be checked first upon determining that--- a previous configuration exists.-reconfigure :: Verbosity    -- ^ Verbosity setting-            -> Flag FilePath  -- ^ \"dist\" prefix-            -> ConfigFlags  -- ^ Additional config flags to set. These flags-                            -- will be 'mappend'ed to the last used or-                            -- default 'ConfigFlags' as appropriate, so-                            -- this value should be 'mempty' with only the-                            -- required flags set. The required verbosity-                            -- and \"dist\" prefix flags will be set-                            -- automatically because they are always-                            -- required; therefore, it is not necessary to-                            -- set them here.-            -> [String]     -- ^ Extra arguments-            -> GlobalFlags  -- ^ Global flags-            -> SkipAddSourceDepsCheck-                            -- ^ Should we skip the timestamp check for modified-                            -- add-source dependencies?-            -> Flag (Maybe Int)-                            -- ^ -j flag for reinstalling add-source deps.-            -> (ConfigFlags -> Maybe String)-                            -- ^ Check that the required flags are set in-                            -- the last used 'ConfigFlags'. If the required-                            -- flags are not set, provide a message to the-                            -- user explaining the reason for-                            -- reconfiguration. Because the correct \"dist\"-                            -- prefix setting is always required, it is checked-                            -- automatically; this function need not check-                            -- for it.-            -> IO (UseSandbox, SavedConfig, FilePath)-reconfigure verbosity flagDistPref addConfigFlags extraArgs globalFlags-            skipAddSourceDepsCheck numJobsFlag    checkFlags = do-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config flagDistPref-  eLbi <- tryGetPersistBuildConfig distPref-  config' <- case eLbi of-    Left err  -> onNoBuildConfig (useSandbox, config) distPref err-    Right lbi -> onBuildConfig (useSandbox, config) distPref lbi-  return (useSandbox, config', distPref)--  where--    -- We couldn't load the saved package config file.-    ---    -- If we're in a sandbox: add-source deps don't have to be reinstalled-    -- (since we don't know the compiler & platform).-    onNoBuildConfig :: (UseSandbox, SavedConfig) -> FilePath-                    -> ConfigStateFileError -> IO SavedConfig-    onNoBuildConfig (_, config) distPref err = do-      let msg = case err of-            ConfigStateFileMissing -> "Package has never been configured."-            ConfigStateFileNoParse -> "Saved package config file seems "-                                      ++ "to be corrupt."-            _ -> show err-      case err of-        -- Note: the build config could have been generated by a custom setup-        -- script built against a different Cabal version, so it's crucial that-        -- we ignore the bad version error here.-        ConfigStateFileBadVersion _ _ _ -> info verbosity msg-        _                               -> do-          let distVerbFlags = mempty-                { configVerbosity = toFlag verbosity-                , configDistPref  = toFlag distPref-                }-              defaultFlags = mappend addConfigFlags distVerbFlags-          notice verbosity-            $ msg ++ " Configuring with default flags." ++ configureManually-          configureAction (defaultFlags, defaultConfigExFlags)-            extraArgs globalFlags-      return config--    -- Package has been configured, but the configuration may be out of-    -- date or required flags may not be set.-    ---    -- If we're in a sandbox: reinstall the modified add-source deps and-    -- force reconfigure if we did.-    onBuildConfig :: (UseSandbox, SavedConfig) -> FilePath-                  -> LBI.LocalBuildInfo -> IO SavedConfig-    onBuildConfig (useSandbox, config) distPref lbi = do-      let configFlags = LBI.configFlags lbi-          distVerbFlags = mempty-            { configVerbosity = toFlag verbosity-            , configDistPref  = toFlag distPref-            }-          flags       = mconcat [configFlags, addConfigFlags, distVerbFlags]--      -- Was the sandbox created after the package was already configured? We-      -- may need to skip reinstallation of add-source deps and force-      -- reconfigure.-      let buildConfig       = localBuildInfoFile distPref-      sandboxConfig        <- getSandboxConfigFilePath globalFlags-      isSandboxConfigNewer <--        sandboxConfig `existsAndIsMoreRecentThan` buildConfig--      let skipAddSourceDepsCheck'-            | isSandboxConfigNewer = SkipAddSourceDepsCheck-            | otherwise            = skipAddSourceDepsCheck--      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $-        info verbosity "Skipping add-source deps check..."--      let (_, config') = updateInstallDirs-                         (configUserInstall flags)-                         (useSandbox, config)--      depsReinstalled <--        case skipAddSourceDepsCheck' of-          DontSkipAddSourceDepsCheck ->-            maybeReinstallAddSourceDeps-              verbosity numJobsFlag flags globalFlags-              (useSandbox, config')-          SkipAddSourceDepsCheck -> do-            return NoDepsReinstalled--      -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need-      -- to force reconfigure. Note that it's possible to use @cabal.config@-      -- even without sandboxes.-      isUserPackageEnvironmentFileNewer <--        userPackageEnvironmentFile `existsAndIsMoreRecentThan` buildConfig--      -- Determine whether we need to reconfigure and which message to show to-      -- the user if that is the case.-      mMsg <- determineMessageToShow distPref lbi configFlags-                                     depsReinstalled isSandboxConfigNewer-                                     isUserPackageEnvironmentFileNewer-      case mMsg of--        -- No message for the user indicates that reconfiguration-        -- is not required.-        Nothing -> return config'--        -- Show the message and reconfigure.-        Just msg -> do-          notice verbosity msg-          configureAction (flags, defaultConfigExFlags)-            extraArgs globalFlags-          return config'--    -- Determine what message, if any, to display to the user if reconfiguration-    -- is required.-    determineMessageToShow :: FilePath -> LBI.LocalBuildInfo -> ConfigFlags-                            -> WereDepsReinstalled -> Bool -> Bool-                            -> IO (Maybe String)-    determineMessageToShow _ _   _           _               True  _     =-      -- The sandbox was created after the package was already configured.-      return $! Just $! sandboxConfigNewerMessage--    determineMessageToShow _ _   _           _               False True  =-      -- The user package environment file was modified.-      return $! Just $! userPackageEnvironmentFileModifiedMessage--    determineMessageToShow distPref lbi configFlags depsReinstalled-                           False False = do-      let savedDistPref = fromFlagOrDefault-                          (useDistPref defaultSetupScriptOptions)-                          (configDistPref configFlags)-      case depsReinstalled of-        ReinstalledSomeDeps ->-          -- Some add-source deps were reinstalled.-          return $! Just $! reinstalledDepsMessage-        NoDepsReinstalled ->-          case checkFlags configFlags of-            -- Flag required by the caller is not set.-            Just msg -> return $! Just $! msg ++ configureManually--            Nothing-              -- Required "dist" prefix is not set.-              | savedDistPref /= distPref ->-                return $! Just distPrefMessage--              -- All required flags are set, but the configuration-              -- may be outdated.-              | otherwise -> case LBI.pkgDescrFile lbi of-                Nothing -> return Nothing-                Just pdFile -> do-                  outdated <- checkPersistBuildConfigOutdated-                              distPref pdFile-                  return $! if outdated-                            then Just $! outdatedMessage pdFile-                            else Nothing--    reconfiguringMostRecent = " Re-configuring with most recently used options."-    configureManually       = " If this fails, please run configure manually."-    sandboxConfigNewerMessage =-        "The sandbox was created after the package was already configured."-        ++ reconfiguringMostRecent-        ++ configureManually-    userPackageEnvironmentFileModifiedMessage =-        "The user package environment file ('"-        ++ userPackageEnvironmentFile ++ "') was modified."-        ++ reconfiguringMostRecent-        ++ configureManually-    distPrefMessage =-        "Package previously configured with different \"dist\" prefix."-        ++ reconfiguringMostRecent-        ++ configureManually-    outdatedMessage pdFile =-        pdFile ++ " has been changed."-        ++ reconfiguringMostRecent-        ++ configureManually-    reinstalledDepsMessage =-        "Some add-source dependencies have been reinstalled."-        ++ reconfiguringMostRecent-        ++ configureManually- installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> Action installAction (configFlags, _, installFlags, _) _ globalFlags   | fromFlagOrDefault False (installOnly installFlags) = do       let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-      (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+      load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+      let config = either (\(SomeException _) -> mempty) snd load       distPref <- findSavedDistPref config (configDistPref configFlags)       let setupOpts = defaultSetupScriptOptions { useDistPref = distPref }       setupWrapper verbosity setupOpts Nothing installCommand (const mempty) []@@ -729,10 +540,10 @@                         savedHaddockFlags     config `mappend`                         haddockFlags { haddockDistPref = toFlag distPref }       globalFlags'    = savedGlobalFlags      config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags'+  (comp, platform, progdb) <- configCompilerAux' configFlags'   -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the   -- future.-  conf' <- configureAllKnownPrograms verbosity conf+  progdb' <- configureAllKnownPrograms verbosity progdb    -- If we're working inside a sandbox and the user has set the -w option, we   -- may need to create a sandbox-local package DB for this compiler and add a@@ -743,7 +554,7 @@                                                      configFlags'    whenUsingSandbox useSandbox $ \sandboxDir -> do-    initPackageDBIfNeeded verbosity configFlags'' comp conf'+    initPackageDBIfNeeded verbosity configFlags'' comp progdb'      indexFile     <- tryGetIndexFilePath config     maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile@@ -755,13 +566,13 @@   -- 'some-package'. This can also prevent packages that depend on older   -- versions of add-source'd packages from building (see #1362).   maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags'-                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              comp platform progdb useSandbox $ \mSandboxPkgInfo ->                               maybeWithSandboxDirOnSearchPath useSandbox $     withRepoContext verbosity globalFlags' $ \repoContext ->       install verbosity               (configPackageDB' configFlags'')               repoContext-              comp platform conf'+              comp platform progdb'               useSandbox mSandboxPkgInfo               globalFlags' configFlags'' configExFlags'               installFlags' haddockFlags'@@ -778,31 +589,40 @@            -> IO () testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)-      addConfigFlags = mempty { configTests = toFlag True }-      noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (testDistPref testFlags)+  let noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck                        (buildOnly buildExFlags)       buildFlags'    = buildFlags                        { buildVerbosity = testVerbosity testFlags }-      checkFlags flags-        | fromFlagOrDefault False (configTests flags) = Nothing-        | otherwise  = Just "Re-configuring with test suites enabled."+      checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->+        if fromFlagOrDefault False (configTests configFlags)+          then pure (mempty, flags)+          else do+            info verbosity "reconfiguring to enable tests"+            let flags' = ( configFlags { configTests = toFlag True }+                         , configExFlags+                         )+            pure (Any True, flags')    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config, distPref) <--    reconfigure verbosity (testDistPref testFlags)-                addConfigFlags [] globalFlags noAddSource-                (buildNumJobs buildFlags') checkFlags+  _ <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    checkFlags [] globalFlags config+   let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }       testFlags'     = testFlags { testDistPref = toFlag distPref }    -- The package was just configured, so the LBI must be available.-  names <- componentNamesFromLBI distPref "test suites"+  names <- componentNamesFromLBI verbosity distPref "test suites"              (\c -> case c of { LBI.CTest{} -> True; _ -> False })   let extraArgs'         | null extraArgs = case names of           ComponentNamesUnknown -> []-          ComponentNames names' -> [ name | LBI.CTestName name <- names' ]+          ComponentNames names' -> [ Make.unUnqualComponentName name+                                   | LBI.CTestName name <- names' ]         | otherwise      = extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $@@ -816,9 +636,10 @@                     | ComponentNames [LBI.ComponentName]  -- | Return the names of all buildable components matching a given predicate.-componentNamesFromLBI :: FilePath -> String -> (LBI.Component -> Bool)+componentNamesFromLBI :: Verbosity -> FilePath -> String+                         -> (LBI.Component -> Bool)                          -> IO ComponentNames-componentNamesFromLBI distPref targetsDescr compPred = do+componentNamesFromLBI verbosity distPref targetsDescr compPred = do   eLBI <- tryGetPersistBuildConfig distPref   case eLBI of     Left err -> case err of@@ -834,7 +655,10 @@                      . filter compPred $                      LBI.pkgComponents pkgDescr       if null names-        then die $ "Package has no buildable " ++ targetsDescr ++ "."+        then do notice verbosity $ "Package has no buildable "+                  ++ targetsDescr ++ "."+                exitSuccess -- See #3215.+         else return $! (ComponentNames names)  benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)@@ -844,35 +668,48 @@                 extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal                        (benchmarkVerbosity benchmarkFlags)-      addConfigFlags = mempty { configBenchmarks = toFlag True }-      buildFlags'    = buildFlags++  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)++  let buildFlags'    = buildFlags                        { buildVerbosity = benchmarkVerbosity benchmarkFlags }-      checkFlags flags-        | fromFlagOrDefault False (configBenchmarks flags) = Nothing-        | otherwise = Just "Re-configuring with benchmarks enabled."       noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck                       (buildOnly buildExFlags) +  let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->+        if fromFlagOrDefault False (configBenchmarks configFlags)+          then pure (mempty, flags)+          else do+            info verbosity "reconfiguring to enable benchmarks"+            let flags' = ( configFlags { configBenchmarks = toFlag True }+                         , configExFlags+                         )+            pure (Any True, flags')++   -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config, distPref) <--    reconfigure verbosity (benchmarkDistPref benchmarkFlags)-                addConfigFlags [] globalFlags noAddSource-                (buildNumJobs buildFlags') checkFlags+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    checkFlags [] globalFlags config+   let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }       benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }    -- The package was just configured, so the LBI must be available.-  names <- componentNamesFromLBI distPref "benchmarks"+  names <- componentNamesFromLBI verbosity distPref "benchmarks"            (\c -> case c of { LBI.CBench{} -> True; _ -> False; })   let extraArgs'         | null extraArgs = case names of           ComponentNamesUnknown -> []-          ComponentNames names' -> [name | LBI.CBenchName name <- names']+          ComponentNames names' -> [ Make.unUnqualComponentName name+                                   | LBI.CBenchName name <- names']         | otherwise      = extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags' extraArgs'+    build verbosity config' distPref buildFlags' extraArgs'    maybeWithSandboxDirOnSearchPath useSandbox $     setupWrapper verbosity setupOptions Nothing@@ -881,17 +718,19 @@ haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do   let verbosity = fromFlag (haddockVerbosity haddockFlags)-  (_useSandbox, config, distPref) <--    reconfigure verbosity (haddockDistPref haddockFlags)-                mempty [] globalFlags DontSkipAddSourceDepsCheck-                NoFlag (const Nothing)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (haddockDistPref haddockFlags)+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag+    mempty [] globalFlags config   let haddockFlags' = defaultHaddockFlags      `mappend`-                      savedHaddockFlags config `mappend`+                      savedHaddockFlags config' `mappend`                       haddockFlags { haddockDistPref = toFlag distPref }       setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }   setupWrapper verbosity setupScriptOptions Nothing     haddockCommand (const haddockFlags') extraArgs-  when (fromFlagOrDefault False $ haddockForHackage haddockFlags) $ do+  when (haddockForHackage haddockFlags == Flag ForHackage) $ do     pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)     let dest = distPref </> name <.> "tar.gz"         name = display (packageId pkg) ++ "-docs"@@ -901,7 +740,8 @@  cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do-  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+  let config = either (\(SomeException _) -> mempty) snd load   distPref <- findSavedDistPref config (cleanDistPref cleanFlags)   let setupScriptOptions = defaultSetupScriptOptions                            { useDistPref = distPref@@ -924,13 +764,13 @@                            `mappend` listPackageDBs listFlags         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, conf) <- configCompilerAux' configFlags+  (comp, _, progdb) <- configCompilerAux' configFlags   withRepoContext verbosity globalFlags' $ \repoContext ->     List.list verbosity        (configPackageDB' configFlags)        repoContext        comp-       conf+       progdb        listFlags        extraArgs @@ -946,13 +786,13 @@                            `mappend` infoPackageDBs infoFlags         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, conf) <- configCompilerAuxEx configFlags+  (comp, _, progdb) <- configCompilerAuxEx configFlags   withRepoContext verbosity globalFlags' $ \repoContext ->     List.info verbosity        (configPackageDB' configFlags)        repoContext        comp-       conf+       progdb        globalFlags'        infoFlags        targets@@ -990,12 +830,12 @@   config <- loadConfig verbosity (globalConfigFile globalFlags)   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags+  (comp, platform, progdb) <- configCompilerAux' configFlags   withRepoContext verbosity globalFlags' $ \repoContext ->     fetch verbosity         (configPackageDB' configFlags)         repoContext-        comp platform conf globalFlags' fetchFlags+        comp platform progdb globalFlags' fetchFlags         targets  freezeAction :: FreezeFlags -> [String] -> Action@@ -1004,16 +844,16 @@   (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags+  (comp, platform, progdb) <- configCompilerAux' configFlags    maybeWithSandboxPackageInfo verbosity configFlags globalFlags'-                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              comp platform progdb useSandbox $ \mSandboxPkgInfo ->                               maybeWithSandboxDirOnSearchPath useSandbox $     withRepoContext verbosity globalFlags' $ \repoContext ->       freeze verbosity             (configPackageDB' configFlags)             repoContext-            comp platform conf+            comp platform progdb             mSandboxPkgInfo             globalFlags' freezeFlags @@ -1023,16 +863,16 @@   (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags+  (comp, platform, progdb) <- configCompilerAux' configFlags    maybeWithSandboxPackageInfo verbosity configFlags globalFlags'-                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              comp platform progdb useSandbox $ \mSandboxPkgInfo ->                               maybeWithSandboxDirOnSearchPath useSandbox $     withRepoContext verbosity globalFlags' $ \repoContext ->       genBounds verbosity             (configPackageDB' configFlags)             repoContext-            comp platform conf+            comp platform progdb             mSandboxPkgInfo             globalFlags' freezeFlags @@ -1044,9 +884,6 @@       tarfiles     = extraArgs   when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $     die "the 'upload' command expects at least one .tar.gz archive."-  when (fromFlag (uploadCheck uploadFlags')-        && fromFlag (uploadDoc uploadFlags')) $-    die "--check and --doc cannot be used together."   checkTarFiles extraArgs   maybe_password <-     case uploadPasswordCmd uploadFlags'@@ -1055,10 +892,7 @@                         (simpleProgramInvocation xs xss)        _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'   withRepoContext verbosity globalFlags' $ \repoContext -> do-    if fromFlag (uploadCheck uploadFlags')-    then do-      Upload.check verbosity repoContext tarfiles-    else if fromFlag (uploadDoc uploadFlags')+    if fromFlag (uploadDoc uploadFlags')     then do       when (length tarfiles > 1) $        die $ "the 'upload' command can only upload documentation "@@ -1068,12 +902,14 @@                        repoContext                        (flagToMaybe $ uploadUsername uploadFlags')                        maybe_password+                       (fromFlag (uploadCandidate uploadFlags'))                        tarfile     else do       Upload.upload verbosity                     repoContext                     (flagToMaybe $ uploadUsername uploadFlags')                     maybe_password+                    (fromFlag (uploadCandidate uploadFlags'))                     tarfiles     where     verbosity = fromFlag (uploadVerbosity uploadFlags)@@ -1091,9 +927,13 @@               (file', ".gz") -> takeExtension file' == ".tar"               _              -> False     generateDocTarball config = do-      notice verbosity-        "No documentation tarball specified. Building documentation tarball..."-      haddockAction (defaultHaddockFlags { haddockForHackage = Flag True })+      notice verbosity $+        "No documentation tarball specified. "+        ++ "Building a documentation tarball with default settings...\n"+        ++ "If you need to customise Haddock options, "+        ++ "run 'haddock --for-hackage' first "+        ++ "to generate a documentation tarball."+      haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage })                     [] globalFlags       distPref <- findSavedDistPref config NoFlag       pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)@@ -1134,7 +974,8 @@   unless (null extraArgs) $     die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag (sDistVerbosity sdistFlags)-  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+  let config = either (\(SomeException _) -> mempty) snd load   distPref <- findSavedDistPref config (sDistDistPref sdistFlags)   let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref }   sdist sdistFlags' sdistExFlags@@ -1157,21 +998,23 @@ runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action runAction (buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (buildDistPref buildFlags)   let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck                     (buildOnly buildExFlags)    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config, distPref) <--    reconfigure verbosity (buildDistPref buildFlags) mempty []-                globalFlags noAddSource (buildNumJobs buildFlags)-                (const Nothing)+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    mempty [] globalFlags config    lbi <- getPersistBuildConfig distPref   (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags ["exe:" ++ exeName exe]+    build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]    maybeWithSandboxDirOnSearchPath useSandbox $     run verbosity lbi exe exeArgs@@ -1203,13 +1046,13 @@                            (globalFlags { globalRequireSandbox = Flag False })   let configFlags  = savedConfigureFlags config   let globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, conf) <- configCompilerAux' configFlags+  (comp, _, progdb) <- configCompilerAux' configFlags   withRepoContext verbosity globalFlags' $ \repoContext ->     initCabal verbosity             (configPackageDB' configFlags)             repoContext             comp-            conf+            progdb             initFlags  sandboxAction :: SandboxFlags -> [String] -> Action@@ -1252,8 +1095,8 @@   let verbosity = fromFlag (execVerbosity execFlags)   (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags = savedConfigureFlags config-  (comp, platform, conf) <- getPersistOrConfigCompiler configFlags-  exec verbosity useSandbox comp platform conf extraArgs+  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags+  exec verbosity useSandbox comp platform progdb extraArgs  userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do@@ -1264,7 +1107,7 @@       path       <- configFile       fileExists <- doesFileExist path       if (not fileExists || (fileExists && force))-      then createDefaultConfigFile verbosity path+      then void $ createDefaultConfigFile verbosity path       else die $ path ++ " already exists."     ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags     ("update":_) -> userConfigUpdate verbosity globalFlags@@ -1278,7 +1121,7 @@ win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do   let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)-  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path+  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse win32SelfUpgradeAction _ _ _ = return ()  -- | Used as an entry point when cabal-install needs to invoke itself
cabal/cabal-install/Setup.hs view
@@ -11,7 +11,7 @@ import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..)                                           , absoluteInstallDirs                                           )-import Distribution.Simple.Utils ( copyFiles+import Distribution.Simple.Utils ( installOrdinaryFiles                                  , notice ) import Distribution.Simple.Setup ( buildVerbosity                                  , copyDest@@ -60,4 +60,4 @@ installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO () installManpage pkg lbi verbosity copy = do   let destDir = mandir (absoluteInstallDirs pkg lbi copy) </> "man1"-  copyFiles verbosity destDir [(buildDir lbi </> "cabal", "cabal.1")]+  installOrdinaryFiles verbosity destDir [(buildDir lbi </> "cabal", "cabal.1")]
cabal/cabal-install/bash-completion/cabal view
@@ -10,9 +10,10 @@ #   - executable|test-suite|benchmark for the three _cabal_list() {-	cat *.cabal |-	grep -Ei "^[[:space:]]*($1)[[:space:]]" |-	sed -e "s/.* \([^ ]*\).*/\1/"+    for f in ./*.cabal; do+        grep -Ei "^[[:space:]]*($1)[[:space:]]" "$f" |+        sed -e "s/.* \([^ ]*\).*/\1/"+    done }  # List possible targets depending on the command supplied as parameter.  The@@ -20,17 +21,17 @@ # This is a temporary workaround. _cabal_targets() {-	# If command ($*) contains build, repl, test or bench completes with-	# targets of according type.-	[ -f *.cabal ] || return 0-	local comp-	for comp in $*; do-		[ $comp == build ] && _cabal_list "executable|test-suite|benchmark" && break-		[ $comp == repl  ] && _cabal_list "executable|test-suite|benchmark" && break-		[ $comp == run   ] && _cabal_list "executable"                      && break-		[ $comp == test  ] && _cabal_list            "test-suite"           && break-		[ $comp == bench ] && _cabal_list                       "benchmark" && break-	done+    # If command ($*) contains build, repl, test or bench completes with+    # targets of according type.+    local comp+    for comp in "$@"; do+        [ "$comp" == new-build ] && _cabal_list "executable|test-suite|benchmark" && break+        [ "$comp" == build     ] && _cabal_list "executable|test-suite|benchmark" && break+        [ "$comp" == repl      ] && _cabal_list "executable|test-suite|benchmark" && break+        [ "$comp" == run       ] && _cabal_list "executable"                      && break+        [ "$comp" == test      ] && _cabal_list            "test-suite"           && break+        [ "$comp" == bench     ] && _cabal_list                       "benchmark" && break+    done }  # List possible subcommands of a cabal subcommand.@@ -87,7 +88,7 @@     cmd[${COMP_CWORD}]="--list-options"      # the resulting completions should be put into this array-    COMPREPLY=( $( compgen -W "$( ${cmd[@]} ) $( _cabal_targets ${cmd[@]} ) $( _cabal_subcommands ${COMP_WORDS[@]} )" -- $cur ) )+    COMPREPLY=( $( compgen -W "$( eval "${cmd[@]}" 2>/dev/null ) $( _cabal_targets "${cmd[@]}" ) $( _cabal_subcommands "${COMP_WORDS[@]}" )" -- "$cur" ) ) }  complete -F _cabal -o default cabal
cabal/cabal-install/bootstrap.sh view
@@ -16,7 +16,10 @@ #EXTRA_BUILD_OPTS #EXTRA_INSTALL_OPTS -die () { printf "\nError during cabal-install bootstrap:\n$1\n" >&2 && exit 2 ;}+die() {+    printf "\nError during cabal-install bootstrap:\n%s\n" "$1" >&2+    exit 2+}  # programs, you can override these by setting environment vars GHC="${GHC:-ghc}"@@ -51,13 +54,12 @@ SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}" DEFAULT_PREFIX="${HOME}/.cabal" -# Try to respect $TMPDIR.-[ -"$TMPDIR"- = -""- ] &&-  export TMPDIR=/tmp/cabal-$(echo $(od -XN4 -An /dev/random)) && mkdir $TMPDIR+TMPDIR=$(mktemp -d -p /tmp -t cabal-XXXXXXX || mktemp -d -t cabal-XXXXXXX)+export TMPDIR  # Check for a C compiler, using user-set $CC, if any, first. for c in $CC gcc clang cc icc; do-  $c --version 2>&1 >/dev/null && CC=$c &&+  $c --version 1>/dev/null 2>&1 && CC=$c &&   echo "Using $c for C compiler. If this is not what you want, set CC." >&2 &&   break done@@ -68,8 +70,12 @@  # Find the correct linker/linker-wrapper. LINK="$(for link in collect2 ld; do-          [ $($CC -print-prog-name=$link) = $link ] && continue ||-          $CC -print-prog-name=$link+          if [ $($CC -print-prog-name=$link) = $link ]+          then+              continue+          else+              $CC -print-prog-name=$link+          fi         done)"  # Fall back to "ld"... might work.@@ -99,13 +105,13 @@  ${GHC_PKG} --version     > /dev/null 2>&1  || die "${GHC_PKG} not found." -GHC_VER="$(${GHC} --numeric-version)" GHC_PKG_VER="$(${GHC_PKG} --version | cut -d' ' -f 5)"  [ ${GHC_VER} = ${GHC_PKG_VER} ] ||   die "Version mismatch between ${GHC} and ${GHC_PKG}.        If you set the GHC variable then set GHC_PKG too." +JOBS="-j1" while [ "$#" -gt 0 ]; do   case "${1}" in     "--user")@@ -128,14 +134,28 @@     "--no-doc")       NO_DOCUMENTATION=1       shift;;+    "-j"|"--jobs")+        shift+        # check if there is another argument which doesn't start with - or --+        if [ "$#" -le 0 ] \+            || [ ! -z $(echo "${1}" | grep "^-") ] \+            || [ ! -z $(echo "${1}" | grep "^--") ]+        then+            JOBS="-j"+        else+            JOBS="-j${1}"+            shift+        fi;;     *)       echo "Unknown argument or option, quitting: ${1}"       echo "usage: bootstrap.sh [OPTION]"       echo       echo "options:"+      echo "   -j/--jobs       Number of concurrent workers to use (Default: 1)"+      echo "                   -j without an argument will use all available cores"       echo "   --user          Install for the local user (default)"       echo "   --global        Install systemwide (must be run as root)"-      echo "   --no-doc        Do not generate documentation for installed "\+      echo "   --no-doc        Do not generate documentation for installed"\            "packages"       echo "   --sandbox       Install to a sandbox in the default location"\            "(.cabal-sandbox)"@@ -144,6 +164,15 @@   esac done +# Do not try to use -j with GHC older than 7.8+case $GHC_VER in+    7.4*|7.6*)+        JOBS=""+        ;;+    *)+        ;;+esac+ abspath () { case "$1" in /*)printf "%s\n" "$1";; *)printf "%s\n" "$PWD/$1";;              esac; } @@ -179,10 +208,23 @@ # The version regex says what existing installed versions are ok. PARSEC_VER="3.1.9";    PARSEC_VER_REGEXP="[3]\.[01]\."                        # >= 3.0 && < 3.2-DEEPSEQ_VER="1.4.1.2"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."+DEEPSEQ_VER="1.4.2.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."                        # >= 1.1 && < 2-BINARY_VER="0.8.2.1";  BINARY_VER_REGEXP="[0]\.[78]\."-                       # >= 0.7 && < 0.9++case "$GHC_VER" in+    7.4*|7.6*)+        # GHC 7.4 or 7.6+        BINARY_VER="0.8.2.1"+        BINARY_VER_REGEXP="[0]\.[78]\.[0-2]\." # >= 0.7 && < 0.8.3+        ;;+    *)+        # GHC >= 7.8+        BINARY_VER="0.8.3.0"+        BINARY_VER_REGEXP="[0]\.[78]\." # >= 0.7 && < 0.9+        ;;+esac++ TEXT_VER="1.2.2.1";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"                        # >= 0.2 && < 1.3 NETWORK_VER="2.6.2.1"; NETWORK_VER_REGEXP="2\.[0-6]\."@@ -211,25 +253,29 @@                        # >=1.0.0.0 && <1.2 OLD_LOCALE_VER="1.0.0.7"; OLD_LOCALE_VER_REGEXP="1\.0\.?"                        # >=1.0.0.0 && <1.1-BYTEABLE_VER="0.1.1";  BYTEABLE_VER_REGEXP="0\.?"-                       # 0.1.1-CRYPTOHASH_VER="0.11.7"; CRYPTOHASH_VER_REGEXP="0\.11\.?"+BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1"+                       # 0.1.*+BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\."+                       # >=1.0+CRYPTOHASH_SHA256_VER="0.11.7.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?"                        # 0.11.*+EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?"+                       # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?"                        # 0.0.*-HACKAGE_SECURITY_VER="0.5.0.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.?"-                       # >= 0.5 && < 0.6-TAR_VER="0.5.0.1";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.1)\.?"-                       # >= 0.5.0.1  && < 0.6-BASE64_BYTESTRING_VER="1.0.0.1";    BASE64_BYTESTRING_REGEXP="1\."-                                    # >=1.0+HACKAGE_SECURITY_VER="0.5.2.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.(2\.[2-9]|[3-9])"+                       # >= 0.5.2 && < 0.6+BYTESTRING_BUILDER_VER="0.10.8.1.0"; BYTESTRING_BUILDER_VER_REGEXP="0\.10\.?"+TAR_VER="0.5.0.3";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?"+                       # >= 0.5.0.3  && < 0.6 HASHABLE_VER="1.2.4.0"; HASHABLE_VER_REGEXP="1\."                        # 1.*  HACKAGE_URL="https://hackage.haskell.org/package" -# Haddock fails for network-2.5.0.0.-NO_DOCS_PACKAGES_VER_REGEXP="network-uri-2\.5\.[0-9]+\.[0-9]+"+# Haddock fails for network-2.5.0.0, and for hackage-security for+# GHC <8, c.f. https://github.com/well-typed/hackage-security/issues/149+NO_DOCS_PACKAGES_VER_REGEXP="network-uri-2\.5\.[0-9]+\.[0-9]+|hackage-security-0\.5\.[0-9]+\.[0-9]+"  # Cache the list of packages: echo "Checking installed packages for ghc-${GHC_VER}..."@@ -316,7 +362,7 @@   [ -x Setup ] && ./Setup clean   [ -f Setup ] && rm Setup -  ${GHC} --make Setup -o Setup ||+  ${GHC} --make ${JOBS} Setup -o Setup -XRank2Types -XFlexibleContexts ||     die "Compiling the Setup script failed."    [ -x Setup ] || die "The Setup script does not exist or cannot be run"@@ -327,7 +373,7 @@    ./Setup configure $args || die "Configuring the ${PKG} package failed." -  ./Setup build ${EXTRA_BUILD_OPTS} ${VERBOSE} ||+  ./Setup build ${JOBS} ${EXTRA_BUILD_OPTS} ${VERBOSE} ||      die "Building the ${PKG} package failed."    if [ ! ${NO_DOCUMENTATION} ]@@ -361,13 +407,29 @@         echo "Downloading ${PKG}-${VER}..."         fetch_pkg ${PKG} ${VER}     fi-    unpack_pkg ${PKG} ${VER}-    cd "${PKG}-${VER}"-    install_pkg ${PKG} ${VER}-    cd ..+    unpack_pkg "${PKG}" "${VER}"+    (cd "${PKG}-${VER}" && install_pkg ${PKG} ${VER})   fi } +# If we're bootstrapping from a Git clone, install the local version of Cabal+# instead of downloading one from Hackage.+do_Cabal_pkg () {+    if [ -d "../.git" ]+    then+        if need_pkg "Cabal" ${CABAL_VER_REGEXP}+        then+            echo "Cabal-${CABAL_VER} will be installed from the local Git clone."+            (cd ../Cabal && install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP})+        else+            echo "Cabal-${CABAL_VER} is already installed and the version is ok."+        fi+    else+        info_pkg "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP}+        do_pkg   "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP}+    fi+}+ # Replicate the flag selection logic for network-uri in the .cabal file. do_network_uri_pkg () {   # Refresh installed package list.@@ -389,12 +451,22 @@   fi } +# Conditionally install bytestring-builder if bytestring is < 0.10.2.+do_bytestring_builder_pkg () {+  if egrep "bytestring-0\.(9|10\.[0,1])\.?" ghc-pkg-stage2.list > /dev/null 2>&1+  then+      info_pkg "bytestring-builder" ${BYTESTRING_BUILDER_VER} \+               ${BYTESTRING_BUILDER_VER_REGEXP}+      do_pkg   "bytestring-builder" ${BYTESTRING_BUILDER_VER} \+               ${BYTESTRING_BUILDER_VER_REGEXP}+  fi+}+ # Actually do something!  info_pkg "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} info_pkg "binary"       ${BINARY_VER}  ${BINARY_VER_REGEXP} info_pkg "time"         ${TIME_VER}    ${TIME_VER_REGEXP}-info_pkg "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP} info_pkg "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP} info_pkg "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP} info_pkg "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP}@@ -407,20 +479,26 @@ info_pkg "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP} info_pkg "stm"          ${STM_VER}     ${STM_VER_REGEXP} info_pkg "async"        ${ASYNC_VER}   ${ASYNC_VER_REGEXP}-info_pkg "byteable"          ${BYTEABLE_VER}         ${BYTEABLE_VER_REGEXP}-info_pkg "cryptohash"        ${CRYPTOHASH_VER}       ${CRYPTOHASH_VER_REGEXP}-info_pkg "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}-info_pkg "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}+info_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \+    ${BASE16_BYTESTRING_VER_REGEXP} info_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \     ${BASE64_BYTESTRING_VER_REGEXP}-info_pkg "hashable"          ${HASHABLE_VER}          ${HASHABLE_VER_REGEXP}+info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \+    ${CRYPTOHASH_SHA256_VER_REGEXP}+info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}+info_pkg "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}+info_pkg "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}+info_pkg "hashable"          ${HASHABLE_VER}         ${HASHABLE_VER_REGEXP} info_pkg "hackage-security"  ${HACKAGE_SECURITY_VER} \     ${HACKAGE_SECURITY_VER_REGEXP}  do_pkg   "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} do_pkg   "binary"       ${BINARY_VER}  ${BINARY_VER_REGEXP} do_pkg   "time"         ${TIME_VER}    ${TIME_VER_REGEXP}-do_pkg   "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP}++# Install the Cabal library from the local Git clone if possible.+do_Cabal_pkg+ do_pkg   "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP} do_pkg   "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP} do_pkg   "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP}@@ -437,12 +515,20 @@ do_pkg   "random"       ${RANDOM_VER}     ${RANDOM_VER_REGEXP} do_pkg   "stm"          ${STM_VER}        ${STM_VER_REGEXP} do_pkg   "async"        ${ASYNC_VER}      ${ASYNC_VER_REGEXP}-do_pkg   "byteable"          ${BYTEABLE_VER}         ${BYTEABLE_VER_REGEXP}-do_pkg   "cryptohash"        ${CRYPTOHASH_VER}       ${CRYPTOHASH_VER_REGEXP}-do_pkg   "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}-do_pkg   "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}+do_pkg   "base16-bytestring" ${BASE16_BYTESTRING_VER} \+    ${BASE16_BYTESTRING_VER_REGEXP} do_pkg   "base64-bytestring" ${BASE64_BYTESTRING_VER} \     ${BASE64_BYTESTRING_VER_REGEXP}+do_pkg   "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \+    ${CRYPTOHASH_SHA256_VER_REGEXP}+do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}+do_pkg   "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}++# We conditionally install bytestring-builder, depending on the bytestring+# version.+do_bytestring_builder_pkg++do_pkg   "tar"               ${TAR_VER}              ${TAR_VER_REGEXP} do_pkg   "hashable"          ${HASHABLE_VER}         ${HASHABLE_VER_REGEXP} do_pkg   "hackage-security"  ${HACKAGE_SECURITY_VER} \     ${HACKAGE_SECURITY_VER_REGEXP}
cabal/cabal-install/cabal-install.cabal view
@@ -9,17 +9,9 @@ bug-reports:        https://github.com/haskell/cabal/issues License:            BSD3 License-File:       LICENSE-Author:             Lemmih <lemmih@gmail.com>-                    Paolo Martini <paolo@nemail.it>-                    Bjorn Bringert <bjorn@bringert.net>-                    Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    Duncan Coutts <duncan@community.haskell.org>-Maintainer:         cabal-devel@haskell.org-Copyright:          2005 Lemmih <lemmih@gmail.com>-                    2006 Paolo Martini <paolo@nemail.it>-                    2007 Bjorn Bringert <bjorn@bringert.net>-                    2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    2007-2012 Duncan Coutts <duncan@community.haskell.org>+Author:             Cabal Development Team (see AUTHORS file)+Maintainer:         Cabal Development Team <cabal-devel@haskell.org>+Copyright:          2003-2016, Cabal Development Team Category:           Distribution Build-type:         Custom Cabal-Version:      >= 1.10@@ -30,12 +22,62 @@   -- Generated with '../Cabal/misc/gen-extra-source-files.sh'   -- Do NOT edit this section manually; instead, run the script.   -- BEGIN gen-extra-source-files+  tests/IntegrationTests/backpack/includes2-external.sh+  tests/IntegrationTests/backpack/includes2-internal.sh+  tests/IntegrationTests/backpack/includes2/Includes2.cabal+  tests/IntegrationTests/backpack/includes2/exe/Main.hs+  tests/IntegrationTests/backpack/includes2/exe/exe.cabal+  tests/IntegrationTests/backpack/includes2/mylib/Mine.hs+  tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal+  tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs+  tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal+  tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs+  tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal+  tests/IntegrationTests/backpack/includes2/src/App.hs+  tests/IntegrationTests/backpack/includes2/src/src.cabal+  tests/IntegrationTests/backpack/includes3-external.sh+  tests/IntegrationTests/backpack/includes3-internal.sh+  tests/IntegrationTests/backpack/includes3/Includes3.cabal+  tests/IntegrationTests/backpack/includes3/exe/Main.hs+  tests/IntegrationTests/backpack/includes3/exe/Setup.hs+  tests/IntegrationTests/backpack/includes3/exe/exe.cabal+  tests/IntegrationTests/backpack/includes3/indef/Foo.hs+  tests/IntegrationTests/backpack/includes3/indef/Setup.hs+  tests/IntegrationTests/backpack/includes3/indef/indef.cabal+  tests/IntegrationTests/backpack/includes3/sigs/Setup.hs+  tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal   tests/IntegrationTests/common.sh-  tests/IntegrationTests/custom/plain.err+  tests/IntegrationTests/custom-setup/Cabal-99998/Cabal.cabal+  tests/IntegrationTests/custom-setup/Cabal-99998/CabalMessage.hs+  tests/IntegrationTests/custom-setup/Cabal-99999/Cabal.cabal+  tests/IntegrationTests/custom-setup/Cabal-99999/CabalMessage.hs+  tests/IntegrationTests/custom-setup/custom-setup-old-cabal/Setup.hs+  tests/IntegrationTests/custom-setup/custom-setup-old-cabal/custom-setup-old-cabal.cabal+  tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/Setup.hs+  tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal+  tests/IntegrationTests/custom-setup/custom-setup-without-cabal/Setup.hs+  tests/IntegrationTests/custom-setup/custom-setup-without-cabal/custom-setup-without-cabal.cabal+  tests/IntegrationTests/custom-setup/custom-setup/Setup.hs+  tests/IntegrationTests/custom-setup/custom-setup/custom-setup.cabal+  tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh+  tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_require_Cabal.sh+  tests/IntegrationTests/custom-setup/installs_Cabal_as_setup_dep.sh+  tests/IntegrationTests/custom-setup/new_build_requires_Cabal_1_20.sh+  tests/IntegrationTests/custom/custom_dep.sh+  tests/IntegrationTests/custom/custom_dep/client/B.hs+  tests/IntegrationTests/custom/custom_dep/client/Setup.hs+  tests/IntegrationTests/custom/custom_dep/client/client.cabal+  tests/IntegrationTests/custom/custom_dep/custom/A.hs+  tests/IntegrationTests/custom/custom_dep/custom/Setup.hs+  tests/IntegrationTests/custom/custom_dep/custom/custom.cabal   tests/IntegrationTests/custom/plain.sh   tests/IntegrationTests/custom/plain/A.hs   tests/IntegrationTests/custom/plain/Setup.hs   tests/IntegrationTests/custom/plain/plain.cabal+  tests/IntegrationTests/custom/segfault.sh+  tests/IntegrationTests/custom/segfault/Setup.hs+  tests/IntegrationTests/custom/segfault/cabal.project+  tests/IntegrationTests/custom/segfault/plain.cabal   tests/IntegrationTests/exec/Foo.hs   tests/IntegrationTests/exec/My.hs   tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.out@@ -62,8 +104,10 @@   tests/IntegrationTests/freeze/freezes_transitive_dependencies.sh   tests/IntegrationTests/freeze/my.cabal   tests/IntegrationTests/freeze/runs_without_error.sh+  tests/IntegrationTests/internal-libs/cabal.project   tests/IntegrationTests/internal-libs/internal_lib_basic.sh   tests/IntegrationTests/internal-libs/internal_lib_shadow.sh+  tests/IntegrationTests/internal-libs/new_build.sh   tests/IntegrationTests/internal-libs/p/Foo.hs   tests/IntegrationTests/internal-libs/p/p.cabal   tests/IntegrationTests/internal-libs/p/p/P.hs@@ -76,6 +120,71 @@   tests/IntegrationTests/multiple-source/p/p.cabal   tests/IntegrationTests/multiple-source/q/Setup.hs   tests/IntegrationTests/multiple-source/q/q.cabal+  tests/IntegrationTests/new-build/BuildToolsPath.sh+  tests/IntegrationTests/new-build/BuildToolsPath/A.hs+  tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs+  tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal+  tests/IntegrationTests/new-build/BuildToolsPath/cabal.project+  tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs+  tests/IntegrationTests/new-build/T3460.sh+  tests/IntegrationTests/new-build/T3460/C.hs+  tests/IntegrationTests/new-build/T3460/Setup.hs+  tests/IntegrationTests/new-build/T3460/T3460.cabal+  tests/IntegrationTests/new-build/T3460/cabal.project+  tests/IntegrationTests/new-build/T3460/sub-package-A/A.hs+  tests/IntegrationTests/new-build/T3460/sub-package-A/Setup.hs+  tests/IntegrationTests/new-build/T3460/sub-package-A/sub-package-A.cabal+  tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs+  tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs+  tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal+  tests/IntegrationTests/new-build/T3978.err+  tests/IntegrationTests/new-build/T3978.sh+  tests/IntegrationTests/new-build/T3978/cabal.project+  tests/IntegrationTests/new-build/T3978/p/p.cabal+  tests/IntegrationTests/new-build/T3978/q/q.cabal+  tests/IntegrationTests/new-build/T4017.sh+  tests/IntegrationTests/new-build/T4017/cabal.project+  tests/IntegrationTests/new-build/T4017/p/p.cabal+  tests/IntegrationTests/new-build/T4017/q/q.cabal+  tests/IntegrationTests/new-build/executable/Main.hs+  tests/IntegrationTests/new-build/executable/Setup.hs+  tests/IntegrationTests/new-build/executable/Test.hs+  tests/IntegrationTests/new-build/executable/a.cabal+  tests/IntegrationTests/new-build/executable/cabal.project+  tests/IntegrationTests/new-build/external_build_tools.sh+  tests/IntegrationTests/new-build/external_build_tools/cabal.project+  tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs+  tests/IntegrationTests/new-build/external_build_tools/client/client.cabal+  tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs+  tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal+  tests/IntegrationTests/new-build/monitor_cabal_files.sh+  tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project+  tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs+  tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs+  tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal+  tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs+  tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs+  tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in+  tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in+  tests/IntegrationTests/regression/t2755.sh+  tests/IntegrationTests/regression/t2755/A.hs+  tests/IntegrationTests/regression/t2755/Setup.hs+  tests/IntegrationTests/regression/t2755/test-t2755.cabal+  tests/IntegrationTests/regression/t3199.sh+  tests/IntegrationTests/regression/t3199/Main.hs+  tests/IntegrationTests/regression/t3199/Setup.hs+  tests/IntegrationTests/regression/t3199/test-3199.cabal+  tests/IntegrationTests/regression/t3827.sh+  tests/IntegrationTests/regression/t3827/cabal.project+  tests/IntegrationTests/regression/t3827/p/P.hs+  tests/IntegrationTests/regression/t3827/p/p.cabal+  tests/IntegrationTests/regression/t3827/q/Main.hs+  tests/IntegrationTests/regression/t3827/q/q.cabal+  tests/IntegrationTests/sandbox-reinstalls/p/Main.hs+  tests/IntegrationTests/sandbox-reinstalls/p/p.cabal+  tests/IntegrationTests/sandbox-reinstalls/q/Q.hs+  tests/IntegrationTests/sandbox-reinstalls/q/q.cabal+  tests/IntegrationTests/sandbox-reinstalls/reinstall-modified-source.sh   tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.err   tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.sh   tests/IntegrationTests/sandbox-sources/p/Setup.hs@@ -94,6 +203,31 @@   tests/IntegrationTests/user-config/runs_without_error.sh   tests/IntegrationTests/user-config/uses_CABAL_CONFIG.out   tests/IntegrationTests/user-config/uses_CABAL_CONFIG.sh+  tests/IntegrationTests2/build/keep-going/cabal.project+  tests/IntegrationTests2/build/keep-going/p/P.hs+  tests/IntegrationTests2/build/keep-going/p/p.cabal+  tests/IntegrationTests2/build/keep-going/q/Q.hs+  tests/IntegrationTests2/build/keep-going/q/q.cabal+  tests/IntegrationTests2/build/setup-custom1/A.hs+  tests/IntegrationTests2/build/setup-custom1/Setup.hs+  tests/IntegrationTests2/build/setup-custom1/a.cabal+  tests/IntegrationTests2/build/setup-custom2/A.hs+  tests/IntegrationTests2/build/setup-custom2/Setup.hs+  tests/IntegrationTests2/build/setup-custom2/a.cabal+  tests/IntegrationTests2/build/setup-simple/A.hs+  tests/IntegrationTests2/build/setup-simple/Setup.hs+  tests/IntegrationTests2/build/setup-simple/a.cabal+  tests/IntegrationTests2/exception/bad-config/cabal.project+  tests/IntegrationTests2/exception/build/Main.hs+  tests/IntegrationTests2/exception/build/a.cabal+  tests/IntegrationTests2/exception/configure/a.cabal+  tests/IntegrationTests2/exception/no-pkg/empty.in+  tests/IntegrationTests2/exception/no-pkg2/cabal.project+  tests/IntegrationTests2/regression/3324/cabal.project+  tests/IntegrationTests2/regression/3324/p/P.hs+  tests/IntegrationTests2/regression/3324/p/p.cabal+  tests/IntegrationTests2/regression/3324/q/Q.hs+  tests/IntegrationTests2/regression/3324/q/q.cabal   -- END gen-extra-source-files  source-repository head@@ -101,6 +235,10 @@   location: https://github.com/haskell/cabal/   subdir:   cabal-install +Flag old-bytestring+  description:  Use bytestring < 0.10.2 and bytestring-builder+  default: False+ Flag old-directory   description:  Use directory < 1.2 and old-time   default:      False@@ -109,49 +247,38 @@   description:  Get Network.URI from the network-uri package   default:      True +Flag debug-conflict-sets+  description:  Add additional information to ConflictSets+  default:      False++Flag debug-tracetree+  description:  Compile in support for tracetree (used to debug the solver)+  default:      False+ executable cabal     main-is:        Main.hs-    ghc-options:    -Wall -fwarn-tabs+    ghc-options:    -Wall -fwarn-tabs -rtsopts     if impl(ghc >= 8.0)         ghc-options: -Wcompat                      -Wnoncanonical-monad-instances                      -Wnoncanonical-monadfail-instances      other-modules:+        Distribution.Client.BuildTarget         Distribution.Client.BuildReports.Anonymous         Distribution.Client.BuildReports.Storage         Distribution.Client.BuildReports.Types         Distribution.Client.BuildReports.Upload         Distribution.Client.Check-        Distribution.Client.ComponentDeps+        Distribution.Client.CmdBuild+        Distribution.Client.CmdConfigure+        Distribution.Client.CmdFreeze+        Distribution.Client.CmdHaddock+        Distribution.Client.CmdRepl         Distribution.Client.Config         Distribution.Client.Configure         Distribution.Client.Dependency-        Distribution.Client.Dependency.TopDown-        Distribution.Client.Dependency.TopDown.Constraints-        Distribution.Client.Dependency.TopDown.Types         Distribution.Client.Dependency.Types-        Distribution.Client.Dependency.Modular-        Distribution.Client.Dependency.Modular.Assignment-        Distribution.Client.Dependency.Modular.Builder-        Distribution.Client.Dependency.Modular.Configured-        Distribution.Client.Dependency.Modular.ConfiguredConversion-        Distribution.Client.Dependency.Modular.Cycles-        Distribution.Client.Dependency.Modular.Dependency-        Distribution.Client.Dependency.Modular.Explore-        Distribution.Client.Dependency.Modular.Flag-        Distribution.Client.Dependency.Modular.Index-        Distribution.Client.Dependency.Modular.IndexConversion-        Distribution.Client.Dependency.Modular.Linking-        Distribution.Client.Dependency.Modular.Log-        Distribution.Client.Dependency.Modular.Message-        Distribution.Client.Dependency.Modular.Package-        Distribution.Client.Dependency.Modular.Preference-        Distribution.Client.Dependency.Modular.PSQ-        Distribution.Client.Dependency.Modular.Solver-        Distribution.Client.Dependency.Modular.Tree-        Distribution.Client.Dependency.Modular.Validate-        Distribution.Client.Dependency.Modular.Version         Distribution.Client.DistDirLayout         Distribution.Client.Exec         Distribution.Client.Fetch@@ -166,6 +293,7 @@         Distribution.Client.Haddock         Distribution.Client.HttpUtils         Distribution.Client.IndexUtils+        Distribution.Client.IndexUtils.Timestamp         Distribution.Client.Init         Distribution.Client.Init.Heuristics         Distribution.Client.Init.Licenses@@ -177,41 +305,95 @@         Distribution.Client.List         Distribution.Client.Manpage         Distribution.Client.PackageHash-        Distribution.Client.PackageIndex         Distribution.Client.PackageUtils         Distribution.Client.ParseUtils-        Distribution.Client.PkgConfigDb-        Distribution.Client.PlanIndex         Distribution.Client.ProjectBuilding+        Distribution.Client.ProjectBuilding.Types         Distribution.Client.ProjectConfig         Distribution.Client.ProjectConfig.Types         Distribution.Client.ProjectConfig.Legacy+        Distribution.Client.ProjectOrchestration         Distribution.Client.ProjectPlanning-        Distribution.Client.Run+        Distribution.Client.ProjectPlanning.Types+        Distribution.Client.ProjectPlanOutput         Distribution.Client.RebuildMonad+        Distribution.Client.Reconfigure+        Distribution.Client.Run         Distribution.Client.Sandbox         Distribution.Client.Sandbox.Index         Distribution.Client.Sandbox.PackageEnvironment         Distribution.Client.Sandbox.Timestamp         Distribution.Client.Sandbox.Types+        Distribution.Client.SavedFlags+        Distribution.Client.Security.DNS         Distribution.Client.Security.HTTP         Distribution.Client.Setup         Distribution.Client.SetupWrapper         Distribution.Client.SrcDist+        Distribution.Client.SolverInstallPlan+        Distribution.Client.SolverPlanIndex+        Distribution.Client.SourceFiles         Distribution.Client.Tar         Distribution.Client.Targets         Distribution.Client.Types         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils-        Distribution.Client.Utils.LabeledGraph+        Distribution.Client.Utils.Json         Distribution.Client.World         Distribution.Client.Win32SelfUpgrade         Distribution.Client.Compat.ExecutablePath         Distribution.Client.Compat.FilePerms+        Distribution.Client.Compat.Prelude         Distribution.Client.Compat.Process         Distribution.Client.Compat.Semaphore-        Distribution.Client.Compat.Time+        Distribution.Solver.Types.ComponentDeps+        Distribution.Solver.Types.ConstraintSource+        Distribution.Solver.Types.DependencyResolver+        Distribution.Solver.Types.InstalledPreference+        Distribution.Solver.Types.InstSolverPackage+        Distribution.Solver.Types.LabeledPackageConstraint+        Distribution.Solver.Types.OptionalStanza+        Distribution.Solver.Types.PackageConstraint+        Distribution.Solver.Types.PackageFixedDeps+        Distribution.Solver.Types.PackageIndex+        Distribution.Solver.Types.PackagePath+        Distribution.Solver.Types.PackagePreferences+        Distribution.Solver.Types.PkgConfigDb+        Distribution.Solver.Types.Progress+        Distribution.Solver.Types.ResolverPackage+        Distribution.Solver.Types.Settings+        Distribution.Solver.Types.SolverId+        Distribution.Solver.Types.SolverPackage+        Distribution.Solver.Types.SourcePackage+        Distribution.Solver.Types.Variable+        Distribution.Solver.Modular+        Distribution.Solver.Modular.Assignment+        Distribution.Solver.Modular.Builder+        Distribution.Solver.Modular.Configured+        Distribution.Solver.Modular.ConfiguredConversion+        Distribution.Solver.Modular.ConflictSet+        Distribution.Solver.Modular.Cycles+        Distribution.Solver.Modular.Degree+        Distribution.Solver.Modular.Dependency+        Distribution.Solver.Modular.Explore+        Distribution.Solver.Modular.Flag+        Distribution.Solver.Modular.Index+        Distribution.Solver.Modular.IndexConversion+        Distribution.Solver.Modular.Linking+        Distribution.Solver.Modular.LabeledGraph+        Distribution.Solver.Modular.Log+        Distribution.Solver.Modular.Message+        Distribution.Solver.Modular.Package+        Distribution.Solver.Modular.Preference+        Distribution.Solver.Modular.PSQ+        Distribution.Solver.Modular.RetryLog+        Distribution.Solver.Modular.Solver+        Distribution.Solver.Modular.Tree+        Distribution.Solver.Modular.Validate+        Distribution.Solver.Modular.Var+        Distribution.Solver.Modular.Version+        Distribution.Solver.Modular.WeightedPSQ         Paths_cabal_install      -- NOTE: when updating build-depends, don't forget to update version regexps@@ -220,12 +402,14 @@         async      >= 2.0      && < 3,         array      >= 0.4      && < 0.6,         base       >= 4.5      && < 5,+        base16-bytestring >= 0.1.1 && < 0.2,         binary     >= 0.5      && < 0.9,-        byteable   >= 0.1      && < 0.2,         bytestring >= 0.9      && < 1,         Cabal      >= 1.25     && < 1.26,         containers >= 0.4      && < 0.6,-        cryptohash >= 0.11     && < 0.12,+        cryptohash-sha256 >= 0.11 && < 0.12,+        deepseq    >= 1.3      && < 1.5,+        edit-distance >= 0.2.2 && < 0.3,         filepath   >= 1.3      && < 1.5,         hashable   >= 1.0      && < 2,         HTTP       >= 4000.1.5 && < 4000.4,@@ -233,11 +417,16 @@         pretty     >= 1.1      && < 1.2,         random     >= 1        && < 1.2,         stm        >= 2.0      && < 3,-        tar        >= 0.5.0.1  && < 0.6,+        tar        >= 0.5.0.3  && < 0.6,         time       >= 1.4      && < 1.7,         zlib       >= 0.5.3    && < 0.7,-        hackage-security >= 0.5 && < 0.6+        hackage-security >= 0.5.2.2 && < 0.6 +    if flag(old-bytestring)+      build-depends: bytestring <  0.10.2, bytestring-builder >= 0.10 && < 1+    else+      build-depends: bytestring >= 0.10.2+     if flag(old-directory)       build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2,                      process   >= 1.0.1.1  && < 1.1.0.2@@ -265,6 +454,14 @@     if !(arch(arm) && impl(ghc < 7.6))       ghc-options: -threaded +    if flag(debug-conflict-sets)+      cpp-options: -DDEBUG_CONFLICT_SETS+      build-depends: base >= 4.8++    if flag(debug-tracetree)+      cpp-options: -DDEBUG_TRACETREE+      build-depends: tracetree >= 0.1 && < 0.2+     default-language: Haskell2010  -- Small, fast running tests.@@ -276,10 +473,6 @@   other-modules:     UnitTests.Distribution.Client.ArbitraryInstances     UnitTests.Distribution.Client.Targets-    UnitTests.Distribution.Client.Compat.Time-    UnitTests.Distribution.Client.Dependency.Modular.PSQ-    UnitTests.Distribution.Client.Dependency.Modular.Solver-    UnitTests.Distribution.Client.Dependency.Modular.DSL     UnitTests.Distribution.Client.FileMonitor     UnitTests.Distribution.Client.Glob     UnitTests.Distribution.Client.GZipUtils@@ -288,13 +481,23 @@     UnitTests.Distribution.Client.Tar     UnitTests.Distribution.Client.UserConfig     UnitTests.Distribution.Client.ProjectConfig+    UnitTests.Distribution.Client.JobControl+    UnitTests.Distribution.Client.IndexUtils.Timestamp+    UnitTests.Distribution.Client.InstallPlan+    UnitTests.Distribution.Solver.Modular.PSQ+    UnitTests.Distribution.Solver.Modular.RetryLog+    UnitTests.Distribution.Solver.Modular.Solver+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.WeightedPSQ     UnitTests.Options   build-depends:         base,+        async,         array,         bytestring,         Cabal,         containers,+        deepseq,         mtl,         pretty,         process,@@ -331,8 +534,19 @@   else     build-depends: unix +  ghc-options: -fno-ignore-asserts+   if !(arch(arm) && impl(ghc < 7.6))     ghc-options: -threaded++  if flag(debug-conflict-sets)+    cpp-options: -DDEBUG_CONFLICT_SETS+    build-depends: base >= 4.8++  if flag(debug-tracetree)+      cpp-options: -DDEBUG_TRACETREE+      build-depends: tracetree >= 0.1 && < 0.2+   default-language: Haskell2010  -- Slow solver tests@@ -340,16 +554,18 @@   type: exitcode-stdio-1.0   main-is: SolverQuickCheck.hs   hs-source-dirs: tests, .-  ghc-options: -Wall -fwarn-tabs+  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts   other-modules:-    UnitTests.Distribution.Client.Dependency.Modular.DSL-    UnitTests.Distribution.Client.Dependency.Modular.QuickCheck+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.QuickCheck   build-depends:         base,+        async,         array,         bytestring,         Cabal,         containers,+        deepseq >= 1.2,         mtl,         pretty,         process,@@ -387,8 +603,18 @@    if !(arch(arm) && impl(ghc < 7.6))     ghc-options: -threaded++  if flag(debug-conflict-sets)+    cpp-options: -DDEBUG_CONFLICT_SETS+    build-depends: base >= 4.8++  if flag(debug-tracetree)+      cpp-options: -DDEBUG_TRACETREE+      build-depends: tracetree >= 0.1 && < 0.2+   default-language: Haskell2010 +-- Integration tests that call the cabal executable externally test-suite integration-tests   type: exitcode-stdio-1.0   hs-source-dirs: tests@@ -413,7 +639,65 @@   if !(arch(arm) && impl(ghc < 7.6))     ghc-options: -threaded -  ghc-options: -Wall+  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts+  default-language: Haskell2010++-- Integration tests that use the cabal-install code directly+-- but still build whole projects+test-suite integration-tests2+  type: exitcode-stdio-1.0+  main-is: IntegrationTests2.hs+  hs-source-dirs: tests, .+  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts+  other-modules:+  build-depends:+        async,+        array,+        base,+        base16-bytestring,+        binary,+        bytestring,+        Cabal,+        containers,+        cryptohash-sha256,+        deepseq,+        directory,+        filepath,+        hackage-security,+        hashable,+        HTTP,+        mtl,+        network,+        network-uri,+        pretty,+        process,+        random,+        stm,+        tar,+        time,+        zlib,+        tasty,+        tasty-hunit,+        tagged++  if flag(old-bytestring)+    build-depends: bytestring-builder++  if flag(old-directory)+    build-depends: old-time++  if impl(ghc < 7.6)+    build-depends: ghc-prim >= 0.2 && < 0.3++  if os(windows)+    build-depends: Win32+  else+    build-depends: unix++  if arch(arm)+    cc-options:  -DCABAL_NO_THREADED+  else+    ghc-options: -threaded   default-language: Haskell2010  custom-setup
cabal/cabal-install/changelog view
@@ -1,7 +1,32 @@ -*-change-log-*-  1.25.x.x (current development version)-	* Made the solver aware of pkg-config constraints (#3023).+	* Removed the '--root-cmd' parameter of the 'install' command+	(#3356).+	* Deprecated 'cabal install --global' (#3356).+	* Changed 'cabal upload' to upload a package candidate by default+	(#3419). Same applies to uploading documentation.+	* Added a new 'cabal upload' flag '--publish' for publishing a+	package on Hackage instead of uploading a candidate (#3419).+	* Added optional solver output visualisation support via the+	tracetree package. Mainly intended for debugging (#3410).+	* Removed the '--check' option from 'cabal upload'+	(#1823). It was replaced by package candidates.+	* Fixed various behaviour differences between network transports+	(#3429).+	* The bootstrap script now works correctly when run from a Git+	clone (#3439).+	* Removed the top-down solver (#3598).+	* The '-v/--verbosity' option no longer affects GHC verbosity+	(except in the case of '-v0'). Use '--ghc-options=-v' to enable+	verbose GHC output (#3540, #3671).+	* Changed the default logfile template from+	'.../$pkgid.log' to '.../$compiler/$libname.log' (#3807).+	* Added a new command, 'cabal reconfigure', which re-runs 'configure'+	with the most recently used flags (#2214).+	* Support for building Backpack packages.  See+	https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst+	for more details.  1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016 	* If there are multiple remote repos, 'cabal update' now updates@@ -57,8 +82,11 @@ 	(#3171). 	* Improved performance of '--reorder-goals' (#3208). 	* Fixed space leaks in modular solver (#2916, #2914).+	* Made the solver aware of pkg-config constraints (#3023). 	* Added a new command: 'gen-bounds' (#3223). See 	http://softwaresimply.blogspot.se/2015/08/cabal-gen-bounds-easy-generation-of.html.+	* Tech preview of new nix-style isolated project-based builds.+	Currently provides the commands (new-)build/repl/configure.  1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015 	* New command: user-config (#2159).
cabal/cabal-install/tests/IntegrationTests.hs view
@@ -9,7 +9,7 @@  -- Modules from Cabal. import Distribution.Compat.CreatePipe (createPipe)-import Distribution.Compat.Environment (setEnv)+import Distribution.Compat.Environment (setEnv, getEnvironment) import Distribution.Compat.Internal.TempFile (createTempDirectory) import Distribution.Simple.Configure (findDistPrefOrDefault) import Distribution.Simple.Program.Builtin (ghcPkgProgram)@@ -100,7 +100,11 @@     (hReadStdOut, hWriteStdOut) <- createPipe     (hReadStdErr, hWriteStdErr) <- createPipe     -- Run the process-    pid <- runProcess path' args (Just cwd) Nothing Nothing (Just hWriteStdOut) (Just hWriteStdErr)+    env0 <- getEnvironment+    -- CABAL_BUILDDIR can interfere with test running, so+    -- be sure to clear it out.+    let env = filter ((/= "CABAL_BUILDDIR") . fst) env0+    pid <- runProcess path' args (Just cwd) (Just env) Nothing (Just hWriteStdOut) (Just hWriteStdErr)     -- Return the pid and read ends of the pipes     return (pid, hReadStdOut, hReadStdErr)   -- Read subprocess output using asynchronous threads; we need to@@ -288,6 +292,8 @@   -- Define default arguments   setEnv "CABAL_ARGS" $ "--config-file=config-file"   setEnv "CABAL_ARGS_NO_CONFIG_FILE" " "+  -- Don't get Unicode output from GHC+  setEnv "LC_ALL" "C"   -- Discover all the test categories   categories <- discoverTestCategories baseDirectory   -- Discover tests in each category
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2-external.sh view
@@ -0,0 +1,9 @@+#!/bin/sh+. ./common.sh++require_ghc_ge 801++cd includes2+mv cabal.project.external cabal.project+cabal new-build exe+dist-newstyle/build/*/*/exe-*/c/exe/build/exe/exe | fgrep "minemysql minepostgresql"
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh view
@@ -0,0 +1,9 @@+#!/bin/sh+. ./common.sh++require_ghc_ge 801++cd includes2+mv cabal.project.internal cabal.project+cabal new-build exe+dist-newstyle/build/*/*/Includes2-*/c/exe/build/exe/exe | fgrep "minemysql minepostgresql"
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal view
@@ -0,0 +1,41 @@+name:                Includes2+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library mylib+  build-depends:       base+  signatures: Database+  exposed-modules:     Mine+  hs-source-dirs:      mylib+  default-language:    Haskell2010++library mysql+  build-depends:       base+  exposed-modules:     Database.MySQL+  hs-source-dirs:      mysql+  default-language:    Haskell2010++library postgresql+  build-depends:       base+  exposed-modules:     Database.PostgreSQL+  hs-source-dirs:      postgresql+  default-language:    Haskell2010++library+  build-depends:       base, mysql, postgresql, mylib+  mixins:+    mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL),+    mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL)+  exposed-modules:     App+  hs-source-dirs:      src+  default-language:    Haskell2010++executable exe+  build-depends:       base, Includes2+  main-is:             Main.hs+  hs-source-dirs:      exe+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external view
@@ -0,0 +1,1 @@+packages: mylib mysql src exe postgresql
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal view
@@ -0,0 +1,1 @@+packages: .
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs view
@@ -0,0 +1,3 @@+import App++main = print app
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/exe/exe.cabal view
@@ -0,0 +1,12 @@+name:                exe+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++executable exe+  build-depends:       base, src+  main-is:             Main.hs+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig view
@@ -0,0 +1,3 @@+signature Database where+data Database+databaseName :: String
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs view
@@ -0,0 +1,4 @@+module Mine where+import Database+data Mine = Mine Database+mine = "mine" ++ databaseName
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal view
@@ -0,0 +1,13 @@+name:                mylib+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  signatures: Database+  exposed-modules:     Mine+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs view
@@ -0,0 +1,3 @@+module Database.MySQL where+data Database = Database Int+databaseName = "mysql"
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal view
@@ -0,0 +1,12 @@+name:                mysql+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  exposed-modules:     Database.MySQL+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs view
@@ -0,0 +1,3 @@+module Database.PostgreSQL where+data Database = Database Bool+databaseName = "postgresql"
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal view
@@ -0,0 +1,12 @@+name:                postgresql+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  exposed-modules:     Database.PostgreSQL+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs view
@@ -0,0 +1,7 @@+module App where+import Database.MySQL+import Database.PostgreSQL+import qualified Mine.MySQL+import qualified Mine.PostgreSQL++app = Mine.MySQL.mine ++ " " ++ Mine.PostgreSQL.mine
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal view
@@ -0,0 +1,15 @@+name:                src+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base, mysql, postgresql, mylib+  mixins:+    mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL),+    mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL)+  exposed-modules:     App+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3-external.sh view
@@ -0,0 +1,9 @@+#!/bin/sh+. ./common.sh++require_ghc_ge 801++cd includes3+mv cabal.project.external cabal.project+cabal new-build exe+dist-newstyle/build/*/*/exe-*/c/exe/build/exe/exe | fgrep "fromList [(0,2),(2,4)]"
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh view
@@ -0,0 +1,9 @@+#!/bin/sh+. ./common.sh++require_ghc_ge 801++cd includes3+mv cabal.project.internal cabal.project+cabal new-build exe+dist-newstyle/build/*/*/Includes3-*/c/exe/build/exe/exe | fgrep "fromList [(0,2),(2,4)]"
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal view
@@ -0,0 +1,23 @@+name:                Includes3+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library sigs+  build-depends:       base+  signatures: Data.Map+  hs-source-dirs:      sigs++library indef+  build-depends:       base, sigs+  exposed-modules:     Foo+  hs-source-dirs:      indef++executable exe+  build-depends:       base, containers, indef+  main-is:             Main.hs+  hs-source-dirs:      exe+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external view
@@ -0,0 +1,1 @@+packages: exe indef sigs
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal view
@@ -0,0 +1,1 @@+packages: .
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Main.hs view
@@ -0,0 +1,4 @@+import qualified Data.Map as Map+import Data.Map (Map)+import Foo+main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int)
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/exe.cabal view
@@ -0,0 +1,12 @@+name:                exe+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++executable exe+  build-depends:       base, containers, indef+  main-is:             Main.hs+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Foo.hs view
@@ -0,0 +1,6 @@+module Foo where++import Data.Map++f :: (a -> b) -> Map k a -> Map k b+f = fmap
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal view
@@ -0,0 +1,11 @@+name:                indef+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base, sigs+  exposed-modules:     Foo
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Data/Map.hsig view
@@ -0,0 +1,5 @@+{-# LANGUAGE RoleAnnotations #-}+signature Data.Map where+type role Map nominal representational+data Map k a+instance Functor (Map k)
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal view
@@ -0,0 +1,11 @@+name:                sigs+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  signatures: Data.Map
cabal/cabal-install/tests/IntegrationTests/common.sh view
@@ -10,3 +10,19 @@     echo "die: $@"     exit 1 }++require_ghc_le() {+    GHCVER="$(echo main = print __GLASGOW_HASKELL__ | runghc -XCPP)"+    if [ "$GHCVER" -gt "$1" ]; then+        echo "Skipping test that needs GHC <= $1 (actual version $GHCVER)"+        exit 0+    fi+}++require_ghc_ge() {+    GHCVER="$(echo main = print __GLASGOW_HASKELL__ | runghc -XCPP)"+    if [ "$GHCVER" -lt "$1" ]; then+        echo "Skipping test that needs GHC >= $1 (actual version $GHCVER)"+        exit 0+    fi+}
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/Cabal.cabal view
@@ -0,0 +1,8 @@+name: Cabal+version: 99998+build-type: Simple+cabal-version: >= 1.2++library+  build-depends: base+  exposed-modules: CabalMessage
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/CabalMessage.hs view
@@ -0,0 +1,3 @@+module CabalMessage where++message = "This is Cabal-99998"
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/Cabal.cabal view
@@ -0,0 +1,8 @@+name: Cabal+version: 99999+build-type: Simple+cabal-version: >= 1.2++library+  build-depends: base+  exposed-modules: CabalMessage
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/CabalMessage.hs view
@@ -0,0 +1,3 @@+module CabalMessage where++message = "This is Cabal-99999"
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/Setup.hs view
@@ -0,0 +1,5 @@+import CabalMessage (message)+import System.Exit+import System.IO++main = hPutStrLn stderr message >> exitFailure
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/custom-setup-old-cabal.cabal view
@@ -0,0 +1,8 @@+name: custom-setup+version: 1.0+build-type: Custom++custom-setup+  setup-depends: base, Cabal < 1.20++library
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal view
@@ -0,0 +1,9 @@+name: custom-setup-without-cabal-defaultMain+version: 1.0+build-type: Custom+cabal-version: >= 1.2++custom-setup+  setup-depends: base++library
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/Setup.hs view
@@ -0,0 +1,4 @@+import System.Exit+import System.IO++main = hPutStrLn stderr "My custom Setup" >> exitFailure
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/custom-setup-without-cabal.cabal view
@@ -0,0 +1,9 @@+name: custom-setup-without-cabal+version: 1.0+build-type: Custom+cabal-version: >= 99999++custom-setup+  setup-depends: base++library
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/Setup.hs view
@@ -0,0 +1,5 @@+import CabalMessage (message)+import System.Exit+import System.IO++main = hPutStrLn stderr message >> exitFailure
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/custom-setup.cabal view
@@ -0,0 +1,9 @@+name: custom-setup+version: 1.0+build-type: Custom+cabal-version: >= 99999++custom-setup+  setup-depends: base, Cabal >= 99999++library
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh view
@@ -0,0 +1,12 @@+. ./common.sh+cd custom-setup-without-cabal-defaultMain++# This package has explicit setup dependencies that do not include Cabal.+# Compilation should fail because Setup.hs imports Distribution.Simple.+! cabal new-build custom-setup-without-cabal-defaultMain > output 2>&1+cat output+grep -q "\(Could not find module\|Failed to load interface for\).*Distribution\\.Simple" output \+    || die "Should not have been able to import Cabal"++grep -q "It is a member of the hidden package .*Cabal-" output \+    || die "Cabal should be available"
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_require_Cabal.sh view
@@ -0,0 +1,11 @@+. ./common.sh+cd custom-setup-without-cabal++# This package has explicit setup dependencies that do not include Cabal.+# new-build should try to build it, even though the cabal-version cannot be+# satisfied by an installed version of Cabal (cabal-version: >= 99999). However,+# configure should fail because Setup.hs just prints an error message and exits.+! cabal new-build custom-setup-without-cabal > output 2>&1+cat output+grep -q "My custom Setup" output \+    || die "Expected output from custom Setup"
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/installs_Cabal_as_setup_dep.sh view
@@ -0,0 +1,15 @@+# Regression test for issue #3436++. ./common.sh+cabal sandbox init+cabal install ./Cabal-99998+cabal sandbox add-source Cabal-99999++# Install custom-setup, which has a setup dependency on Cabal-99999.+# cabal should build the setup script with Cabal-99999, but then+# configure should fail because Setup just prints an error message+# imported from Cabal and exits.+! cabal install custom-setup/ > output 2>&1++cat output+grep -q "This is Cabal-99999" output || die "Expected output from Cabal-99999"
+ cabal/cabal-install/tests/IntegrationTests/custom-setup/new_build_requires_Cabal_1_20.sh view
@@ -0,0 +1,9 @@+# Regression test for issue #3932++. ./common.sh++cd custom-setup-old-cabal+! cabal new-build > output 2>&1++cat output+grep -q "(issue #3932) requires >=1.20" output || die "Expect constraint failure"
+ cabal/cabal-install/tests/IntegrationTests/custom/custom_dep.sh view
@@ -0,0 +1,22 @@+. ./common.sh++# On Travis OSX, Cabal shipped with GHC 7.8 does not work+# with error "setup: /usr/bin/ar: permission denied"; see+# also https://github.com/haskell/cabal/issues/3938+# This is a hack to make the test not run in this case.+if [ "$TRAVIS_OS_NAME" = "osx" ]; then+    require_ghc_ge 710+fi++cd custom_dep+cabal sandbox init+cabal sandbox add-source custom+cabal sandbox add-source client+# Some care must be taken here: we want the Setup script+# to build against GHC's bundled Cabal, but passing+# --package-db=clear --package-db=global to cabal is+# insufficient, as these flags are NOT respected when+# building Setup scripts.  Changing HOME to a location+# which definitely does not have a local .cabal+# directory works, the environment variable propagates to GHC.+HOME=`pwd` cabal install client
+ cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/B.hs view
@@ -0,0 +1,2 @@+module B where+import A
+ cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/client.cabal view
@@ -0,0 +1,12 @@+name:                client+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     B+  build-depends:       base, custom+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/A.hs view
@@ -0,0 +1,1 @@+module A where
+ cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/custom.cabal view
@@ -0,0 +1,12 @@+name:                custom+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Custom+cabal-version:       >=1.10++library+  exposed-modules:     A+  build-depends:       base+  default-language:    Haskell2010
− cabal/cabal-install/tests/IntegrationTests/custom/plain.err 
@@ -1,2 +0,0 @@-Custom-Custom
cabal/cabal-install/tests/IntegrationTests/custom/plain.sh view
@@ -1,4 +1,15 @@ . ./common.sh++# On Travis OSX, Cabal shipped with GHC 7.8 does not work+# with error "setup: /usr/bin/ar: permission denied"; see+# also https://github.com/haskell/cabal/issues/3938+# This is a hack to make the test not run in this case.+if [ "$TRAVIS_OS_NAME" = "osx" ]; then+    require_ghc_ge 710+fi+ cd plain-cabal configure-cabal build+cabal configure 2> log+grep Custom log+cabal build 2> log+grep Custom log
+ cabal/cabal-install/tests/IntegrationTests/custom/segfault.sh view
@@ -0,0 +1,10 @@+. ./common.sh+if [ "x$(uname)" != "xLinux" ]; then+    exit+fi+# Older GHCs don't report exit via signal adequately+require_ghc_ge 708+cd segfault+! cabal new-build 2> log+cat log+grep SIGSEGV log
+ cabal/cabal-install/tests/IntegrationTests/custom/segfault/Setup.hs view
@@ -0,0 +1,3 @@+import System.Posix.Signals++main = putStrLn "Quitting..." >> raiseSignal sigSEGV
+ cabal/cabal-install/tests/IntegrationTests/custom/segfault/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ cabal/cabal-install/tests/IntegrationTests/custom/segfault/plain.cabal view
@@ -0,0 +1,14 @@+name:                plain+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Custom+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010++custom-setup+  setup-depends: base, unix
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/cabal.project view
@@ -0,0 +1,1 @@+packages: p q
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh view
@@ -0,0 +1,3 @@+. ./common.sh++cabal new-build p
+ cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cd BuildToolsPath+cabal new-build build-tools-path hello-world
+ cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/A.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-}+module A where++a :: String+a = "0000"
+ cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment+import System.IO++main :: IO ()+main = do+  (_:source:target:_) <- getArgs+  let f '0' = '1'+      f c = c+  writeFile target . map f  =<< readFile source
+ cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal view
@@ -0,0 +1,25 @@+name:                build-tools-path+version:             0.1.0.0+synopsis:            Checks build-tools are put in PATH+license:             BSD3+category:            Testing+build-type:          Simple+cabal-version:       >=1.10++executable             my-custom-preprocessor+  main-is:             MyCustomPreprocessor.hs+  build-depends:       base, directory+  default-language:    Haskell2010++library+  exposed-modules:     A+  build-depends:       base+  build-tools:         my-custom-preprocessor+  -- ^ Note the internal dependency.+  default-language:    Haskell2010++executable             hello-world+  main-is:             Hello.hs+  build-depends:       base, build-tools-path+  default-language:    Haskell2010+  hs-source-dirs:      hello
+ cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs view
@@ -0,0 +1,6 @@+module Main where++import A++main :: IO ()+main = putStrLn a
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cd T3460+cabal new-build -j T3460
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/C.hs view
@@ -0,0 +1,3 @@+module C where+import A+import B
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/T3460.cabal view
@@ -0,0 +1,22 @@+-- Initial T3460.cabal generated by cabal init.  For further documentation,+--  see http://haskell.org/cabal/users-guide/++name:                T3460+version:             0.1.0.0+-- synopsis:            +-- description:         +license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+-- copyright:           +-- category:            +build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     C+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base, sub-package-A, sub-package-B+  -- hs-source-dirs:      +  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/cabal.project view
@@ -0,0 +1,3 @@+packages: ./T3460.cabal+        , ./sub-package-A+        , ./sub-package-B
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/A.hs view
@@ -0,0 +1,1 @@+module A where
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/sub-package-A.cabal view
@@ -0,0 +1,22 @@+-- Initial sub-package-A.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                sub-package-A+version:             0.1.0.0+-- synopsis:            +-- description:         +license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+-- copyright:           +-- category:            +build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     A+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base+  -- hs-source-dirs:      +  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs view
@@ -0,0 +1,1 @@+module B where
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal view
@@ -0,0 +1,22 @@+-- Initial sub-package-B.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                sub-package-B+version:             0.1.0.0+-- synopsis:            +-- description:         +license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+-- copyright:           +-- category:            +build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     B+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base+  -- hs-source-dirs:      +  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3978.err view
@@ -0,0 +1,1 @@+RE:^cabal(\.exe)?: The package q-1.0 depends on unbuildable libraries: p-1.0
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3978.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cd T3978+! cabal new-build q
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3978/cabal.project view
@@ -0,0 +1,2 @@+packages: p q+allow-older: p:base
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3978/p/p.cabal view
@@ -0,0 +1,7 @@+name: p+version: 1.0+build-type: Simple+cabal-version: >= 1.10++library+    buildable: False
+ cabal/cabal-install/tests/IntegrationTests/new-build/T3978/q/q.cabal view
@@ -0,0 +1,7 @@+name: q+version: 1.0+build-type: Simple+cabal-version: >= 1.10++library+    build-depends: p
+ cabal/cabal-install/tests/IntegrationTests/new-build/T4017.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cd T4017+cabal new-build q
+ cabal/cabal-install/tests/IntegrationTests/new-build/T4017/cabal.project view
@@ -0,0 +1,2 @@+packages: p q+allow-older: p:base
+ cabal/cabal-install/tests/IntegrationTests/new-build/T4017/p/p.cabal view
@@ -0,0 +1,7 @@+name: p+version: 1.0+build-type: Simple+cabal-version: >= 1.10++library+    build-depends: base >= 99999
+ cabal/cabal-install/tests/IntegrationTests/new-build/T4017/q/q.cabal view
@@ -0,0 +1,7 @@+name: q+version: 1.0+build-type: Simple+cabal-version: >= 1.10++library+    build-depends: p
+ cabal/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs view
@@ -0,0 +1,1 @@+main = return ()
+ cabal/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs view
@@ -0,0 +1,1 @@+main = return ()
+ cabal/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal view
@@ -0,0 +1,15 @@+name: a+version: 0.1+cabal-version: >= 1.10+build-type: Simple++executable aexe+  main-is: Main.hs+  build-depends: base+  default-language: Haskell2010++test-suite atest+  type: exitcode-stdio-1.0+  main-is: Test.hs+  build-depends: base+  default-language: Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cd external_build_tools+cabal new-build client
+ cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/cabal.project view
@@ -0,0 +1,1 @@+packages: client, happy
+ cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -F -pgmF happy #-}+module Main where++a :: String+a = "0000"++main :: IO ()+main = putStrLn a
+ cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/client.cabal view
@@ -0,0 +1,13 @@+name:                client+version:             0.1.0.0+synopsis:            Checks build-tools are put in PATH+license:             BSD3+category:            Testing+build-type:          Simple+cabal-version:       >=1.10++executable             hello-world+  main-is:             Hello.hs+  build-depends:       base+  build-tools:         happy+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment+import System.IO++main :: IO ()+main = do+  (_:source:target:_) <- getArgs+  let f '0' = '1'+      f c = c+  writeFile target . map f  =<< readFile source
+ cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal view
@@ -0,0 +1,12 @@+name:                happy+version:             999.999.999+synopsis:            Checks build-tools on legacy package name are put in PATH+license:             BSD3+category:            Testing+build-type:          Simple+cabal-version:       >=1.10++executable             happy+  main-is:             MyCustomPreprocessor.hs+  build-depends:       base, directory+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files.sh view
@@ -0,0 +1,8 @@+. ./common.sh+cd monitor_cabal_files+cp q/q-broken.cabal.in q/q.cabal+echo "Run 1" | awk '{print;print > "/dev/stderr"}'+! cabal new-build q+cp q/q-fixed.cabal.in q/q.cabal+echo "Run 2" | awk '{print;print > "/dev/stderr"}'+cabal new-build q
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/.gitignore view
@@ -0,0 +1,1 @@+q/q.cabal
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project view
@@ -0,0 +1,4 @@+packages: p/p.cabal q/++-- use both matching a .cabal file, and a dir+-- since these are slightly different code paths
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs view
@@ -0,0 +1,1 @@+module P where
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal view
@@ -0,0 +1,12 @@+name:                p+version:             1.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     P+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs view
@@ -0,0 +1,4 @@+module Main where+import P+main :: IO ()+main = return ()
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in view
@@ -0,0 +1,12 @@+name:                q+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable q+  main-is:             Main.hs+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in view
@@ -0,0 +1,12 @@+name:                q+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable q+  main-is:             Main.hs+  build-depends:       base, p+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/regression/t2755.sh view
@@ -0,0 +1,6 @@+. ./common.sh++cd t2755+cabal configure --enable-tests+(cabal test || true) | tee result.log+! grep "Re-configuring" result.log > /dev/null
+ cabal/cabal-install/tests/IntegrationTests/regression/t2755/A.hs view
@@ -0,0 +1,1 @@+module A where
+ cabal/cabal-install/tests/IntegrationTests/regression/t2755/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/regression/t2755/test-t2755.cabal view
@@ -0,0 +1,13 @@+name:                test-t2755+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+category:            Test+build-type:          Simple+cabal-version:       >=1.10++library+    exposed-modules: A+    build-depends: base+    default-language: Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/regression/t3199.sh view
@@ -0,0 +1,12 @@+. ./common.sh++if [[ `ghc --numeric-version` =~ "7\\." ]]; then+    cd t3199+    tmpfile=$(mktemp /tmp/cabal-t3199.XXXXXX)+    cabal sandbox init+    cabal sandbox add-source ../../../../../Cabal+    cabal install --package-db=clear --package-db=global --only-dep --dry-run > $tmpfile+    grep -q "the following would be installed" $tmpfile || die "Should've installed Cabal"+    grep -q Cabal $tmpfile || die "Should've installed Cabal"+    rm $tmpfile+fi
+ cabal/cabal-install/tests/IntegrationTests/regression/t3199/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ cabal/cabal-install/tests/IntegrationTests/regression/t3199/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/regression/t3199/test-3199.cabal view
@@ -0,0 +1,27 @@+name:                test-t3199+version:             0.1.0.0+license:             BSD3+author:              Mikhail Glushenkov+maintainer:          mikhail.glushenkov@gmail.com+category:            Test+build-type:          Custom+cabal-version:       >=1.10++flag exe_2+     description: Build second exe+     default:     False++executable test-3199-1+  main-is:             Main.hs+  build-depends:       base+  default-language:    Haskell2010++executable test-3199-2+  main-is:             Main.hs+  build-depends:       base, ansi-terminal+  default-language:    Haskell2010++  if flag(exe_2)+     buildable: True+  else+     buildable: False
+ cabal/cabal-install/tests/IntegrationTests/regression/t3827.sh view
@@ -0,0 +1,4 @@+. ./common.sh++cd t3827+cabal new-build exe:q
+ cabal/cabal-install/tests/IntegrationTests/regression/t3827/cabal.project view
@@ -0,0 +1,4 @@+packages: p q+profiling-detail: all-functions+package q+    profiling: True
+ cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/P.hs view
@@ -0,0 +1,2 @@+module P where+p = True
+ cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/p.cabal view
@@ -0,0 +1,8 @@+name:           p+version:        1.0+build-type:     Simple+cabal-version:  >= 1.10++library+    build-depends: base+    exposed-modules: P
+ cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/Main.hs view
@@ -0,0 +1,3 @@+module Main where+import P+main = print p
+ cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/q.cabal view
@@ -0,0 +1,8 @@+name:           q+version:        1.0+build-type:     Simple+cabal-version:  >= 1.10++executable q+    build-depends: base, p+    main-is: Main.hs
+ cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/Main.hs view
@@ -0,0 +1,4 @@+import Q (message)++main :: IO ()+main = putStrLn message
+ cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/p.cabal view
@@ -0,0 +1,8 @@+name: p+version: 1.0+build-type: Simple+cabal-version: >= 1.2++executable p+  main-is: Main.hs+  build-depends: q, base
+ cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/Q.hs view
@@ -0,0 +1,4 @@+module Q where++message :: String+message = "message"
+ cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/q.cabal view
@@ -0,0 +1,8 @@+name: q+version: 1.0+build-type: Simple+cabal-version: >= 1.2++library+  build-depends: base+  exposed-modules: Q
+ cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/reinstall-modified-source.sh view
@@ -0,0 +1,16 @@+. ./common.sh++cd p+cabal sandbox init+cabal sandbox add-source ../q++cabal install --only-dependencies+cabal run p -v0 | grep -q '^message$' \+    || die "Expected \"message\" in p's output."++sleep 1+# Append to the string that p imports from q and prints:+echo '       ++ " updated"' >> ../q/Q.hs++cabal run p -v0 | grep -q '^message updated$' \+    || die "Expected \"message updated\" in p's output."
+ cabal/cabal-install/tests/IntegrationTests2.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Distribution.Client.DistDirLayout+import Distribution.Client.ProjectConfig+import Distribution.Client.Config (defaultCabalDir)+import Distribution.Client.ProjectPlanning+import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.ProjectBuilding+import qualified Distribution.Client.InstallPlan as InstallPlan++import Distribution.Package+import Distribution.PackageDescription+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Simple.Setup (toFlag)+import Distribution.Simple.Compiler+import Distribution.System+import Distribution.Version+import Distribution.Verbosity+import Distribution.Text++import Data.Monoid+import qualified Data.Map as Map+import Control.Monad+import Control.Exception+import System.FilePath+import System.Directory++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options+import Data.Tagged (Tagged(..))+import Data.Proxy  (Proxy(..))+import Data.Typeable (Typeable)+++main :: IO ()+main =+  defaultMainWithIngredients+    (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions])+    (withProjectConfig $ \config ->+      testGroup "Integration tests (internal)"+                (tests config))++tests :: ProjectConfig -> [TestTree]+tests config =+    --TODO: tests for:+    -- * normal success+    -- * dry-run tests with changes+  [ testGroup "Exceptions during discovey and planning" $+    [ testCase "no package"  (testExceptionInFindingPackage config)+    , testCase "no package2" (testExceptionInFindingPackage2 config)+    , testCase "proj conf1"  (testExceptionInProjectConfig config)+    ]+  , testGroup "Exceptions during building (local inplace)" $+    [ testCase "configure"   (testExceptionInConfigureStep config)+    , testCase "build"       (testExceptionInBuildStep config)+--    , testCase "register"   testExceptionInRegisterStep+    ]+    --TODO: need to repeat for packages for the store++  , testGroup "Successful builds" $+    [ testCaseSteps "Setup script styles" (testSetupScriptStyles config)+    , testCase      "keep-going"          (testBuildKeepGoing config)+    ]++  , testGroup "Regression tests" $+    [ testCase "issue #3324" (testRegressionIssue3324 config)+    ]+  ]++testExceptionInFindingPackage :: ProjectConfig -> Assertion+testExceptionInFindingPackage config = do+    BadPackageLocations _ locs <- expectException "BadPackageLocations" $+      void $ planProject testdir config+    case locs of+      [BadLocGlobEmptyMatch "./*.cabal"] -> return ()+      _ -> assertFailure "expected BadLocGlobEmptyMatch"+    cleanProject testdir+  where+    testdir = "exception/no-pkg"+++testExceptionInFindingPackage2 :: ProjectConfig -> Assertion+testExceptionInFindingPackage2 config = do+    BadPackageLocations _ locs <- expectException "BadPackageLocations" $+      void $ planProject testdir config+    case locs of+      [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return ()+      _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs+    cleanProject testdir+  where+    testdir = "exception/no-pkg2"+++testExceptionInProjectConfig :: ProjectConfig -> Assertion+testExceptionInProjectConfig config = do+    BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $+      void $ planProject testdir config+    case ps of+      [(pn,"ghc")] | mkPackageName "foo" == pn -> return ()+      _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got "+                        ++ show ps+    cleanProject testdir+  where+    testdir = "exception/bad-config"+++testExceptionInConfigureStep :: ProjectConfig -> Assertion+testExceptionInConfigureStep config = do+    (plan, res) <- executePlan =<< planProject testdir config+    (_pkga1, failure) <- expectPackageFailed plan res pkgidA1+    case buildFailureReason failure of+      ConfigureFailed _ -> return ()+      _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure +    cleanProject testdir+  where+    testdir = "exception/configure"+    pkgidA1 = PackageIdentifier (mkPackageName "a") (mkVersion [1])+++testExceptionInBuildStep :: ProjectConfig -> Assertion+testExceptionInBuildStep config = do+    (plan, res) <- executePlan =<< planProject testdir config+    (_pkga1, failure) <- expectPackageFailed plan res pkgidA1+    expectBuildFailed failure+  where+    testdir = "exception/build"+    pkgidA1 = PackageIdentifier (mkPackageName "a") (mkVersion [1])++testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion+testSetupScriptStyles config reportSubCase = do++  reportSubCase (show SetupCustomExplicitDeps)++  plan0@(_,_,sharedConfig,_,_) <- planProject testdir1 config++  let isOSX (Platform _ OSX) = True+      isOSX _ = False+  -- Skip the Custom tests when the shipped Cabal library is buggy+  unless (isOSX (pkgConfigPlatform sharedConfig)+       && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do++    (plan1, res1) <- executePlan plan0+    (pkg1,  _)    <- expectPackageInstalled plan1 res1 pkgidA+    elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps+    hasDefaultSetupDeps pkg1 @?= Just False+    marker1 <- readFile (basedir </> testdir1 </> "marker")+    marker1 @?= "ok"+    removeFile (basedir </> testdir1 </> "marker")++    reportSubCase (show SetupCustomImplicitDeps)+    (plan2, res2) <- executePlan =<< planProject testdir2 config+    (pkg2,  _)    <- expectPackageInstalled plan2 res2 pkgidA+    elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps+    hasDefaultSetupDeps pkg2 @?= Just True+    marker2 <- readFile (basedir </> testdir2 </> "marker")+    marker2 @?= "ok"+    removeFile (basedir </> testdir2 </> "marker")++    reportSubCase (show SetupNonCustomInternalLib)+    (plan3, res3) <- executePlan =<< planProject testdir3 config+    (pkg3,  _)    <- expectPackageInstalled plan3 res3 pkgidA+    elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib+{-+    --TODO: the SetupNonCustomExternalLib case is hard to test since it+    -- requires a version of Cabal that's later than the one we're testing+    -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0+    -- and a corresponding Cabal package that we can use to try and build a+    -- default Setup.hs.+    reportSubCase (show SetupNonCustomExternalLib)+    (plan4, res4) <- executePlan =<< planProject testdir4 config+    (pkg4,  _)    <- expectPackageInstalled plan4 res4 pkgidA+    pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib+-}+  where+    testdir1 = "build/setup-custom1"+    testdir2 = "build/setup-custom2"+    testdir3 = "build/setup-simple"+    pkgidA   = PackageIdentifier (mkPackageName "a") (mkVersion [0,1])+    -- The solver fills in default setup deps explicitly, but marks them as such+    hasDefaultSetupDeps = fmap defaultSetupDepends+                        . setupBuildInfo . elabPkgDescription++-- | Test the behaviour with and without @--keep-going@+--+testBuildKeepGoing :: ProjectConfig -> Assertion+testBuildKeepGoing config = do+    -- P is expected to fail, Q does not depend on P but without+    -- parallel build and without keep-going then we don't build Q yet.+    (plan1, res1) <- executePlan =<< planProject testdir (config  <> keepGoing False)+    (_, failure1) <- expectPackageFailed plan1 res1 pkgidP+    expectBuildFailed failure1+    _ <- expectPackageConfigured plan1 res1 pkgidQ++    -- With keep-going then we should go on to sucessfully build Q+    (plan2, res2) <- executePlan+                 =<< planProject testdir (config <> keepGoing True)+    (_, failure2) <- expectPackageFailed plan2 res2 pkgidP+    expectBuildFailed failure2+    _ <- expectPackageInstalled plan2 res2 pkgidQ+    return ()+  where+    testdir = "build/keep-going"+    pkgidP  = PackageIdentifier (mkPackageName "p") (mkVersion [0,1])+    pkgidQ  = PackageIdentifier (mkPackageName "q") (mkVersion [0,1])+    keepGoing kg =+      mempty {+        projectConfigBuildOnly = mempty {+          projectConfigKeepGoing = toFlag kg+        }+      }++-- | See <https://github.com/haskell/cabal/issues/3324>+--+testRegressionIssue3324 :: ProjectConfig -> Assertion+testRegressionIssue3324 config = do+    -- expected failure first time due to missing dep+    (plan1, res1) <- executePlan =<< planProject testdir config+    (_pkgq, failure) <- expectPackageFailed plan1 res1 pkgidQ+    expectBuildFailed failure++    -- add the missing dep, now it should work+    let qcabal  = basedir </> testdir </> "q" </> "q.cabal"+    withFileFinallyRestore qcabal $ do+      appendFile qcabal ("  build-depends: p\n")+      (plan2, res2) <- executePlan =<< planProject testdir config+      _ <- expectPackageInstalled plan2 res2 pkgidP+      _ <- expectPackageInstalled plan2 res2 pkgidQ+      return ()+  where+    testdir = "regression/3324"+    pkgidP  = PackageIdentifier (mkPackageName "p") (mkVersion [0,1])+    pkgidQ  = PackageIdentifier (mkPackageName "q") (mkVersion [0,1])+++---------------------------------+-- Test utils to plan and build+--++basedir :: FilePath+basedir = "tests" </> "IntegrationTests2"++planProject :: FilePath -> ProjectConfig -> IO PlanDetails+planProject testdir cliConfig = do+    cabalDir <- defaultCabalDir+    let cabalDirLayout = defaultCabalDirLayout cabalDir++    projectRootDir <- canonicalizePath ("tests" </> "IntegrationTests2"+                                                </> testdir)+    let distDirLayout = defaultDistDirLayout projectRootDir++    -- Clear state between test runs. The state remains if the previous run+    -- ended in an exception (as we leave the files to help with debugging).+    cleanProject testdir++    (elaboratedPlan, _, elaboratedShared, projectConfig) <-+      rebuildInstallPlan verbosity+                         projectRootDir distDirLayout cabalDirLayout+                         cliConfig++    let targets =+          Map.fromList+            [ (installedUnitId elab, [BuildDefaultComponents])+            | InstallPlan.Configured elab <- InstallPlan.toList elaboratedPlan+            , elabBuildStyle elab == BuildInplaceOnly ]+        elaboratedPlan' = pruneInstallPlanToTargets targets elaboratedPlan++    pkgsBuildStatus <-+      rebuildTargetsDryRun distDirLayout elaboratedShared+                           elaboratedPlan'++    let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages+                             pkgsBuildStatus elaboratedPlan'++    let buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          (projectConfigShared    projectConfig)+                          (projectConfigBuildOnly projectConfig)+                          (projectConfigBuildOnly cliConfig)++    return (distDirLayout,+            elaboratedPlan'',+            elaboratedShared,+            pkgsBuildStatus,+            buildSettings)++type PlanDetails = (DistDirLayout,+                    ElaboratedInstallPlan,+                    ElaboratedSharedConfig,+                    BuildStatusMap,+                    BuildTimeSettings)++executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes)+executePlan (distDirLayout,+             elaboratedPlan,+             elaboratedShared,+             pkgsBuildStatus,+             buildSettings) =+    fmap ((,) elaboratedPlan) $+    rebuildTargets verbosity+                   distDirLayout+                   elaboratedPlan+                   elaboratedShared+                   pkgsBuildStatus+                   -- Avoid trying to use act-as-setup mode:+                   buildSettings { buildSettingNumJobs = 1 }++cleanProject :: FilePath -> IO ()+cleanProject testdir = do+    alreadyExists <- doesDirectoryExist distDir+    when alreadyExists $ removeDirectoryRecursive distDir+  where+    projectRootDir = "tests" </> "IntegrationTests2" </> testdir+    distDirLayout  = defaultDistDirLayout projectRootDir+    distDir        = distDirectory distDirLayout+++verbosity :: Verbosity+verbosity = minBound --normal --verbose --maxBound --minBound++++-------------------------------------------+-- Tasty integration to adjust the config+--++withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree+withProjectConfig testtree =+    askOption $ \ghcPath ->+      testtree (mkProjectConfig ghcPath)++mkProjectConfig :: GhcPath -> ProjectConfig+mkProjectConfig (GhcPath ghcPath) =+    mempty {+      projectConfigShared = mempty {+        projectConfigHcPath = maybeToFlag ghcPath+      },+     projectConfigBuildOnly = mempty {+       projectConfigNumJobs = toFlag (Just 1)+     }+    }+  where+    maybeToFlag = maybe mempty toFlag+++data GhcPath = GhcPath (Maybe FilePath)+  deriving Typeable++instance IsOption GhcPath where+  defaultValue = GhcPath Nothing+  optionName   = Tagged "with-ghc"+  optionHelp   = Tagged "The ghc compiler to use"+  parseValue   = Just . GhcPath . Just++projectConfigOptionDescriptions :: [OptionDescription]+projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)]+++---------------------------------------+-- HUint style utils for this context+--++expectException :: Exception e => String -> IO a -> IO e+expectException expected action = do+    res <- try action+    case res of+      Left  e -> return e+      Right _ -> throwIO $ HUnitFailure $ "expected an exception " ++ expected++expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                         -> IO InstalledPackageInfo+expectPackagePreExisting plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.PreExisting pkg, Nothing)+                       -> return pkg+      (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult++expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                        -> IO ElaboratedConfiguredPackage+expectPackageConfigured plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Nothing)+                       -> return pkg+      (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult++expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                       -> IO (ElaboratedConfiguredPackage, BuildResult)+expectPackageInstalled plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Just (Right result))+                       -> return (pkg, result)+      (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult++expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                    -> IO (ElaboratedConfiguredPackage, BuildFailure)+expectPackageFailed plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Just (Left failure))+                       -> return (pkg, failure)+      (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult++unexpectedBuildResult :: String -> ElaboratedPlanPackage+                      -> Maybe (Either BuildFailure BuildResult) -> IO a+unexpectedBuildResult expected planpkg buildResult =+    throwIO $ HUnitFailure $+         "expected to find " ++ display (packageId planpkg) ++ " in the "+      ++ expected ++ " state, but it is actually in the " ++ actual ++ " state."+  where+    actual = case (buildResult, planpkg) of+      (Nothing, InstallPlan.PreExisting{})       -> "PreExisting"+      (Nothing, InstallPlan.Configured{})        -> "Configured"+      (Just (Right _), InstallPlan.Configured{}) -> "Installed"+      (Just (Left  _), InstallPlan.Configured{}) -> "Failed"+      _                                          -> "Impossible!"++expectPlanPackage :: ElaboratedInstallPlan -> PackageId+                  -> IO ElaboratedPlanPackage+expectPlanPackage plan pkgid =+    case [ pkg+         | pkg <- InstallPlan.toList plan+         , packageId pkg == pkgid ] of+      [pkg] -> return pkg+      []    -> throwIO $ HUnitFailure $+                   "expected to find " ++ display pkgid+                ++ " in the install plan but it's not there"+      _     -> throwIO $ HUnitFailure $+                   "expected to find only one instance of " ++ display pkgid+                ++ " in the install plan but there's several"++expectBuildFailed :: BuildFailure -> IO ()+expectBuildFailed (BuildFailure _ (BuildFailed _)) = return ()+expectBuildFailed (BuildFailure _ reason) =+    assertFailure $ "expected BuildFailed, got " ++ show reason++---------------------------------------+-- Other utils+--++-- | Allow altering a file during a test, but then restore it afterwards+--+withFileFinallyRestore :: FilePath -> IO a -> IO a+withFileFinallyRestore file action = do+    copyFile file backup+    action `finally` renameFile backup file+  where+    backup = file <.> "backup"
+ cabal/cabal-install/tests/IntegrationTests2/build/keep-going/cabal.project view
@@ -0,0 +1,1 @@+packages: p q
+ cabal/cabal-install/tests/IntegrationTests2/build/keep-going/p/P.hs view
@@ -0,0 +1,4 @@+module P where++p :: Int+p = this_is_not_expected_to_compile
+ cabal/cabal-install/tests/IntegrationTests2/build/keep-going/p/p.cabal view
@@ -0,0 +1,8 @@+name: p+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: P+  build-depends: base
+ cabal/cabal-install/tests/IntegrationTests2/build/keep-going/q/Q.hs view
@@ -0,0 +1,4 @@+module Q where++q :: Int+q = 42
+ cabal/cabal-install/tests/IntegrationTests2/build/keep-going/q/q.cabal view
@@ -0,0 +1,9 @@+name: q+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: Q+  build-depends: base+
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-custom1/A.hs view
@@ -0,0 +1,4 @@+module A where++a :: Int+a = 42
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain >> writeFile "marker" "ok"
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-custom1/a.cabal view
@@ -0,0 +1,13 @@+name: a+version: 0.1+build-type: Custom+cabal-version: >= 1.10++-- explicit setup deps:+custom-setup+  setup-depends: base, Cabal >= 1.18++library+  exposed-modules: A+  build-depends: base+  default-language: Haskell2010
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-custom2/A.hs view
@@ -0,0 +1,4 @@+module A where++a :: Int+a = 42
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain >> writeFile "marker" "ok"
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-custom2/a.cabal view
@@ -0,0 +1,11 @@+name: a+version: 0.1+build-type: Custom+cabal-version: >= 1.10++-- no explicit setup deps++library+  exposed-modules: A+  build-depends: base+  default-language: Haskell2010
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-simple/A.hs view
@@ -0,0 +1,4 @@+module A where++a :: Int+a = 42
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests2/build/setup-simple/a.cabal view
@@ -0,0 +1,9 @@+name: a+version: 0.1+build-type: Simple+cabal-version: >= 1.10++library+  exposed-modules: A+  build-depends: base+  default-language: Haskell2010
+ cabal/cabal-install/tests/IntegrationTests2/exception/bad-config/cabal.project view
@@ -0,0 +1,4 @@+packages:++package foo+  ghc-location: bar
+ cabal/cabal-install/tests/IntegrationTests2/exception/build/Main.hs view
@@ -0,0 +1,1 @@+main = thisNameDoesNotExist
+ cabal/cabal-install/tests/IntegrationTests2/exception/build/a.cabal view
@@ -0,0 +1,8 @@+name: a+version: 1+build-type: Simple+cabal-version: >= 1.2++executable a+  main-is: Main.hs+  build-depends: base
+ cabal/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal view
@@ -0,0 +1,9 @@+name: a+version: 1+build-type: Simple+-- This used to be a blank package with no components,+-- but I refactored new-build so that if a package has+-- no buildable components, we skip configuring it.+-- So put in a (failing) component so that we try to+-- configure.+executable a
+ cabal/cabal-install/tests/IntegrationTests2/exception/no-pkg/empty.in view
@@ -0,0 +1,1 @@+this is just here to ensure the source control creates the dir
+ cabal/cabal-install/tests/IntegrationTests2/exception/no-pkg2/cabal.project view
@@ -0,0 +1,1 @@+packages: ./
+ cabal/cabal-install/tests/IntegrationTests2/regression/3324/cabal.project view
@@ -0,0 +1,1 @@+packages: p q
+ cabal/cabal-install/tests/IntegrationTests2/regression/3324/p/P.hs view
@@ -0,0 +1,4 @@+module P where++p :: Int+p = 42
+ cabal/cabal-install/tests/IntegrationTests2/regression/3324/p/p.cabal view
@@ -0,0 +1,8 @@+name: p+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: P+  build-depends: base
+ cabal/cabal-install/tests/IntegrationTests2/regression/3324/q/Q.hs view
@@ -0,0 +1,6 @@+module Q where++import P++q :: Int+q = p
+ cabal/cabal-install/tests/IntegrationTests2/regression/3324/q/q.cabal view
@@ -0,0 +1,9 @@+name: q+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: Q+  build-depends: base+  -- missing a dep on p here, so expect failure initially
cabal/cabal-install/tests/SolverQuickCheck.hs view
@@ -2,14 +2,14 @@  import Test.Tasty -import qualified UnitTests.Distribution.Client.Dependency.Modular.QuickCheck+import qualified UnitTests.Distribution.Solver.Modular.QuickCheck   tests :: TestTree tests =   testGroup "Solver QuickCheck"-  [ testGroup "UnitTests.Distribution.Client.Dependency.Modular.QuickCheck"-        UnitTests.Distribution.Client.Dependency.Modular.QuickCheck.tests+  [ testGroup "UnitTests.Distribution.Solver.Modular.QuickCheck"+        UnitTests.Distribution.Solver.Modular.QuickCheck.tests   ]  main :: IO ()
cabal/cabal-install/tests/UnitTests.hs view
@@ -5,18 +5,15 @@  import Test.Tasty -import Control.Monad-import Data.Time.Clock-import System.FilePath- import Distribution.Simple.Utils import Distribution.Verbosity -import Distribution.Client.Compat.Time+import Distribution.Compat.Time -import qualified UnitTests.Distribution.Client.Compat.Time-import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ-import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver+import qualified UnitTests.Distribution.Solver.Modular.PSQ+import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ+import qualified UnitTests.Distribution.Solver.Modular.Solver+import qualified UnitTests.Distribution.Solver.Modular.RetryLog import qualified UnitTests.Distribution.Client.FileMonitor import qualified UnitTests.Distribution.Client.Glob import qualified UnitTests.Distribution.Client.GZipUtils@@ -26,6 +23,9 @@ import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.UserConfig import qualified UnitTests.Distribution.Client.ProjectConfig+import qualified UnitTests.Distribution.Client.JobControl+import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp+import qualified UnitTests.Distribution.Client.InstallPlan  import UnitTests.Options @@ -38,12 +38,14 @@                     else mtimeChangeCalibrated   in   testGroup "Unit Tests"-  [ testGroup "UnitTests.Distribution.Client.Compat.Time" $-        UnitTests.Distribution.Client.Compat.Time.tests mtimeChange-  , testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"-        UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests-  , testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"-        UnitTests.Distribution.Client.Dependency.Modular.Solver.tests+  [ testGroup "UnitTests.Distribution.Solver.Modular.PSQ"+        UnitTests.Distribution.Solver.Modular.PSQ.tests+  , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ"+        UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests+  , testGroup "UnitTests.Distribution.Solver.Modular.Solver"+        UnitTests.Distribution.Solver.Modular.Solver.tests+  , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog"+        UnitTests.Distribution.Solver.Modular.RetryLog.tests   , testGroup "UnitTests.Distribution.Client.FileMonitor" $         UnitTests.Distribution.Client.FileMonitor.tests mtimeChange   , testGroup "UnitTests.Distribution.Client.Glob"@@ -62,45 +64,25 @@        UnitTests.Distribution.Client.UserConfig.tests   , testGroup "UnitTests.Distribution.Client.ProjectConfig"        UnitTests.Distribution.Client.ProjectConfig.tests+  , testGroup "UnitTests.Distribution.Client.JobControl"+       UnitTests.Distribution.Client.JobControl.tests+  , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp"+       UnitTests.Distribution.Client.IndexUtils.Timestamp.tests+  , testGroup "UnitTests.Distribution.Client.InstallPlan"+       UnitTests.Distribution.Client.InstallPlan.tests   ]  main :: IO () main = do-  mtimeChangeDelay <- calibrateMtimeChangeDelay+  (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay+  let toMillis :: Int -> Double+      toMillis x = fromIntegral x / 1000.0+  notice normal $ "File modification time resolution calibration completed, "+    ++ "maximum delay observed: "+    ++ (show . toMillis $ mtimeChange ) ++ " ms. "+    ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')+    ++ " for test runs."   defaultMainWithIngredients          (includingOptions extraOptions : defaultIngredients)-         (tests mtimeChangeDelay)---- Based on code written by Neill Mitchell for Shake. See--- 'sleepFileTimeCalibrate' in 'Test.Type'. The returned delay is never smaller--- than 10 ms, but never larger than 1 second.-calibrateMtimeChangeDelay :: IO Int-calibrateMtimeChangeDelay = do-  withTempDirectory silent "." "calibration-" $ \dir -> do-    let fileName = dir </> "probe"-    mtimes <- forM [1..25] $ \(i::Int) -> time $ do-      writeFile fileName $ show i-      t0 <- getModTime fileName-      let spin j = do-            writeFile fileName $ show (i,j)-            t1 <- getModTime fileName-            unless (t0 < t1) (spin $ j + 1)-      spin (0::Int)-    let mtimeChange  = maximum mtimes-        mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2-    notice normal $ "File modification time resolution calibration completed, "-      ++ "maximum delay observed: "-      ++ (show . toMillis $ mtimeChange ) ++ " ms. "-      ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')-      ++ " for test runs."-    return mtimeChange'-  where-    toMillis :: Int -> Double-    toMillis x = fromIntegral x / 1000.0+         (tests mtimeChange') -    time :: IO () -> IO Int-    time act = do-      t0 <- getCurrentTime-      act-      t1 <- getCurrentTime-      return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs view
@@ -30,6 +30,8 @@  import Distribution.Utils.NubList +import Distribution.Client.IndexUtils.Timestamp+ import Test.QuickCheck  @@ -74,13 +76,11 @@                           ,(3, return 1)                           ,(2, return 2)                           ,(1, return 3)]-    return (Version branch []) -- deliberate []+    return (mkVersion branch)     where -  shrink (Version branch []) =-    [ Version branch' [] | branch' <- shrink branch, not (null branch') ]-  shrink (Version branch _tags) =-    [ Version branch [] ]+  shrink ver = [ mkVersion branch' | branch' <- shrink (versionNumbers ver)+                                   , not (null branch') ]  instance Arbitrary VersionRange where   arbitrary = canonicaliseVersionRange <$> sized verRangeExp@@ -111,7 +111,7 @@       canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals  instance Arbitrary PackageName where-    arbitrary = PackageName . intercalate "-" <$> shortListOf1 2 nameComponent+    arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent       where         nameComponent = shortListOf1 5 (elements packageChars)                         `suchThat` (not . all isDigit)@@ -170,3 +170,10 @@     arbitrary = NoShrink <$> arbitrary     shrink _  = [] +instance Arbitrary Timestamp where+    arbitrary = (maybe (toEnum 0) id . epochTimeToTimestamp) <$> arbitrary++instance Arbitrary IndexState where+    arbitrary = frequency [ (1, pure IndexStateHead)+                          , (50, IndexStateTime <$> arbitrary)+                          ]
− cabal/cabal-install/tests/UnitTests/Distribution/Client/Compat/Time.hs 
@@ -1,49 +0,0 @@-module UnitTests.Distribution.Client.Compat.Time (tests) where--import Control.Concurrent (threadDelay)-import System.FilePath--import Distribution.Simple.Utils (withTempDirectory)-import Distribution.Verbosity--import Distribution.Client.Compat.Time--import Test.Tasty-import Test.Tasty.HUnit--tests :: Int -> [TestTree]-tests mtimeChange =-  [ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange-  , testCase "getCurTime works as expected"         $ getCurTimeTest mtimeChange-  ]--getModTimeTest :: Int -> Assertion-getModTimeTest mtimeChange =-  withTempDirectory silent "." "getmodtime-" $ \dir -> do-    let fileName = dir </> "foo"-    writeFile fileName "bar"-    t0 <- getModTime fileName-    threadDelay mtimeChange-    writeFile fileName "baz"-    t1 <- getModTime fileName-    assertBool "expected different file mtimes" (t1 > t0)---getCurTimeTest :: Int -> Assertion-getCurTimeTest mtimeChange =-  withTempDirectory silent "." "getmodtime-" $ \dir -> do-    let fileName = dir </> "foo"-    writeFile fileName "bar"-    t0 <- getModTime fileName-    threadDelay mtimeChange-    t1 <- getCurTime-    assertBool("expected file mtime (" ++ show t0-               ++ ") to be earlier than current time (" ++ show t1 ++ ")")-      (t0 < t1)--    threadDelay mtimeChange-    writeFile fileName "baz"-    t2 <- getModTime fileName-    assertBool ("expected current time (" ++ show t1-                ++ ") to be earlier than file mtime (" ++ show t2 ++ ")")-      (t1 < t2)
− cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs 
@@ -1,455 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--- | DSL for testing the modular solver-module UnitTests.Distribution.Client.Dependency.Modular.DSL (-    ExampleDependency(..)-  , Dependencies(..)-  , ExTest(..)-  , ExPreference(..)-  , ExampleDb-  , ExampleVersionRange-  , ExamplePkgVersion-  , ExamplePkgName-  , ExampleAvailable(..)-  , ExampleInstalled(..)-  , IndepGoals(..)-  , ReorderGoals(..)-  , exAv-  , exInst-  , exFlag-  , exResolve-  , extractInstallPlan-  , withSetupDeps-  , withTest-  , withTests-  ) where---- base-import Data.Either (partitionEithers)-import Data.Maybe (catMaybes)-import Data.List (nub)-import Data.Monoid-import Data.Version-import qualified Data.Map as Map---- Cabal-import qualified Distribution.Compiler             as C-import qualified Distribution.InstalledPackageInfo as C-import qualified Distribution.Package              as C-  hiding (HasUnitId(..))-import qualified Distribution.PackageDescription   as C-import qualified Distribution.Simple.PackageIndex  as C.PackageIndex-import qualified Distribution.System               as C-import qualified Distribution.Version              as C-import Language.Haskell.Extension (Extension(..), Language)---- cabal-install-import Distribution.Client.ComponentDeps (ComponentDeps)-import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types-import Distribution.Client.Types-import qualified Distribution.Client.InstallPlan   as CI.InstallPlan-import qualified Distribution.Client.PackageIndex  as CI.PackageIndex-import qualified Distribution.Client.PkgConfigDb   as PC-import qualified Distribution.Client.ComponentDeps as CD--{--------------------------------------------------------------------------------  Example package database DSL--  In order to be able to set simple examples up quickly, we define a very-  simple version of the package database here explicitly designed for use in-  tests.--  The design of `ExampleDb` takes the perspective of the solver, not the-  perspective of the package DB. This makes it easier to set up tests for-  various parts of the solver, but makes the mapping somewhat awkward,  because-  it means we first map from "solver perspective" `ExampleDb` to the package-  database format, and then the modular solver internally in `IndexConversion`-  maps this back to the solver specific data structures.--  IMPLEMENTATION NOTES-  ----------------------  TODO: Perhaps these should be made comments of the corresponding data type-  definitions. For now these are just my own conclusions and may be wrong.--  * The difference between `GenericPackageDescription` and `PackageDescription`-    is that `PackageDescription` describes a particular _configuration_ of a-    package (for instance, see documentation for `checkPackage`). A-    `GenericPackageDescription` can be turned into a `PackageDescription` in-    two ways:--      a. `finalizePackageDescription` does the proper translation, by taking-         into account the platform, available dependencies, etc. and picks a-         flag assignment (or gives an error if no flag assignment can be found)-      b. `flattenPackageDescription` ignores flag assignment and just joins all-         components together.--    The slightly odd thing is that a `GenericPackageDescription` contains a-    `PackageDescription` as a field; both of the above functions do the same-    thing: they take the embedded `PackageDescription` as a basis for the result-    value, but override `library`, `executables`, `testSuites`, `benchmarks`-    and `buildDepends`.-  * The `condTreeComponents` fields of a `CondTree` is a list of triples-    `(condition, then-branch, else-branch)`, where the `else-branch` is-    optional.--------------------------------------------------------------------------------}--type ExamplePkgName    = String-type ExamplePkgVersion = Int-type ExamplePkgHash    = String  -- for example "installed" packages-type ExampleFlagName   = String-type ExampleTestName   = String-type ExampleVersionRange = C.VersionRange--data Dependencies = NotBuildable | Buildable [ExampleDependency]-  deriving Show--data ExampleDependency =-    -- | Simple dependency on any version-    ExAny ExamplePkgName--    -- | Simple dependency on a fixed version-  | ExFix ExamplePkgName ExamplePkgVersion--    -- | Dependencies indexed by a flag-  | ExFlag ExampleFlagName Dependencies Dependencies--    -- | Dependency on a language extension-  | ExExt Extension--    -- | Dependency on a language version-  | ExLang Language--    -- | Dependency on a pkg-config package-  | ExPkg (ExamplePkgName, ExamplePkgVersion)-  deriving Show--data ExTest = ExTest ExampleTestName [ExampleDependency]--exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]-       -> ExampleDependency-exFlag n t e = ExFlag n (Buildable t) (Buildable e)--data ExPreference = ExPref String ExampleVersionRange--data ExampleAvailable = ExAv {-    exAvName    :: ExamplePkgName-  , exAvVersion :: ExamplePkgVersion-  , exAvDeps    :: ComponentDeps [ExampleDependency]-  } deriving Show---- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',--- given:------      1. The name 'ExamplePkgName' of the available package,---      2. The version 'ExamplePkgVersion' available---      3. The list of dependency constraints 'ExampleDependency'---         that this package has.  'ExampleDependency' provides---         a number of pre-canned dependency types to look at.----exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]-     -> ExampleAvailable-exAv n v ds = ExAv { exAvName = n, exAvVersion = v-                   , exAvDeps = CD.fromLibraryDeps n ds }--withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable-withSetupDeps ex setupDeps = ex {-      exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps-    }--withTest :: ExampleAvailable -> ExTest -> ExampleAvailable-withTest ex test = withTests ex [test]--withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable-withTests ex tests =-  let testCDs = CD.fromList [(CD.ComponentTest name, deps)-                            | ExTest name deps <- tests]-  in ex { exAvDeps = exAvDeps ex <> testCDs }---- | An installed package in 'ExampleDb'; construct me with 'exInst'.-data ExampleInstalled = ExInst {-    exInstName         :: ExamplePkgName-  , exInstVersion      :: ExamplePkgVersion-  , exInstHash         :: ExamplePkgHash-  , exInstBuildAgainst :: [ExamplePkgHash]-  } deriving Show---- | Constructs an example installed package given:------      1. The name of the package 'ExamplePkgName', i.e., 'String'---      2. The version of the package 'ExamplePkgVersion', i.e., 'Int'---      3. The IPID for the package 'ExamplePkgHash', i.e., 'String'---         (just some unique identifier for the package.)---      4. The 'ExampleInstalled' packages which this package was---         compiled against.)----exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash-       -> [ExampleInstalled] -> ExampleInstalled-exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)---- | An example package database is a list of installed packages--- 'ExampleInstalled' and available packages 'ExampleAvailable'.--- Generally, you want to use 'exInst' and 'exAv' to construct--- these packages.-type ExampleDb = [Either ExampleInstalled ExampleAvailable]--type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a--newtype IndepGoals = IndepGoals Bool-  deriving Show--newtype ReorderGoals = ReorderGoals Bool-  deriving Show--exDbPkgs :: ExampleDb -> [ExamplePkgName]-exDbPkgs = map (either exInstName exAvName)--exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage-exAvSrcPkg ex =-    let (libraryDeps, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex))-        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]-    in SourcePackage {-           packageInfoId        = exAvPkgId ex-         , packageSource        = LocalTarballPackage "<<path>>"-         , packageDescrOverride = Nothing-         , packageDescription   = C.GenericPackageDescription {-               C.packageDescription = C.emptyPackageDescription {-                   C.package        = exAvPkgId ex-                 , C.libraries      = error "not yet configured: library"-                 , C.executables    = error "not yet configured: executables"-                 , C.testSuites     = error "not yet configured: testSuites"-                 , C.benchmarks     = error "not yet configured: benchmarks"-                 , C.buildDepends   = error "not yet configured: buildDepends"-                 , C.setupBuildInfo = Just C.SetupBuildInfo {-                       C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex))-                     }-                 }-             , C.genPackageFlags = nub $ concatMap extractFlags $-                                   CD.libraryDeps (exAvDeps ex) ++ concatMap snd testSuites-             , C.condLibraries   = [(exAvName ex, mkCondTree (extsLib exts <> langLib mlang <> pcpkgLib pcpkgs)-                                                     disableLib-                                                     (Buildable libraryDeps))]-             , C.condExecutables = []-             , C.condTestSuites  =-                 let mkTree = mkCondTree mempty disableTest . Buildable-                 in map (\(t, deps) -> (t, mkTree deps)) testSuites-             , C.condBenchmarks  = []-             }-         }-  where-    -- Split the set of dependencies into the set of dependencies of the library,-    -- the dependencies of the test suites and extensions.-    splitTopLevel :: [ExampleDependency]-                  -> ( [ExampleDependency]-                     , [Extension]-                     , Maybe Language-                     , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config-                     )-    splitTopLevel [] =-        ([], [], Nothing, [])-    splitTopLevel (ExExt ext:deps) =-      let (other, exts, lang, pcpkgs) = splitTopLevel deps-      in (other, ext:exts, lang, pcpkgs)-    splitTopLevel (ExLang lang:deps) =-        case splitTopLevel deps of-            (other, exts, Nothing, pcpkgs) -> (other, exts, Just lang, pcpkgs)-            _ -> error "Only 1 Language dependency is supported"-    splitTopLevel (ExPkg pkg:deps) =-      let (other, exts, lang, pcpkgs) = splitTopLevel deps-      in (other, exts, lang, pkg:pcpkgs)-    splitTopLevel (dep:deps) =-      let (other, exts, lang, pcpkgs) = splitTopLevel deps-      in (dep:other, exts, lang, pcpkgs)--    -- Extract the total set of flags used-    extractFlags :: ExampleDependency -> [C.Flag]-    extractFlags (ExAny _)      = []-    extractFlags (ExFix _ _)    = []-    extractFlags (ExFlag f a b) = C.MkFlag {-                                      C.flagName        = C.FlagName f-                                    , C.flagDescription = ""-                                    , C.flagDefault     = True-                                    , C.flagManual      = False-                                    }-                                : concatMap extractFlags (deps a ++ deps b)-      where-        deps :: Dependencies -> [ExampleDependency]-        deps NotBuildable = []-        deps (Buildable ds) = ds-    extractFlags (ExExt _)      = []-    extractFlags (ExLang _)     = []-    extractFlags (ExPkg _)      = []--    mkCondTree :: Monoid a => a -> (a -> a) -> Dependencies -> DependencyTree a-    mkCondTree x dontBuild NotBuildable =-      C.CondNode {-             C.condTreeData        = dontBuild x-           , C.condTreeConstraints = []-           , C.condTreeComponents  = []-           }-    mkCondTree x dontBuild (Buildable deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in C.CondNode {-             C.condTreeData        = x -- Necessary for language extensions-           , C.condTreeConstraints = map mkDirect directDeps-           , C.condTreeComponents  = map (mkFlagged dontBuild) flaggedDeps-           }--    mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency-    mkDirect (dep, Nothing) = C.Dependency (C.PackageName dep) C.anyVersion-    mkDirect (dep, Just n)  = C.Dependency (C.PackageName dep) (C.thisVersion v)-      where-        v = Version [n, 0, 0] []--    mkFlagged :: Monoid a-              => (a -> a)-              -> (ExampleFlagName, Dependencies, Dependencies)-              -> (C.Condition C.ConfVar-                 , DependencyTree a, Maybe (DependencyTree a))-    mkFlagged dontBuild (f, a, b) = ( C.Var (C.Flag (C.FlagName f))-                                    , mkCondTree mempty dontBuild a-                                    , Just (mkCondTree mempty dontBuild b)-                                    )--    -- Split a set of dependencies into direct dependencies and flagged-    -- dependencies. A direct dependency is a tuple of the name of package and-    -- maybe its version (no version means any version) meant to be converted-    -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is-    -- the set of dependencies guarded by a flag.-    ---    -- TODO: Take care of flagged language extensions and language flavours.-    splitDeps :: [ExampleDependency]-              -> ( [(ExamplePkgName, Maybe Int)]-                 , [(ExampleFlagName, Dependencies, Dependencies)]-                 )-    splitDeps [] =-      ([], [])-    splitDeps (ExAny p:deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in ((p, Nothing):directDeps, flaggedDeps)-    splitDeps (ExFix p v:deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in ((p, Just v):directDeps, flaggedDeps)-    splitDeps (ExFlag f a b:deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in (directDeps, (f, a, b):flaggedDeps)-    splitDeps (_:deps) = splitDeps deps--    -- Currently we only support simple setup dependencies-    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]-    mkSetupDeps deps =-      let (directDeps, []) = splitDeps deps in map mkDirect directDeps--    -- A 'C.Library' with just the given extensions in its 'BuildInfo'-    extsLib :: [Extension] -> C.Library-    extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }--    -- A 'C.Library' with just the given extensions in its 'BuildInfo'-    langLib :: Maybe Language -> C.Library-    langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }-    langLib _ = mempty--    disableLib :: C.Library -> C.Library-    disableLib lib =-        lib { C.libBuildInfo = (C.libBuildInfo lib) { C.buildable = False }}--    disableTest :: C.TestSuite -> C.TestSuite-    disableTest test =-        test { C.testBuildInfo = (C.testBuildInfo test) { C.buildable = False }}--    -- A 'C.Library' with just the given pkgconfig-depends in its 'BuildInfo'-    pcpkgLib :: [(ExamplePkgName, ExamplePkgVersion)] -> C.Library-    pcpkgLib ds = mempty { C.libBuildInfo = mempty { C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- ds] } }--exAvPkgId :: ExampleAvailable -> C.PackageIdentifier-exAvPkgId ex = C.PackageIdentifier {-      pkgName    = C.PackageName (exAvName ex)-    , pkgVersion = Version [exAvVersion ex, 0, 0] []-    }--exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo-exInstInfo ex = C.emptyInstalledPackageInfo {-      C.installedUnitId    = C.mkUnitId (exInstHash ex)-    , C.sourcePackageId    = exInstPkgId ex-    , C.depends            = map C.mkUnitId (exInstBuildAgainst ex)-    }--exInstPkgId :: ExampleInstalled -> C.PackageIdentifier-exInstPkgId ex = C.PackageIdentifier {-      pkgName    = C.PackageName (exInstName ex)-    , pkgVersion = Version [exInstVersion ex, 0, 0] []-    }--exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage-exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg--exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex-exInstIdx = C.PackageIndex.fromList . map exInstInfo--exResolve :: ExampleDb-          -- List of extensions supported by the compiler, or Nothing if unknown.-          -> Maybe [Extension]-          -- List of languages supported by the compiler, or Nothing if unknown.-          -> Maybe [Language]-          -> PC.PkgConfigDb-          -> [ExamplePkgName]-          -> Solver-          -> IndepGoals-          -> ReorderGoals-          -> [ExPreference]-          -> ([String], Either String CI.InstallPlan.InstallPlan)-exResolve db exts langs pkgConfigDb targets solver (IndepGoals indepGoals) (ReorderGoals reorder) prefs = runProgress $-    resolveDependencies C.buildPlatform-                        compiler pkgConfigDb-                        solver-                        params-  where-    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag-    compiler = defaultCompiler { C.compilerInfoExtensions = exts-                               , C.compilerInfoLanguages  = langs-                               }-    (inst, avai) = partitionEithers db-    instIdx      = exInstIdx inst-    avaiIdx      = SourcePackageDb {-                       packageIndex       = exAvIdx avai-                     , packagePreferences = Map.empty-                     }-    enableTests  = fmap (\p -> PackageConstraintStanzas-                              (C.PackageName p) [TestStanzas])-                       (exDbPkgs db)-    targets'     = fmap (\p -> NamedPackage (C.PackageName p) []) targets-    params       =   addPreferences (fmap toPref prefs)-                   $ addConstraints (fmap toLpc enableTests)-                   $ setIndependentGoals indepGoals-                   $ setReorderGoals reorder-                   $ standardInstallPolicy instIdx avaiIdx targets'-    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown-    toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v--extractInstallPlan :: CI.InstallPlan.InstallPlan-                   -> [(ExamplePkgName, ExamplePkgVersion)]-extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList-  where-    confPkg :: CI.InstallPlan.PlanPackage -> Maybe (String, Int)-    confPkg (CI.InstallPlan.Configured pkg) = Just $ srcPkg pkg-    confPkg _                               = Nothing--    srcPkg :: ConfiguredPackage UnresolvedPkgLoc -> (String, Int)-    srcPkg cpkg =-      let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) =-            packageInfoId (confPkgSource cpkg)-      in (p, n)--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}---- | Run Progress computation------ Like `runLog`, but for the more general `Progress` type.-runProgress :: Progress step e a -> ([step], Either e a)-runProgress = go-  where-    go (Step s p) = let (ss, result) = go p in (s:ss, result)-    go (Fail e)   = ([], Left e)-    go (Done a)   = ([], Right a)
− cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs 
@@ -1,22 +0,0 @@-module UnitTests.Distribution.Client.Dependency.Modular.PSQ (-  tests-  ) where--import Distribution.Client.Dependency.Modular.PSQ--import Test.Tasty-import Test.Tasty.QuickCheck--tests :: [TestTree]-tests = [ testProperty "splitsAltImplementation" splitsTest-        ]---- | Original splits implementation-splits' :: PSQ k a -> PSQ k (a, PSQ k a)-splits' xs =-  casePSQ xs-    (PSQ [])-    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys)))--splitsTest :: [(Int, Int)] -> Bool-splitsTest psq = splits' (PSQ psq) == splits (PSQ psq)
− cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/QuickCheck.hs 
@@ -1,291 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module UnitTests.Distribution.Client.Dependency.Modular.QuickCheck (tests) where--import Control.Monad (foldM)-import Data.Either (lefts)-import Data.Function (on)-import Data.List (groupBy, nub, sort)-import Data.Maybe (isJust)--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-import Data.Monoid (Monoid)-#endif--import Text.Show.Pretty (parseValue, valToStr)--import Test.Tasty (TestTree)-import Test.Tasty.QuickCheck--import qualified Distribution.Client.ComponentDeps as CD-import Distribution.Client.ComponentDeps ( Component(..)-                                         , ComponentDep, ComponentDeps)-import Distribution.Client.Dependency.Types (Solver(..))-import Distribution.Client.PkgConfigDb (pkgConfigDbFromList)--import UnitTests.Distribution.Client.Dependency.Modular.DSL--tests :: [TestTree]-tests = [-      -- This test checks that certain solver parameters do not affect the-      -- existence of a solution. It runs the solver twice, and only sets those-      -- parameters on the second run. The test also applies parameters that-      -- can affect the existence of a solution to both runs.-      testProperty "target order and --reorder-goals do not affect solvability" $-          \(SolverTest db targets) targetOrder reorderGoals indepGoals solver ->-            let r1 = solve (ReorderGoals False) indepGoals solver targets  db-                r2 = solve reorderGoals         indepGoals solver targets2 db-                targets2 = case targetOrder of-                             SameOrder -> targets-                             ReverseOrder -> reverse targets-            in counterexample (showResults r1 r2) $-               isJust (resultPlan r1) === isJust (resultPlan r2)-    ]-  where-    showResults :: Result -> Result -> String-    showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2--    showResult :: Int -> Result -> String-    showResult n result =-        unlines $ ["", "Run " ++ show n ++ ":"]-               ++ resultLog result-               ++ ["result: " ++ show (resultPlan result)]--solve :: ReorderGoals -> IndepGoals -> Solver -> [PN] -> TestDb -> Result-solve reorder indep solver targets (TestDb db) =-  let (lg, result) =-        exResolve db Nothing Nothing-                  (pkgConfigDbFromList [])-                  (map unPN targets)-                  solver indep reorder []-  in Result {-       resultLog = lg-     , resultPlan =-          case result of-            Left _ -> Nothing-            Right plan -> Just (extractInstallPlan plan)-     }---- | How to modify the order of the input targets.-data TargetOrder = SameOrder | ReverseOrder-  deriving Show--instance Arbitrary TargetOrder where-  arbitrary = elements [SameOrder, ReverseOrder]--  shrink SameOrder = []-  shrink ReverseOrder = [SameOrder]--data Result = Result {-    resultLog :: [String]-  , resultPlan :: Maybe [(ExamplePkgName, ExamplePkgVersion)]-  }---- | Package name.-newtype PN = PN { unPN :: String }-  deriving (Eq, Ord, Show)--instance Arbitrary PN where-  arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']])---- | Package version.-newtype PV = PV { unPV :: Int }-  deriving (Eq, Ord, Show)--instance Arbitrary PV where-  arbitrary = PV <$> elements [1..10]--type TestPackage = Either ExampleInstalled ExampleAvailable--getName :: TestPackage -> PN-getName = PN . either exInstName exAvName--getVersion :: TestPackage -> PV-getVersion = PV . either exInstVersion exAvVersion--data SolverTest = SolverTest {-    testDb :: TestDb-  , testTargets :: [PN]-  }---- | Pretty-print the test when quickcheck calls 'show'.-instance Show SolverTest where-  show test =-    let str = "SolverTest {testDb = " ++ show (testDb test)-                     ++ ", testTargets = " ++ show (testTargets test) ++ "}"-    in maybe str valToStr $ parseValue str--instance Arbitrary SolverTest where-  arbitrary = do-    db <- arbitrary-    let pkgs = nub $ map getName (unTestDb db)-    Positive n <- arbitrary-    targets <- randomSubset n pkgs-    return (SolverTest db targets)--  shrink test =-         [test { testDb = db } | db <- shrink (testDb test)]-      ++ [test { testTargets = targets } | targets <- shrink (testTargets test)]---- | Collection of source and installed packages.-newtype TestDb = TestDb { unTestDb :: ExampleDb }-  deriving Show--instance Arbitrary TestDb where-  arbitrary = do-      -- Avoid cyclic dependencies by grouping packages by name and only-      -- allowing each package to depend on packages in the groups before it.-      groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<<-                     boundedListOf 10 arbitrary-      db <- foldM nextPkgs (TestDb []) groupedPkgs-      TestDb <$> shuffle (unTestDb db)-    where-      nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb-      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs--      nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage-      nextPkg db (pn, v) = do-        installed <- arbitrary-        if installed-        then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)-        else Right <$> arbitraryExAv pn v db--  shrink (TestDb pkgs) = map TestDb $ shrink pkgs--arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable-arbitraryExAv pn v db =-    ExAv (unPN pn) (unPV v) <$> arbitraryComponentDeps db--arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled-arbitraryExInst pn v pkgs = do-  hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']-  numDeps <- min 3 <$> arbitrary-  deps <- randomSubset numDeps pkgs-  return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps)--arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency])-arbitraryComponentDeps (TestDb []) = return $ CD.fromList []-arbitraryComponentDeps db =-    -- CD.fromList combines duplicate components.-    CD.fromList <$> boundedListOf 3 (arbitraryComponentDep db)--arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])-arbitraryComponentDep db = do-  comp <- arbitrary-  deps <- case comp of-            ComponentSetup -> smallListOf (arbitraryExDep db Setup)-            _              -> boundedListOf 5 (arbitraryExDep db NonSetup)-  return (comp, deps)---- | Location of an 'ExampleDependency'. It determines which values are valid.-data ExDepLocation = Setup | NonSetup--arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency-arbitraryExDep db@(TestDb pkgs) level =-  let flag = ExFlag <$> arbitraryFlagName-                    <*> arbitraryDeps db-                    <*> arbitraryDeps db-      other = [-            ExAny . unPN <$> elements (map getName pkgs)--          -- existing version-          , let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)-            in fixed <$> elements pkgs--          -- random version of an existing package-          , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)-          ]-  in oneof $-      case level of-        NonSetup -> flag : other-        Setup -> other--arbitraryDeps :: TestDb -> Gen Dependencies-arbitraryDeps db = frequency-    [ (1, return NotBuildable)-    , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetup))-    ]--arbitraryFlagName :: Gen String-arbitraryFlagName = (:[]) <$> elements ['A'..'E']--arbitraryComponentName :: Gen String-arbitraryComponentName = (:[]) <$> elements "ABC"--instance Arbitrary ReorderGoals where-  arbitrary = ReorderGoals <$> arbitrary--  shrink (ReorderGoals reorder) = [ReorderGoals False | reorder]--instance Arbitrary IndepGoals where-  arbitrary = IndepGoals <$> arbitrary--  shrink (IndepGoals indep) = [IndepGoals False | indep]--instance Arbitrary Solver where-  arbitrary = frequency [ (1, return TopDown)-                        , (5, return Modular) ]--  shrink Modular = []-  shrink TopDown = [Modular]--instance Arbitrary Component where-  arbitrary = oneof [ ComponentLib <$> arbitraryComponentName-                    , ComponentExe <$> arbitraryComponentName-                    , ComponentTest <$> arbitraryComponentName-                    , ComponentBench <$> arbitraryComponentName-                    , return ComponentSetup-                    ]--  shrink (ComponentLib "") = []-  shrink _ = [ComponentLib ""]--instance Arbitrary ExampleInstalled where-  arbitrary = error "arbitrary not implemented: ExampleInstalled"--  shrink ei = [ ei { exInstBuildAgainst = deps }-              | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)]--instance Arbitrary ExampleAvailable where-  arbitrary = error "arbitrary not implemented: ExampleAvailable"--  shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)]--instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where-  arbitrary = error "arbitrary not implemented: ComponentDeps"--  shrink = map CD.fromList . shrink . CD.toList--instance Arbitrary ExampleDependency where-  arbitrary = error "arbitrary not implemented: ExampleDependency"--  shrink (ExAny _) = []-  shrink (ExFix pn _) = [ExAny pn]-  shrink (ExFlag flag th el) =-         deps th ++ deps el-      ++ [ExFlag flag th' el | th' <- shrink th]-      ++ [ExFlag flag th el' | el' <- shrink el]-    where-      deps NotBuildable = []-      deps (Buildable ds) = ds-  shrink dep = error $ "Dependency not handled: " ++ show dep--instance Arbitrary Dependencies where-  arbitrary = error "arbitrary not implemented: Dependencies"--  shrink NotBuildable = [Buildable []]-  shrink (Buildable deps) = map Buildable (shrink deps)--randomSubset :: Int -> [a] -> Gen [a]-randomSubset n xs = take n <$> shuffle xs--boundedListOf :: Int -> Gen a -> Gen [a]-boundedListOf n gen = take n <$> listOf gen---- | Generates lists with average length less than 1.-smallListOf :: Gen a -> Gen [a]-smallListOf gen =-    frequency [ (fr, vectorOf n gen)-              | (fr, n) <- [(3, 0), (5, 1), (2, 2)]]
− cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs 
@@ -1,588 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests)-       where---- base-import Control.Monad-import Data.Maybe (isNothing)--import qualified Data.Version         as V-import qualified Distribution.Version as V---- test-framework-import Test.Tasty as TF-import Test.Tasty.HUnit (testCase, assertEqual, assertBool)---- Cabal-import Language.Haskell.Extension ( Extension(..)-                                  , KnownExtension(..), Language(..))---- cabal-install-import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)-import Distribution.Client.Dependency.Types (Solver(Modular))-import UnitTests.Distribution.Client.Dependency.Modular.DSL-import UnitTests.Options--tests :: [TF.TestTree]-tests = [-      testGroup "Simple dependencies" [-          runTest $         mkTest db1 "alreadyInstalled"   ["A"]      (Just [])-        , runTest $         mkTest db1 "installLatest"      ["B"]      (Just [("B", 2)])-        , runTest $         mkTest db1 "simpleDep1"         ["C"]      (Just [("B", 1), ("C", 1)])-        , runTest $         mkTest db1 "simpleDep2"         ["D"]      (Just [("B", 2), ("D", 1)])-        , runTest $         mkTest db1 "failTwoVersions"    ["C", "D"] Nothing-        , runTest $ indep $ mkTest db1 "indepTwoVersions"   ["C", "D"] (Just [("B", 1), ("B", 2), ("C", 1), ("D", 1)])-        , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (Just [("B", 1), ("C", 1), ("E", 1)])-        , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (Just [("B", 2), ("D", 1), ("E", 1)])-        , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (Just [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])-        , runTest $         mkTest db1 "buildDepAgainstOld" ["F"]      (Just [("B", 1), ("E", 1), ("F", 1)])-        , runTest $         mkTest db1 "buildDepAgainstNew" ["G"]      (Just [("B", 2), ("E", 1), ("G", 1)])-        , runTest $ indep $ mkTest db1 "multipleInstances"  ["F", "G"] Nothing-        ]-    , testGroup "Flagged dependencies" [-          runTest $         mkTest db3 "forceFlagOn"  ["C"]      (Just [("A", 1), ("B", 1), ("C", 1)])-        , runTest $         mkTest db3 "forceFlagOff" ["D"]      (Just [("A", 2), ("B", 1), ("D", 1)])-        , runTest $ indep $ mkTest db3 "linkFlags1"   ["C", "D"] Nothing-        , runTest $ indep $ mkTest db4 "linkFlags2"   ["C", "D"] Nothing-        ]-    , testGroup "Stanzas" [-          runTest $         mkTest db5 "simpleTest1" ["C"]      (Just [("A", 2), ("C", 1)])-        , runTest $         mkTest db5 "simpleTest2" ["D"]      Nothing-        , runTest $         mkTest db5 "simpleTest3" ["E"]      (Just [("A", 1), ("E", 1)])-        , runTest $         mkTest db5 "simpleTest4" ["F"]      Nothing -- TODO-        , runTest $         mkTest db5 "simpleTest5" ["G"]      (Just [("A", 2), ("G", 1)])-        , runTest $         mkTest db5 "simpleTest6" ["E", "G"] Nothing-        , runTest $ indep $ mkTest db5 "simpleTest7" ["E", "G"] (Just [("A", 1), ("A", 2), ("E", 1), ("G", 1)])-        , runTest $         mkTest db6 "depsWithTests1" ["C"]      (Just [("A", 1), ("B", 1), ("C", 1)])-        , runTest $ indep $ mkTest db6 "depsWithTests2" ["C", "D"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1)])-        ]-    , testGroup "Setup dependencies" [-          runTest $ mkTest db7  "setupDeps1" ["B"] (Just [("A", 2), ("B", 1)])-        , runTest $ mkTest db7  "setupDeps2" ["C"] (Just [("A", 2), ("C", 1)])-        , runTest $ mkTest db7  "setupDeps3" ["D"] (Just [("A", 1), ("D", 1)])-        , runTest $ mkTest db7  "setupDeps4" ["E"] (Just [("A", 1), ("A", 2), ("E", 1)])-        , runTest $ mkTest db7  "setupDeps5" ["F"] (Just [("A", 1), ("A", 2), ("F", 1)])-        , runTest $ mkTest db8  "setupDeps6" ["C", "D"] (Just [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])-        , runTest $ mkTest db9  "setupDeps7" ["F", "G"] (Just [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])-        , runTest $ mkTest db10 "setupDeps8" ["C"] (Just [("C", 1)])-        ]-    , testGroup "Base shim" [-          runTest $ mkTest db11 "baseShim1" ["A"] (Just [("A", 1)])-        , runTest $ mkTest db12 "baseShim2" ["A"] (Just [("A", 1)])-        , runTest $ mkTest db12 "baseShim3" ["B"] (Just [("B", 1)])-        , runTest $ mkTest db12 "baseShim4" ["C"] (Just [("A", 1), ("B", 1), ("C", 1)])-        , runTest $ mkTest db12 "baseShim5" ["D"] Nothing-        , runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])-        ]-    , testGroup "Cycles" [-          runTest $ mkTest db14 "simpleCycle1"          ["A"]      Nothing-        , runTest $ mkTest db14 "simpleCycle2"          ["A", "B"] Nothing-        , runTest $ mkTest db14 "cycleWithFlagChoice1"  ["C"]      (Just [("C", 1), ("E", 1)])-        , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"]      Nothing-        , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"]      Nothing-        , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (Just [("C", 2), ("D", 1)])-        , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (Just [("D", 1)])-        , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (Just [("C", 2), ("D", 1), ("E", 1)])-        ]-    , testGroup "Extensions" [-          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing-        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] Nothing-        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (Just [("A",1)])-        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (Just [("A",1),("B",1), ("C",1)])-        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] Nothing-        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] Nothing-        , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (Just [("A",1),("B",1),("C",1),("E",1)])-        ]-    , testGroup "Languages" [-          runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] Nothing-        , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (Just [("A",1)])-        , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] Nothing-        , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (Just [("A",1),("B",1),("C",1)])-        ]--     , testGroup "Soft Constraints" [-          runTest $ soft [ ExPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (Just [("A", 1)])-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (Just [("A", 2)])-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2-                         , ExPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (Just [("A", 1)])-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 1-                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (Just [("A", 1)])-        , runTest $ soft [ ExPref "A" $ mkvrThis 1-                         , ExPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (Just [("A", 2)])-        , runTest $ soft [ ExPref "A" $ mkvrThis 1-                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (Just [("A", 1)])-        ]-     , testGroup "Buildable Field" [-          testBuildable "avoid building component with unknown dependency" (ExAny "unknown")-        , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))-        , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))-        , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (Just [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])-        , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (Just [("A", 1), ("B", 2)])-         ]-    , testGroup "Pkg-config dependencies" [-          runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] Nothing-        , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] Nothing-        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (Just [("A", 1), ("B", 1), ("C", 1)])-        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (Just [("A", 1), ("B", 2), ("C", 1)])-        ]-    ]-  where-    -- | Combinator to turn on --independent-goals behavior, i.e. solve-    -- for the goals as if we were solving for each goal independently.-    -- (This doesn't really work well at the moment, see #2842)-    indep test      = test { testIndepGoals = IndepGoals True }-    soft prefs test = test { testSoftConstraints = prefs }-    mkvrThis        = V.thisVersion . makeV-    mkvrOrEarlier   = V.orEarlierVersion . makeV-    makeV v         = V.Version [v,0,0] []--{--------------------------------------------------------------------------------  Solver tests--------------------------------------------------------------------------------}--data SolverTest = SolverTest {-    testLabel          :: String-  , testTargets        :: [String]-  , testResult         :: Maybe [(String, Int)]-  , testIndepGoals     :: IndepGoals-  , testSoftConstraints :: [ExPreference]-  , testDb             :: ExampleDb-  , testSupportedExts  :: Maybe [Extension]-  , testSupportedLangs :: Maybe [Language]-  , testPkgConfigDb    :: PkgConfigDb-  }---- | Makes a solver test case, consisting of the following components:------      1. An 'ExampleDb', representing the package database (both---         installed and remote) we are doing dependency solving over,---      2. A 'String' name for the test,---      3. A list '[String]' of package names to solve for---      4. The expected result, either 'Nothing' if there is no---         satisfying solution, or a list '[(String, Int)]' of---         packages to install, at which versions.------ See 'UnitTests.Distribution.Client.Dependency.Modular.DSL' for how--- to construct an 'ExampleDb', as well as definitions of 'db1' etc.--- in this file.-mkTest :: ExampleDb-       -> String-       -> [String]-       -> Maybe [(String, Int)]-       -> SolverTest-mkTest = mkTestExtLangPC Nothing Nothing []--mkTestExts :: [Extension]-           -> ExampleDb-           -> String-           -> [String]-           -> Maybe [(String, Int)]-           -> SolverTest-mkTestExts exts = mkTestExtLangPC (Just exts) Nothing []--mkTestLangs :: [Language]-            -> ExampleDb-            -> String-            -> [String]-            -> Maybe [(String, Int)]-            -> SolverTest-mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) []--mkTestPCDepends :: [(String, String)]-                -> ExampleDb-                -> String-                -> [String]-                -> Maybe [(String, Int)]-                -> SolverTest-mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb--mkTestExtLangPC :: Maybe [Extension]-                -> Maybe [Language]-                -> [(String, String)]-                -> ExampleDb-                -> String-                -> [String]-                -> Maybe [(String, Int)]-                -> SolverTest-mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {-    testLabel          = label-  , testTargets        = targets-  , testResult         = result-  , testIndepGoals     = IndepGoals False-  , testSoftConstraints = []-  , testDb             = db-  , testSupportedExts  = exts-  , testSupportedLangs = langs-  , testPkgConfigDb    = pkgConfigDbFromList pkgConfigDb-  }--runTest :: SolverTest -> TF.TestTree-runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->-    testCase testLabel $ do-      let (_msgs, result) = exResolve testDb testSupportedExts-                            testSupportedLangs testPkgConfigDb testTargets-                            Modular testIndepGoals (ReorderGoals False)-                            testSoftConstraints-      when showSolverLog $ mapM_ putStrLn _msgs-      case result of-        Left  err  -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)-        Right plan -> assertEqual "" testResult (Just (extractInstallPlan plan))--{--------------------------------------------------------------------------------  Specific example database for the tests--------------------------------------------------------------------------------}--db1 :: ExampleDb-db1 =-    let a = exInst "A" 1 "A-1" []-    in [ Left a-       , Right $ exAv "B" 1 [ExAny "A"]-       , Right $ exAv "B" 2 [ExAny "A"]-       , Right $ exAv "C" 1 [ExFix "B" 1]-       , Right $ exAv "D" 1 [ExFix "B" 2]-       , Right $ exAv "E" 1 [ExAny "B"]-       , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]-       , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]-       , Right $ exAv "Z" 1 []-       ]---- In this example, we _can_ install C and D as independent goals, but we have--- to pick two diferent versions for B (arbitrarily)-db2 :: ExampleDb-db2 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 [ExAny "A"]-  , Right $ exAv "B" 2 [ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1]-  , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2]-  ]--db3 :: ExampleDb-db3 = [-     Right $ exAv "A" 1 []-   , Right $ exAv "A" 2 []-   , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]-   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]-   , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]-   ]---- | Like db3, but the flag picks a different package rather than a--- different package version------ In db3 we cannot install C and D as independent goals because:------ * The multiple instance restriction says C and D _must_ share B--- * Since C relies on A-1, C needs B to be compiled with flagB on--- * Since D relies on A-2, D needs B to be compiled with flagB off--- * Hence C and D have incompatible requirements on B's flags.------ However, _even_ if we don't check explicitly that we pick the same flag--- assignment for 0.B and 1.B, we will still detect the problem because--- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to--- 1.A and therefore we cannot link 0.B to 1.B.------ In db4 the situation however is trickier. We again cannot install--- packages C and D as independent goals because:------ * As above, the multiple instance restriction says that C and D _must_ share B--- * Since C relies on Ax-2, it requires B to be compiled with flagB off--- * Since D relies on Ay-2, it requires B to be compiled with flagB on--- * Hence C and D have incompatible requirements on B's flags.------ But now this requirement is more indirect. If we only check dependencies--- we don't see the problem:------ * We link 0.B to 1.B--- * 0.B relies on Ay-1--- * 1.B relies on Ax-1------ We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since--- we only ever assign to one of these, these constraints are never broken.-db4 :: ExampleDb-db4 = [-     Right $ exAv "Ax" 1 []-   , Right $ exAv "Ax" 2 []-   , Right $ exAv "Ay" 1 []-   , Right $ exAv "Ay" 2 []-   , Right $ exAv "B"  1 [exFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]-   , Right $ exAv "C"  1 [ExFix "Ax" 2, ExAny "B"]-   , Right $ exAv "D"  1 [ExFix "Ay" 2, ExAny "B"]-   ]---- | Some tests involving testsuites------ Note that in this test framework test suites are always enabled; if you--- want to test without test suites just set up a test database without--- test suites.------ * C depends on A (through its test suite)--- * D depends on B-2 (through its test suite), but B-2 is unavailable--- * E depends on A-1 directly and on A through its test suite. We prefer---     to use A-1 for the test suite in this case.--- * F depends on A-1 directly and on A-2 through its test suite. In this---     case we currently fail to install F, although strictly speaking---     test suites should be considered independent goals.--- * G is like E, but for version A-2. This means that if we cannot install---     E and G together, unless we regard them as independent goals.-db5 :: ExampleDb-db5 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 []-  , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"]-  , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2]-  , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"]-  , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2]-  , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"]-  ]---- Now the _dependencies_ have test suites------ * Installing C is a simple example. C wants version 1 of A, but depends on---   B, and B's testsuite depends on an any version of A. In this case we prefer---   to link (if we don't regard test suites as independent goals then of course---   linking here doesn't even come into it).--- * Installing [C, D] means that we prefer to link B -- depending on how we---   set things up, this means that we should also link their test suites.-db6 :: ExampleDb-db6 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"]-  , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]-  , Right $ exAv "D" 1 [ExAny "B"]-  ]---- Packages with setup dependencies------ Install..--- * B: Simple example, just make sure setup deps are taken into account at all--- * C: Both the package and the setup script depend on any version of A.---      In this case we prefer to link--- * D: Variation on C.1 where the package requires a specific (not latest)---      version but the setup dependency is not fixed. Again, we prefer to---      link (picking the older version)--- * E: Variation on C.2 with the setup dependency the more inflexible.---      Currently, in this case we do not see the opportunity to link because---      we consider setup dependencies after normal dependencies; we will---      pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick---      A.1 instead. This isn't so easy to fix (if we want to fix it at all);---      in particular, considering setup dependencies _before_ other deps is---      not an improvement, because in general we would prefer to link setup---      setups to package deps, rather than the other way around. (For example,---      if we change this ordering then the test for D would start to install---      two versions of A).--- * F: The package and the setup script depend on different versions of A.---      This will only work if setup dependencies are considered independent.-db7 :: ExampleDb-db7 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 []            `withSetupDeps` [ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "A"  ] `withSetupDeps` [ExAny "A"  ]-  , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"  ]-  , Right $ exAv "E" 1 [ExAny "A"  ] `withSetupDeps` [ExFix "A" 1]-  , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]-  ]---- If we install C and D together (not as independent goals), we need to build--- both B.1 and B.2, both of which depend on A.-db8 :: ExampleDb-db8 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "B" 1 [ExAny "A"]-  , Right $ exAv "B" 2 [ExAny "A"]-  , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1]-  , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2]-  ]---- Extended version of `db8` so that we have nested setup dependencies-db9 :: ExampleDb-db9 = db8 ++ [-    Right $ exAv "E" 1 [ExAny "C"]-  , Right $ exAv "E" 2 [ExAny "D"]-  , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]-  , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]-  ]---- Multiple already-installed packages with inter-dependencies, and one package--- (C) that depends on package A-1 for its setup script and package A-2 as a--- library dependency.-db10 :: ExampleDb-db10 =-  let rts         = exInst "rts"         1 "rts-inst"         []-      ghc_prim    = exInst "ghc-prim"    1 "ghc-prim-inst"    [rts]-      base        = exInst "base"        1 "base-inst"        [rts, ghc_prim]-      a1          = exInst "A"           1 "A1-inst"          [base]-      a2          = exInst "A"           2 "A2-inst"          [base]-  in [-      Left rts-    , Left ghc_prim-    , Left base-    , Left a1-    , Left a2-    , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]-    ]---- | Tests for dealing with base shims-db11 :: ExampleDb-db11 =-  let base3 = exInst "base" 3 "base-3-inst" [base4]-      base4 = exInst "base" 4 "base-4-inst" []-  in [-      Left base3-    , Left base4-    , Right $ exAv "A" 1 [ExFix "base" 3]-    ]---- | Slightly more realistic version of db11 where base-3 depends on syb--- This means that if a package depends on base-3 and on syb, then they MUST--- share the version of syb------ * Package A relies on base-3 (which relies on base-4)--- * Package B relies on base-4--- * Package C relies on both A and B--- * Package D relies on base-3 and on syb-2, which is not possible because---     base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier)--- * Package E relies on base-4 and on syb-2, which is fine.-db12 :: ExampleDb-db12 =-  let base3 = exInst "base" 3 "base-3-inst" [base4, syb1]-      base4 = exInst "base" 4 "base-4-inst" []-      syb1  = exInst "syb" 1 "syb-1-inst" [base4]-  in [-      Left base3-    , Left base4-    , Left syb1-    , Right $ exAv "syb" 2 [ExFix "base" 4]-    , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]-    , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]-    , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]-    , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]-    , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]-    ]--db13 :: ExampleDb-db13 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "A" 3 []-  ]---- | Database with some cycles------ * Simplest non-trivial cycle: A -> B and B -> A--- * There is a cycle C -> D -> C, but it can be broken by picking the---   right flag assignment.-db14 :: ExampleDb-db14 = [-    Right $ exAv "A" 1 [ExAny "B"]-  , Right $ exAv "B" 1 [ExAny "A"]-  , Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]]-  , Right $ exAv "D" 1 [ExAny "C"]-  , Right $ exAv "E" 1 []-  ]---- | Cycles through setup dependencies------ The first cycle is unsolvable: package A has a setup dependency on B,--- B has a regular dependency on A, and we only have a single version available--- for both.------ The second cycle can be broken by picking different versions: package C-2.0--- has a setup dependency on D, and D has a regular dependency on C-*. However,--- version C-1.0 is already available (perhaps it didn't have this setup dep).--- Thus, we should be able to break this cycle even if we are installing package--- E, which explictly depends on C-2.0.-db15 :: ExampleDb-db15 = [-    -- First example (real cycle, no solution)-    Right $ exAv   "A" 1            []            `withSetupDeps` [ExAny "B"]-  , Right $ exAv   "B" 1            [ExAny "A"]-    -- Second example (cycle can be broken by picking versions carefully)-  , Left  $ exInst "C" 1 "C-1-inst" []-  , Right $ exAv   "C" 2            []            `withSetupDeps` [ExAny "D"]-  , Right $ exAv   "D" 1            [ExAny "C"  ]-  , Right $ exAv   "E" 1            [ExFix "C" 2]-  ]--dbExts1 :: ExampleDb-dbExts1 = [-    Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]-  , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "B"]-  , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]-  , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]-  ]--dbLangs1 :: ExampleDb-dbLangs1 = [-    Right $ exAv "A" 1 [ExLang Haskell2010]-  , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]-  , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]-  ]---- | cabal must set enable-lib to false in order to avoid the unavailable--- dependency. Flags are true by default. The flag choice causes "pkg" to--- depend on "false-dep".-testBuildable :: String -> ExampleDependency -> TestTree-testBuildable testName unavailableDep =-    runTest $ mkTestExtLangPC (Just []) (Just []) [] db testName ["pkg"] expected-  where-    expected = Just [("false-dep", 1), ("pkg", 1)]-    db = [-        Right $ exAv "pkg" 1-            [ unavailableDep-            , ExFlag "enable-lib" (Buildable []) NotBuildable ]-         `withTest`-            ExTest "test" [exFlag "enable-lib"-                              [ExAny "true-dep"]-                              [ExAny "false-dep"]]-      , Right $ exAv "true-dep" 1 []-      , Right $ exAv "false-dep" 1 []-      ]---- | cabal must choose -flag1 +flag2 for "pkg", which requires packages--- "flag1-false" and "flag2-true".-dbBuildable1 :: ExampleDb-dbBuildable1 = [-    Right $ exAv "pkg" 1-        [ ExAny "unknown"-        , ExFlag "flag1" (Buildable []) NotBuildable-        , ExFlag "flag2" (Buildable []) NotBuildable]-     `withTests`-        [ ExTest "optional-test"-              [ ExAny "unknown"-              , ExFlag "flag1"-                    (Buildable [])-                    (Buildable [ExFlag "flag2" NotBuildable (Buildable [])])]-        , ExTest "test" [ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]-                        , exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]-        ]-  , Right $ exAv "flag1-true" 1 []-  , Right $ exAv "flag1-false" 1 []-  , Right $ exAv "flag2-true" 1 []-  , Right $ exAv "flag2-false" 1 []-  ]---- | Package databases for testing @pkg-config@ dependencies.-dbPC1 :: ExampleDb-dbPC1 = [-    Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]-  , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"]-  , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "B"]-  ]---- | cabal must pick B-2 to avoid the unknown dependency.-dbBuildable2 :: ExampleDb-dbBuildable2 = [-    Right $ exAv "A" 1 [ExAny "B"]-  , Right $ exAv "B" 1 [ExAny "unknown"]-  , Right $ exAv "B" 2-        [ ExAny "unknown"-        , ExFlag "disable-lib" NotBuildable (Buildable [])-        ]-  , Right $ exAv "B" 3 [ExAny "unknown"]-  ]
cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs view
@@ -1,5 +1,6 @@ module UnitTests.Distribution.Client.FileMonitor (tests) where +import Data.Typeable import Control.Monad import Control.Exception import Control.Concurrent (threadDelay)@@ -15,7 +16,7 @@ import Distribution.Verbosity (silent)  import Distribution.Client.FileMonitor-import Distribution.Client.Compat.Time+import Distribution.Compat.Time  import Test.Tasty import Test.Tasty.HUnit@@ -24,6 +25,7 @@ tests :: Int -> [TestTree] tests mtimeChange =   [ testCase "sanity check mtimes"   $ testFileMTimeSanity mtimeChange+  , testCase "sanity check dirs"     $ testDirChangeSanity mtimeChange   , testCase "no monitor cache"      testNoMonitorCache   , testCase "corrupt monitor cache" testCorruptMonitorCache   , testCase "empty monitor"         testEmptyMonitor@@ -34,6 +36,7 @@   , testCase "remove file"           testRemoveFile   , testCase "non-existent file"     testNonExistentFile   , testCase "changed file type"     $ testChangedFileType mtimeChange+  , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange    , testGroup "glob matches"     [ testCase "no change"           testGlobNoChange@@ -69,6 +72,8 @@   , testCase "value updated"         testValueUpdated   ] +-- Check the file system behaves the way we expect it to+ -- we rely on file mtimes having a reasonable resolution testFileMTimeSanity :: Int -> Assertion testFileMTimeSanity mtimeChange =@@ -81,6 +86,62 @@       t2 <- getModTime (dir </> "a")       assertBool "expected different file mtimes" (t2 > t1) +-- We rely on directories changing mtime when entries are added or removed+testDirChangeSanity :: Int -> Assertion+testDirChangeSanity mtimeChange =+  withTempDirectory silent "." "dir-mtime-" $ \dir -> do++    expectMTimeChange dir "file add" $+      IO.writeFile (dir </> "file") "content"++    expectMTimeSame dir "file content change" $+      IO.writeFile (dir </> "file") "new content"++    expectMTimeChange dir "file del" $+      IO.removeFile (dir </> "file")++    expectMTimeChange dir "subdir add" $+      IO.createDirectory (dir </> "dir")++    expectMTimeSame dir "subdir file add" $+      IO.writeFile (dir </> "dir" </> "file") "content"++    expectMTimeChange dir "subdir file move in" $+      IO.renameFile (dir </> "dir" </> "file") (dir </> "file")++    expectMTimeChange dir "subdir file move out" $+      IO.renameFile (dir </> "file") (dir </> "dir" </> "file")++    expectMTimeSame dir "subdir dir add" $+      IO.createDirectory (dir </> "dir" </> "subdir")++    expectMTimeChange dir "subdir dir move in" $+      IO.renameDirectory (dir </> "dir" </> "subdir") (dir </> "subdir")++    expectMTimeChange dir "subdir dir move out" $+      IO.renameDirectory (dir </> "subdir") (dir </> "dir" </> "subdir")++  where+    expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO ()+                                       -> Assertion++    expectMTimeChange dir descr action = do+      t  <- getModTime dir+      threadDelay mtimeChange+      action+      t' <- getModTime dir+      assertBool ("expected dir mtime change on " ++ descr) (t' > t)++    expectMTimeSame dir descr action = do+      t  <- getModTime dir+      threadDelay mtimeChange+      action+      t' <- getModTime dir+      assertBool ("expected same dir mtime on " ++ descr) (t' == t)+++-- Now for the FileMonitor tests proper...+ -- first run, where we don't even call updateMonitor testNoMonitorCache :: Assertion testNoMonitorCache =@@ -328,7 +389,35 @@         reason <- expectMonitorChanged root monitor ()         reason @?= MonitoredFileChanged "a" +-- Monitoring the same file with two different kinds of monitor should work+-- both should be kept, and both checked for changes.+-- We had a bug where only one monitor kind was kept per file.+-- https://github.com/haskell/cabal/pull/3863#issuecomment-248495178+testMultipleMonitorKinds :: Int -> Assertion+testMultipleMonitorKinds mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFile "a", monitorFileHashed "a"]+    threadDelay mtimeChange+    touchFile root "a" -- not changing content, just mtime+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a" +    createDir root "dir"+    updateMonitor root monitor [monitorDirectory "dir",+                                monitorDirectoryExistence "dir"] () ()+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"]+    threadDelay mtimeChange+    touchFile root ("dir" </> "a") -- changing dir mtime, not existence+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "dir"++ ------------------ -- globs --@@ -723,7 +812,7 @@   | otherwise                        = error $ "Failed to parse " ++ globstr  -expectMonitorChanged :: (Binary a, Binary b)+expectMonitorChanged :: (Binary a, Binary b, Typeable a, Typeable b)                      => RootPath -> FileMonitor a b -> a                      -> IO (MonitorChangedReason a) expectMonitorChanged root monitor key = do@@ -732,7 +821,7 @@     MonitorChanged reason -> return reason     MonitorUnchanged _ _  -> throwIO $ HUnitFailure "expected change" -expectMonitorUnchanged :: (Binary a, Binary b)+expectMonitorUnchanged :: (Binary a, Binary b, Typeable a, Typeable b)                         => RootPath -> FileMonitor a b -> a                         -> IO (b, [MonitorFilePath]) expectMonitorUnchanged root monitor key = do@@ -741,19 +830,19 @@     MonitorChanged _reason   -> throwIO $ HUnitFailure "expected no change"     MonitorUnchanged b files -> return (b, files) -checkChanged :: (Binary a, Binary b)+checkChanged :: (Binary a, Binary b, Typeable a, Typeable b)              => RootPath -> FileMonitor a b              -> a -> IO (MonitorChanged a b) checkChanged (RootPath root) monitor key =   checkFileMonitorChanged monitor root key -updateMonitor :: (Binary a, Binary b)+updateMonitor :: (Binary a, Binary b, Typeable a, Typeable b)               => RootPath -> FileMonitor a b               -> [MonitorFilePath] -> a -> b -> IO () updateMonitor (RootPath root) monitor files key result =   updateFileMonitor monitor root Nothing files key result -updateMonitorWithTimestamp :: (Binary a, Binary b)+updateMonitorWithTimestamp :: (Binary a, Binary b, Typeable a, Typeable b)               => RootPath -> FileMonitor a b -> MonitorTimestamp               -> [MonitorFilePath] -> a -> b -> IO () updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result =
cabal/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs view
@@ -40,12 +40,12 @@ testParseCases :: Assertion testParseCases = do -  FilePathGlob FilePathUnixRoot GlobDirTrailing <- testparse "/"+  FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"   FilePathGlob FilePathHomeDir  GlobDirTrailing <- testparse "~/" -  FilePathGlob (FilePathWinDrive 'A') GlobDirTrailing <- testparse "A:/"-  FilePathGlob (FilePathWinDrive 'Z') GlobDirTrailing <- testparse "z:/"-  FilePathGlob (FilePathWinDrive 'C') GlobDirTrailing <- testparse "C:\\"+  FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"+  FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"+  FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"   FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"    FilePathGlob FilePathRelative@@ -68,7 +68,7 @@     (GlobDir [Literal "foo"]       (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/" -  FilePathGlob FilePathUnixRoot+  FilePathGlob (FilePathRoot "/")     (GlobDir [Literal "foo"]       (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/" @@ -134,16 +134,17 @@   arbitrary =     frequency       [ (3, pure FilePathRelative)-      , (1, pure FilePathUnixRoot)+      , (1, pure (FilePathRoot unixroot))+      , (1, FilePathRoot <$> windrive)       , (1, pure FilePathHomeDir)-      , (1, FilePathWinDrive <$> choose ('A', 'Z'))       ]+    where+      unixroot = "/"+      windrive = do d <- choose ('A', 'Z'); return (d : ":\\")    shrink FilePathRelative     = []-  shrink FilePathUnixRoot     = [FilePathRelative]+  shrink (FilePathRoot _)     = [FilePathRelative]   shrink FilePathHomeDir      = [FilePathRelative]-  shrink (FilePathWinDrive d) = FilePathRelative-                              : [ FilePathWinDrive d' | d' <- shrink d ]   instance Arbitrary FilePathGlobRel where
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs view
@@ -0,0 +1,60 @@+module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where++import Distribution.Text+import Data.Time+import Data.Time.Clock.POSIX++import Distribution.Client.IndexUtils.Timestamp++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests =+    [ testProperty "Timestamp1" prop_timestamp1+    , testProperty "Timestamp2" prop_timestamp2+    , testProperty "Timestamp3" prop_timestamp3+    , testProperty "Timestamp4" prop_timestamp4+    , testProperty "Timestamp5" prop_timestamp5+    ]++-- test unixtime format parsing+prop_timestamp1 :: Int -> Bool+prop_timestamp1 t0 = Just t == simpleParse ('@':show t0)+  where+    t = toEnum t0 :: Timestamp++-- test display/simpleParse roundtrip+prop_timestamp2 :: Int -> Bool+prop_timestamp2 t0+  | t /= nullTimestamp  = simpleParse (display t) == Just t+  | otherwise           = display t == ""+  where+    t = toEnum t0 :: Timestamp++-- test display against reference impl+prop_timestamp3 :: Int -> Bool+prop_timestamp3 t0+  | t /= nullTimestamp  = refDisp t == display t+  | otherwise           = display t == ""+  where+    t = toEnum t0 :: Timestamp++    refDisp = maybe undefined (formatTime undefined "%FT%TZ")+              . timestampToUTCTime++-- test utcTimeToTimestamp/timestampToUTCTime roundtrip+prop_timestamp4 :: Int -> Bool+prop_timestamp4 t0+  | t /= nullTimestamp  = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t+  | otherwise           = timestampToUTCTime t == Nothing+  where+    t = toEnum t0 :: Timestamp++prop_timestamp5 :: Int -> Bool+prop_timestamp5 t0+  | t /= nullTimestamp = timestampToUTCTime t == Just ut+  | otherwise          = timestampToUTCTime t == Nothing+  where+    t = toEnum t0 :: Timestamp+    ut = posixSecondsToUTCTime (fromIntegral t0)
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE ConstraintKinds #-}+module UnitTests.Distribution.Client.InstallPlan (tests) where++import           Distribution.Package+import           Distribution.Version+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)+import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph (IsNode(..))+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.PackageFixedDeps+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Client.Types+import           Distribution.Client.JobControl++import Data.Graph+import Data.Array hiding (index)+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)+import Data.IORef+import Control.Monad+import Control.Concurrent (threadDelay)+import System.Random+import Test.QuickCheck++import Test.Tasty+import Test.Tasty.QuickCheck+++tests :: [TestTree]+tests =+  [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder+  , testProperty "executionOrder"          prop_executionOrder+  , testProperty "execute serial"          prop_execute_serial+  , testProperty "execute parallel"        prop_execute_parallel+  , testProperty "execute/executionOrder"  prop_execute_vs_executionOrder+  ]++prop_reverseTopologicalOrder :: TestInstallPlan -> Bool+prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) =+    isReverseTopologicalOrder+      graph+      (map (toVertex . installedUnitId)+           (InstallPlan.reverseTopologicalOrder plan))++-- | @executionOrder@ is in reverse topological order+prop_executionOrder :: TestInstallPlan -> Bool+prop_executionOrder (TestInstallPlan plan graph toVertex _) =+    isReversePartialTopologicalOrder graph (map toVertex pkgids)+ && allConfiguredPackages plan == Set.fromList pkgids+  where+    pkgids = map installedUnitId (InstallPlan.executionOrder plan)++-- | @execute@ is in reverse topological order+prop_execute_serial :: TestInstallPlan -> Property+prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) =+    ioProperty $ do+      jobCtl <- newSerialJobControl+      pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())+      return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)+            && allConfiguredPackages plan == Set.fromList pkgids++prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property+prop_execute_parallel (Positive (Small maxJobLimit))+                      tplan@(TestInstallPlan plan graph toVertex _) =+    ioProperty $ do+      jobCtl <- newParallelJobControl maxJobLimit+      pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do+                  delay <- randomRIO (0,1000)+                  threadDelay delay+      return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)+            && allConfiguredPackages plan == Set.fromList pkgids++-- | return the packages that are visited by execute, in order.+executeTestInstallPlan :: JobControl IO (UnitId, Either () ())+                       -> TestInstallPlan+                       -> (TestPkg -> IO ())+                       -> IO [UnitId]+executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do+    resultsRef <- newIORef []+    _ <- InstallPlan.execute jobCtl False (const ())+                             plan $ \(ReadyPackage pkg) -> do+           visit pkg+           atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ())+           return (Right ())+    fmap reverse (readIORef resultsRef)++-- | @execute@ visits the packages in the same order as @executionOrder@+prop_execute_vs_executionOrder :: TestInstallPlan -> Property+prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) =+    ioProperty $ do+      jobCtl <- newSerialJobControl+      pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())+      let pkgids' = map installedUnitId (InstallPlan.executionOrder plan)+      return (pkgids == pkgids')+++--------------------------+-- Property helper utils+--++-- | A graph topological ordering is a linear ordering of its vertices such+-- that for every directed edge uv from vertex u to vertex v, u comes before v+-- in the ordering.+--+-- A reverse topological ordering is the swapped: for every directed edge uv+-- from vertex u to vertex v, v comes before u in the ordering.+--+isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool+isReverseTopologicalOrder g vs =+    and [ ixs ! u > ixs ! v+        | let ixs = array (bounds g) (zip vs [0::Int ..])+        , (u,v) <- edges g ]++isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool+isReversePartialTopologicalOrder g vs =+    and [ case (ixs ! u, ixs ! v) of+            (Just ixu, Just ixv) -> ixu > ixv+            _                    -> True+        | let ixs = array (bounds g)+                          (zip (range (bounds g)) (repeat Nothing) ++ +                           zip vs (map Just [0::Int ..]))+        , (u,v) <- edges g ]++allConfiguredPackages :: HasUnitId srcpkg+                      => GenericInstallPlan ipkg srcpkg -> Set UnitId+allConfiguredPackages plan =+    Set.fromList+      [ installedUnitId pkg+      | InstallPlan.Configured pkg <- InstallPlan.toList plan ]+++--------------------+-- Test generators+--++data TestInstallPlan = TestInstallPlan+                         (GenericInstallPlan TestPkg TestPkg)+                         Graph+                         (UnitId -> Vertex)+                         (Vertex -> UnitId)++instance Show TestInstallPlan where+  show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan++data TestPkg = TestPkg PackageId UnitId [UnitId]+  deriving (Eq, Show)++instance IsNode TestPkg where+  type Key TestPkg = UnitId+  nodeKey (TestPkg _ ipkgid _) = ipkgid+  nodeNeighbors (TestPkg _ _ deps) = deps+++instance Package TestPkg where+  packageId (TestPkg pkgid _ _) = pkgid++instance HasUnitId TestPkg where+  installedUnitId (TestPkg _ ipkgid _) = ipkgid++instance PackageFixedDeps TestPkg where+  depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps++instance PackageInstalled TestPkg where+  installedDepends (TestPkg _ _ deps) = deps++instance Arbitrary TestInstallPlan where+  arbitrary = arbitraryTestInstallPlan++arbitraryTestInstallPlan :: Gen TestInstallPlan+arbitraryTestInstallPlan = do+    graph <- arbitraryAcyclicGraph+               (choose (2,5))+               (choose (1,5))+               0.3++    plan  <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph++    let toVertexMap   = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ]+        fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ]+        toVertex      = (toVertexMap   Map.!)+        fromVertex    = (fromVertexMap Map.!)++    return (TestInstallPlan plan graph toVertex fromVertex)+  where+    mkTestPkg pkgv depvs =+        return (TestPkg pkgid ipkgid deps)+      where+        pkgid  = mkPkgId pkgv+        ipkgid = mkUnitIdV pkgv+        deps   = map mkUnitIdV depvs+    mkUnitIdV = mkUnitId . show+    mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v))+                                  (mkVersion [1])+++-- | Generate a random 'InstallPlan' following the structure of an existing+-- 'Graph'.+--+-- It takes generators for installed and source packages and the chance that+-- each package is installed (for those packages with no prerequisites).+--+arbitraryInstallPlan :: (IsUnit ipkg,+                         IsUnit srcpkg)+                     => (Vertex -> [Vertex] -> Gen ipkg)+                     -> (Vertex -> [Vertex] -> Gen srcpkg)+                     -> Float+                     -> Graph+                     -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg)+arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do++    (ipkgvs, srcpkgvs) <-+      fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs))+            . partition snd) $+      sequence+        [ do isipkg <- if isRoot then pick ipkgProportion+                                 else return False+             return (v, isipkg)+        | (v,n) <- assocs (outdegree graph)+        , let isRoot = n == 0 ]++    ipkgs   <- sequence+                 [ mkIPkg pkgv depvs+                 | pkgv <- ipkgvs+                 , let depvs  = graph ! pkgv+                 ]+    srcpkgs <- sequence+                 [ mkSrcPkg pkgv depvs+                 | pkgv <- srcpkgvs+                 , let depvs  = graph ! pkgv+                 ]+    let index = Graph.fromList (map InstallPlan.PreExisting ipkgs+                             ++ map InstallPlan.Configured  srcpkgs)+    return $ InstallPlan.new (IndependentGoals False) index+++-- | Generate a random directed acyclic graph, based on the algorithm presented+-- here <http://stackoverflow.com/questions/12790337/generating-a-random-dag>+--+-- It generates a DAG based on ranks of nodes. Nodes in each rank can only+-- have edges to nodes in subsequent ranks.+--+-- The generator is paramterised by a generator for the number of ranks and+-- the number of nodes within each rank. It is also paramterised by the+-- chance that each node in each rank will have an edge from each node in+-- each previous rank. Thus a higher chance will produce a more densely+-- connected graph.+--+arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph+arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do+    nranks    <- genNRanks+    rankSizes <- replicateM nranks genNPerRank+    let rankStarts = scanl (+) 0 rankSizes+        rankRanges = drop 1 (zip rankStarts (tail rankStarts))+        totalRange = sum rankSizes+    rankEdges <- mapM (uncurry genRank) rankRanges+    return $ buildG (0, totalRange-1) (concat rankEdges)+  where+    genRank :: Vertex -> Vertex -> Gen [Edge]+    genRank rankStart rankEnd =+      filterM (const (pick edgeChance))+        [ (i,j)+        | i <- [0..rankStart-1]+        , j <- [rankStart..rankEnd-1]+        ]++pick :: Float -> Gen Bool+pick chance = do+    p <- choose (0,1)+    return (p < chance)+++--------------------------------+-- Inspecting generated graphs+--++{-+-- Handy util for checking the generated graphs look sensible+writeDotFile :: FilePath -> Graph -> IO ()+writeDotFile file = writeFile file . renderDotGraph++renderDotGraph :: Graph -> String+renderDotGraph graph =+  unlines (+      [header+      ,graphDefaultAtribs+      ,nodeDefaultAtribs+      ,edgeDefaultAtribs]+    ++ map renderNode (vertices graph)+    ++ map renderEdge (edges graph)+    ++ [footer]+  )+  where+    renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++  "\"];"++    renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];"+++header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String++header = "digraph packages {"+footer = "}"++graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];"+nodeDefaultAtribs  = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];"+edgeDefaultAtribs  = "\tedge [fontsize=10];"+-}
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DeriveDataTypeable #-}+module UnitTests.Distribution.Client.JobControl (tests) where++import Distribution.Client.JobControl++import Data.List+import Data.Maybe+import Data.IORef+import Control.Monad+import Control.Concurrent (threadDelay)+import Control.Exception  (Exception, try, throwIO)+import Data.Typeable      (Typeable)+import qualified Data.Set as Set++import Test.Tasty+import Test.Tasty.QuickCheck hiding (collect)+++tests :: [TestTree]+tests =+  [ testGroup "serial"+      [ testProperty "submit batch"       prop_submit_serial+      , testProperty "submit batch"       prop_remaining_serial+      , testProperty "submit interleaved" prop_interleaved_serial+      , testProperty "concurrent jobs"    prop_concurrent_serial+      , testProperty "cancel"             prop_cancel_serial+      , testProperty "exceptions"         prop_exception_serial+      ]+  , testGroup "parallel"+      [ testProperty "submit batch"       prop_submit_parallel+      , testProperty "submit batch"       prop_remaining_parallel+      , testProperty "submit interleaved" prop_interleaved_parallel+      , testProperty "concurrent jobs"    prop_concurrent_parallel+      , testProperty "cancel"             prop_cancel_parallel+      , testProperty "exceptions"         prop_exception_parallel+      ]+  ]+++prop_submit_serial :: [Int] -> Property+prop_submit_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_submit jobCtl xs++prop_submit_parallel :: Positive (Small Int) -> [Int] -> Property+prop_submit_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_submit jobCtl xs++prop_remaining_serial :: [Int] -> Property+prop_remaining_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_remaining jobCtl xs++prop_remaining_parallel :: Positive (Small Int) -> [Int] -> Property+prop_remaining_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_remaining jobCtl xs++prop_interleaved_serial :: [Int] -> Property+prop_interleaved_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_submit_interleaved jobCtl xs++prop_interleaved_parallel :: Positive (Small Int) -> [Int] -> Property+prop_interleaved_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_submit_interleaved jobCtl xs++prop_submit :: JobControl IO Int -> [Int] -> IO Bool+prop_submit jobCtl xs = do+    mapM_ (\x -> spawnJob jobCtl (return x)) xs+    xs' <- mapM (\_ -> collectJob jobCtl) xs+    return (sort xs == sort xs')++prop_remaining :: JobControl IO Int -> [Int] -> IO Bool+prop_remaining jobCtl xs = do+    mapM_ (\x -> spawnJob jobCtl (return x)) xs+    xs' <- collectRemainingJobs jobCtl+    return (sort xs == sort xs')++collectRemainingJobs :: Monad m => JobControl m a -> m [a]+collectRemainingJobs jobCtl = go []+  where+    go xs = do+      remaining <- remainingJobs jobCtl+      if remaining+        then do x <- collectJob jobCtl+                go (x:xs)+        else return xs++prop_submit_interleaved :: JobControl IO (Maybe Int) -> [Int] -> IO Bool+prop_submit_interleaved jobCtl xs = do+    xs' <- sequence+      [ spawn >> collect+      | let spawns   = map (\x -> spawnJob jobCtl (return (Just x))) xs+                    ++ repeat (return ())+            collects = replicate 5 (return Nothing)+                    ++ map (\_ -> collectJob jobCtl) xs+      , (spawn, collect) <- zip spawns collects+      ]+    return (sort xs == sort (catMaybes xs'))++prop_concurrent_serial :: NonNegative (Small Int) -> Property+prop_concurrent_serial (NonNegative (Small ntasks)) =+  ioProperty $ do+    jobCtl   <- newSerialJobControl+    countRef <- newIORef (0 :: Int)+    replicateM_ ntasks (spawnJob jobCtl (task countRef))+    counts   <- replicateM ntasks (collectJob jobCtl)+    return $ length counts == ntasks+          && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts+  where+    task countRef = do+      n0 <- atomicModifyIORef countRef (\n -> (n+1, n))+      threadDelay 100+      n1 <- atomicModifyIORef countRef (\n -> (n-1, n))+      return (n0, n1)++prop_concurrent_parallel :: Positive (Small Int) -> NonNegative Int -> Property+prop_concurrent_parallel (Positive (Small maxJobLimit)) (NonNegative ntasks) =+  ioProperty $ do+    jobCtl   <- newParallelJobControl maxJobLimit+    countRef <- newIORef (0 :: Int)+    replicateM_ ntasks (spawnJob jobCtl (task countRef))+    counts   <- replicateM ntasks (collectJob jobCtl)+    return $ length counts == ntasks+          && all (\(n0, n1) -> n0 >= 0 && n0 <  maxJobLimit+                            && n1 >  0 && n1 <= maxJobLimit) counts+             -- we do hit the concurrency limit (in the right circumstances)+          && if ntasks >= maxJobLimit*2 -- give us enough of a margin+               then any (\(_,n1) -> n1 == maxJobLimit) counts+               else True+  where+    task countRef = do+      n0 <- atomicModifyIORef countRef (\n -> (n+1, n))+      threadDelay 100+      n1 <- atomicModifyIORef countRef (\n -> (n-1, n))+      return (n0, n1)++prop_cancel_serial :: [Int] -> [Int] -> Property+prop_cancel_serial xs ys =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    mapM_ (\x -> spawnJob jobCtl (return x)) (xs++ys)+    xs' <- mapM (\_ -> collectJob jobCtl) xs+    cancelJobs jobCtl+    ys' <- collectRemainingJobs jobCtl+    return (sort xs == sort xs' && null ys')++prop_cancel_parallel :: Positive (Small Int) -> [Int] -> [Int] -> Property+prop_cancel_parallel (Positive (Small maxJobLimit)) xs ys = do+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    mapM_ (\x -> spawnJob jobCtl (threadDelay 100  >> return x)) (xs++ys)+    xs' <- mapM (\_ -> collectJob jobCtl) xs+    cancelJobs jobCtl+    ys' <- collectRemainingJobs jobCtl+    return $ Set.fromList (xs'++ys') `Set.isSubsetOf` Set.fromList (xs++ys)++data TestException = TestException Int+  deriving (Typeable, Show)++instance Exception TestException++prop_exception_serial :: [Either Int Int] -> Property+prop_exception_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_exception jobCtl xs++prop_exception_parallel :: Positive (Small Int) -> [Either Int Int] -> Property+prop_exception_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_exception jobCtl xs++prop_exception :: JobControl IO Int -> [Either Int Int] -> IO Bool+prop_exception jobCtl xs = do+    mapM_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs+    xs' <- replicateM (length xs) $ do+             mx <- try (collectJob jobCtl)+             return $ case mx of+               Left (TestException n) -> Left  n+               Right               n  -> Right n+    return (sort xs == sort xs')+
cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs view
@@ -31,6 +31,10 @@ import Distribution.Utils.NubList import Network.URI +import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.Settings+ import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy @@ -72,7 +76,7 @@   where     usingGhc76orOlder =       case buildCompilerId of-        CompilerId GHC v -> v < Version [7,7] []+        CompilerId GHC v -> v < mkVersion [7,7]         _                -> False  @@ -91,8 +95,11 @@   prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool-prop_roundtrip_legacytypes_all =+prop_roundtrip_legacytypes_all config =     roundtrip_legacytypes+      config {+        projectConfigProvenance = mempty+      }  prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool prop_roundtrip_legacytypes_packages config =@@ -100,6 +107,7 @@       config {         projectConfigBuildOnly       = mempty,         projectConfigShared          = mempty,+        projectConfigProvenance      = mempty,         projectConfigLocalPackages   = mempty,         projectConfigSpecificPackage = mempty       }@@ -122,7 +130,7 @@ prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Bool prop_roundtrip_legacytypes_specific config =     roundtrip_legacytypes-      mempty { projectConfigSpecificPackage = config }+      mempty { projectConfigSpecificPackage = MapMappend config }   --------------------------------------------@@ -136,7 +144,7 @@         . showLegacyProjectConfig         . convertToLegacyProjectConfig)           config of-      ParseOk _ x -> x == config+      ParseOk _ x -> x == config { projectConfigProvenance = mempty }       _           -> False  @@ -194,8 +202,8 @@       --TODO: [required eventually] parse ambiguity in constraint       -- "pkgname -any" as either any version or disabled flag "any".         let ambiguous ((UserConstraintFlags _pkg flags), _) =-              (not . null) [ () | (FlagName name, False) <- flags-                                , "any" `isPrefixOf` name ]+              (not . null) [ () | (name, False) <- flags+                                , "any" `isPrefixOf` unFlagName name ]             ambiguous _ = False          in filter (not . ambiguous) (projectConfigConstraints config)     }@@ -213,7 +221,7 @@ prop_roundtrip_printparse_specific config =     roundtrip_printparse       mempty {-        projectConfigSpecificPackage = fmap getNonMEmpty config+        projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)       }  @@ -240,16 +248,21 @@         <*> (map getPackageLocationString <$> arbitrary)         <*> shortListOf 3 arbitrary         <*> arbitrary-        <*> arbitrary <*> arbitrary         <*> arbitrary-        <*> (fmap getNonMEmpty . Map.fromList <$> shortListOf 3 arbitrary)+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (MapMappend . fmap getNonMEmpty . Map.fromList+               <$> shortListOf 3 arbitrary)         -- package entries with no content are equivalent to         -- the entry not existing at all, so exclude empty -    shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7) =-      [ ProjectConfig x0' x1' x2' x3' x4' x5' x6' (fmap getNonMEmpty x7')-      | ((x0', x1', x2', x3'), (x4', x5', x6', x7'))-          <- shrink ((x0, x1, x2, x3), (x4, x5, x6, fmap NonMEmpty x7))+    shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7 x8) =+      [ ProjectConfig x0' x1' x2' x3'+                      x4' x5' x6' x7' (MapMappend (fmap getNonMEmpty x8'))+      | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8'))+          <- shrink ((x0, x1, x2, x3),+                     (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8)))       ]  newtype PackageLocationString@@ -292,11 +305,10 @@         <*> arbitrary         <*> arbitraryNumJobs         <*> arbitrary-        <*> arbitrary                                           -- 12-        <*> (fmap getShortToken <$> arbitrary)         <*> arbitrary+        <*> arbitrary         <*> (fmap getShortToken <$> arbitrary)-        <*> (fmap getShortToken <$> arbitrary)                  -- 16+        <*> arbitrary         <*> (fmap getShortToken <$> arbitrary)         <*> (fmap getShortToken <$> arbitrary)       where@@ -305,19 +317,19 @@     shrink (ProjectConfigBuildOnly               x00 x01 x02 x03 x04 x05 x06 x07               x08 x09 x10 x11 x12 x13 x14 x15-              x16 x17) =+              x16) =       [ ProjectConfigBuildOnly           x00' x01' x02' x03' x04'           x05' x06' x07' x08' (postShrink_NumJobs x09')-          x10' x11' x12  x13' x14-          x15 x16 x17+          x10' x11' x12' x13  x14'+          x15  x16       | ((x00', x01', x02', x03', x04'),          (x05', x06', x07', x08', x09'),-         (x10', x11',       x13'))+         (x10', x11', x12',       x14'))           <- shrink                ((x00, x01, x02, x03, x04),                 (x05, x06, x07, x08, preShrink_NumJobs x09),-                (x10, x11,      x13))+                (x10, x11, x12,      x14))       ]       where         preShrink_NumJobs  = fmap (fmap Positive)@@ -326,30 +338,20 @@ instance Arbitrary ProjectConfigShared where     arbitrary =       ProjectConfigShared-        <$> (Map.fromList <$> shortListOf 10 -              ((,) <$> arbitraryProgramName-                   <*> arbitraryShortToken))-        <*> (Map.fromList <$> shortListOf 10 -              ((,) <$> arbitraryProgramName-                   <*> listOf arbitraryShortToken))-        <*> (toNubList <$> listOf arbitraryShortToken)-        <*> arbitrary                                           --  4+        <$> arbitrary                                           --  4         <*> arbitraryFlag arbitraryShortToken         <*> arbitraryFlag arbitraryShortToken         <*> arbitrary-        <*> arbitrary                                           --  8+        <*> arbitrary         <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitrary         <*> arbitraryConstraints-        <*> arbitrary <*> shortListOf 2 arbitrary               -- 12+        <*> shortListOf 2 arbitrary         <*> arbitrary <*> arbitrary-        <*> arbitrary <*> arbitrary                             -- 16         <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary       where-        arbitraryProgramName :: Gen String-        arbitraryProgramName =-          elements [ programName prog-                   | (prog, _) <- knownPrograms (defaultProgramDb) ]-         arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]         arbitraryConstraints =             map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary@@ -358,36 +360,22 @@               x00 x01 x02 x03 x04               x05 x06 x07 x08 x09               x10 x11 x12 x13 x14-              x15 x16 x17) =+              x15 x16) =       [ ProjectConfigShared-          (postShrink_Paths x00')-          (postShrink_Args  x01')-          x02' x03'-          (fmap getNonEmpty x04')-          (fmap getNonEmpty x05')-               x06' x07' x08'-          (postShrink_Constraints x09')-          x10' x11' x12' x13' x14'-          x15' x16' x17'+          x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04'+          x05' x06' (postShrink_Constraints x07') x08' x09'+          x10' x11' x12' x13' x14' x15' x16'       | ((x00', x01', x02', x03', x04'),          (x05', x06', x07', x08', x09'),          (x10', x11', x12', x13', x14'),-         (x15', x16', x17'))+         (x15', x16'))           <- shrink-               ((preShrink_Paths x00,-                 preShrink_Args  x01,-                 x02, x03, fmap NonEmpty x04),-                (fmap NonEmpty x05, x06, x07, x08, preShrink_Constraints x09),+               ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04),+                (x05, x06, preShrink_Constraints x07, x08, x09),                 (x10, x11, x12, x13, x14),-                (x15, x16, x17))+                (x15, x16))       ]       where-        preShrink_Paths  = Map.map NonEmpty . Map.mapKeys NoShrink-        postShrink_Paths = Map.map getNonEmpty . Map.mapKeys getNoShrink-        preShrink_Args   = Map.map (NonEmpty . map NonEmpty)-                         . Map.mapKeys NoShrink-        postShrink_Args  = Map.map (map getNonEmpty . getNonEmpty)-                         . Map.mapKeys getNoShrink         preShrink_Constraints  = map fst         postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) @@ -395,34 +383,51 @@ projectConfigConstraintSource =      ConstraintSourceProjectConfig "TODO" +instance Arbitrary ProjectConfigProvenance where+    arbitrary = elements [Implicit, Explicit "cabal.project"]+ instance Arbitrary PackageConfig where     arbitrary =       PackageConfig-        <$> arbitrary <*> arbitrary-        <*> arbitrary <*> arbitrary                             --  4+        <$> (MapLast . Map.fromList <$> shortListOf 10+              ((,) <$> arbitraryProgramName+                   <*> arbitraryShortToken))+        <*> (MapMappend . Map.fromList <$> shortListOf 10+              ((,) <$> arbitraryProgramName+                   <*> listOf arbitraryShortToken))+        <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitrary         <*> arbitrary <*> arbitrary-        <*> arbitrary <*> arbitrary                             --  8+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary         <*> shortListOf 5 arbitraryShortToken         <*> arbitrary-        <*> arbitrary <*> arbitrary                             -- 12+        <*> arbitrary <*> arbitrary         <*> shortListOf 5 arbitraryShortToken         <*> shortListOf 5 arbitraryShortToken         <*> shortListOf 5 arbitraryShortToken-        <*> arbitrary                                           -- 16+        <*> arbitrary         <*> arbitrary <*> arbitrary-        <*> arbitrary <*> arbitrary                             -- 20         <*> arbitrary <*> arbitrary-        <*> arbitrary <*> arbitrary                             -- 24         <*> arbitrary <*> arbitrary-        <*> arbitrary <*> arbitrary                             -- 28+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary         <*> arbitraryFlag arbitraryShortToken         <*> arbitrary-        <*> arbitrary <*> arbitrary                             -- 32         <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary         <*> arbitraryFlag arbitraryShortToken         <*> arbitrary-        <*> arbitraryFlag arbitraryShortToken                   -- 36+        <*> arbitraryFlag arbitraryShortToken         <*> arbitrary+      where+        arbitraryProgramName :: Gen String+        arbitraryProgramName =+          elements [ programName prog+                   | (prog, _) <- knownPrograms (defaultProgramDb) ]      shrink (PackageConfig               x00 x01 x02 x03 x04@@ -431,41 +436,60 @@               x15 x16 x17 x18 x19               x20 x21 x22 x23 x24               x25 x26 x27 x28 x29-              x30 x31 x32 x33 x34-              x35 x36) =+              x30 x31 x32 x33 x33_1 x34+              x35 x36 x37 x38 x39+              x40) =       [ PackageConfig-          x00' x01' x02' x03' x04'-          x05' x06' x07' (map getNonEmpty x08') x09'-          x10' x11'-          (map getNonEmpty x12')-          (map getNonEmpty x13')-          (map getNonEmpty x14')-          x15' x16' x17' x18' x19'+          (postShrink_Paths x00')+          (postShrink_Args  x01') x02' x03' x04'+          x05' x06' x07' x08' x09'+          x10' x11' (map getNonEmpty x12') x13' x14'+          x15' (map getNonEmpty x16')+               (map getNonEmpty x17')+               (map getNonEmpty x18')+                              x19'           x20' x21' x22' x23' x24'           x25' x26' x27' x28' x29'-          x30' x31' x32' (fmap getNonEmpty x33') x34'-          (fmap getNonEmpty x35') x36'+          x30' x31' x32' x33' x33_1' x34'+          x35' x36' (fmap getNonEmpty x37') x38'+                    (fmap getNonEmpty x39')+          x40'       | (((x00', x01', x02', x03', x04'),           (x05', x06', x07', x08', x09'),           (x10', x11', x12', x13', x14'),           (x15', x16', x17', x18', x19')),          ((x20', x21', x22', x23', x24'),           (x25', x26', x27', x28', x29'),-          (x30', x31', x32', x33', x34'),-          (x35', x36')))+          (x30', x31', x32', (x33', x33_1'), x34'),+          (x35', x36', x37', x38', x39'),+          (x40')))           <- shrink-               (((x00, x01, x02, x03, x04),-                 (x05, x06, x07, map NonEmpty x08, x09),-                 (x10, x11,-                  map NonEmpty x12,-                  map NonEmpty x13,-                  map NonEmpty x14),-                 (x15, x16, x17, x18, x19)),+               (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04),+                 (x05, x06, x07, x08, x09),+                 (x10, x11, map NonEmpty x12, x13, x14),+                 (x15, map NonEmpty x16,+                       map NonEmpty x17,+                       map NonEmpty x18,+                       x19)),                 ((x20, x21, x22, x23, x24),                  (x25, x26, x27, x28, x29),-                 (x30, x31, x32, fmap NonEmpty x33, x34),-                 (fmap NonEmpty x35, x36)))+                 (x30, x31, x32, (x33, x33_1), x34),+                 (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39),+                 (x40)))       ]+      where+        preShrink_Paths  = Map.map NonEmpty+                         . Map.mapKeys NoShrink+                         . getMapLast+        postShrink_Paths = MapLast+                         . Map.map getNonEmpty+                         . Map.mapKeys getNoShrink+        preShrink_Args   = Map.map (NonEmpty . map NonEmpty)+                         . Map.mapKeys NoShrink+                         . getMapMappend+        postShrink_Args  = MapMappend+                         . Map.map (map getNonEmpty . getNonEmpty)+                         . Map.mapKeys getNoShrink   instance Arbitrary SourceRepo where@@ -476,7 +500,7 @@                            <*> (fmap getShortToken <$> arbitrary)                            <*> (fmap getShortToken <$> arbitrary)                            <*> (fmap getShortToken <$> arbitrary))-                `suchThat` (/= emptySourceRepo)+                `suchThat` (/= emptySourceRepo RepoThis)      shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =       [ repo@@ -493,14 +517,9 @@                               (fmap getShortToken x4')                               (fmap getShortToken x5')                               (fmap getShortToken x6')-      , repo /= emptySourceRepo+      , repo /= emptySourceRepo RepoThis       ] -emptySourceRepo :: SourceRepo-emptySourceRepo = SourceRepo RepoThis Nothing Nothing Nothing-                                      Nothing Nothing Nothing-- instance Arbitrary RepoType where     arbitrary = elements knownRepoTypes @@ -521,7 +540,7 @@         <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  4         <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  8         <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12-        <*> arbitrary <*> arbitrary                             -- 14+        <*> arbitrary <*> arbitrary <*> arbitrary               -- 15  instance Arbitrary PackageDB where     arbitrary = oneof [ pure GlobalPackageDB@@ -557,7 +576,7 @@     arbitrary = elements [minBound..maxBound]  instance Arbitrary FlagName where-    arbitrary = FlagName <$> flagident+    arbitrary = mkFlagName <$> flagident       where         flagident   = lowercase <$> shortListOf1 5 (elements flagChars)                       `suchThat` (("-" /=) . take 1)@@ -566,15 +585,30 @@ instance Arbitrary PreSolver where     arbitrary = elements [minBound..maxBound] +instance Arbitrary ReorderGoals where+    arbitrary = ReorderGoals <$> arbitrary++instance Arbitrary CountConflicts where+    arbitrary = CountConflicts <$> arbitrary++instance Arbitrary StrongFlags where+    arbitrary = StrongFlags <$> arbitrary+ instance Arbitrary AllowNewer where-    arbitrary = oneof [ pure AllowNewerNone-                      , AllowNewerSome <$> shortListOf1 3 arbitrary-                      , pure AllowNewerAll+    arbitrary = AllowNewer <$> arbitrary++instance Arbitrary AllowOlder where+    arbitrary = AllowOlder <$> arbitrary++instance Arbitrary RelaxDeps where+    arbitrary = oneof [ pure RelaxDepsNone+                      , RelaxDepsSome <$> shortListOf1 3 arbitrary+                      , pure RelaxDepsAll                       ] -instance Arbitrary AllowNewerDep where-    arbitrary = oneof [ AllowNewerDep       <$> arbitrary-                      , AllowNewerDepScoped <$> arbitrary <*> arbitrary+instance Arbitrary RelaxedDep where+    arbitrary = oneof [ RelaxedDep       <$> arbitrary+                      , RelaxedDepScoped <$> arbitrary <*> arbitrary                       ]  instance Arbitrary ProfDetailLevel where
cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs view
@@ -5,7 +5,7 @@ import Distribution.Simple.Utils (withTempDirectory) import Distribution.Verbosity -import Distribution.Client.Compat.Time+import Distribution.Compat.Time import Distribution.Client.Sandbox.Timestamp  import Test.Tasty
cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs view
@@ -4,7 +4,7 @@  import Distribution.Client.Targets     (UserConstraint (..), readUserConstraint) import Distribution.Compat.ReadP       (ReadP, readP_to_S)-import Distribution.Package            (PackageName (..))+import Distribution.Package            (mkPackageName) import Distribution.ParseUtils         (parseCommaList) import Distribution.Text               (parse) @@ -26,7 +26,7 @@     pkgName  = "template-haskell"     constr   = pkgName ++ " installed" -    expected = UserConstraintInstalled (PackageName pkgName)+    expected = UserConstraintInstalled (mkPackageName pkgName)     actual   = let (Right r) = readUserConstraint constr in r  parseUserConstraintTest :: Assertion@@ -36,7 +36,7 @@     pkgName  = "template-haskell"     constr   = pkgName ++ " installed" -    expected = [UserConstraintInstalled (PackageName pkgName)]+    expected = [UserConstraintInstalled (mkPackageName pkgName)]     actual   = [ x | (x, ys) <- readP_to_S parseUserConstraint constr                    , all isSpace ys] @@ -50,7 +50,7 @@     pkgName  = "template-haskell"     constr   = pkgName ++ " installed" -    expected = [[UserConstraintInstalled (PackageName pkgName)]]+    expected = [[UserConstraintInstalled (mkPackageName pkgName)]]     actual   = [ x | (x, ys) <- readP_to_S parseUserConstraints constr                    , all isSpace ys]
cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs view
@@ -48,7 +48,7 @@     appendFile configFile "verbose: 0\n"     diff <- userConfigDiff $ globalFlags configFile     assertBool (unlines $ "Should detect a difference:" : diff) $-        diff == [ "- verbose: 1", "+ verbose: 0" ]+        diff == [ "+ verbose: 0" ]   canUpdateConfig :: Assertion@@ -85,7 +85,7 @@     sysTmpDir <- getTemporaryDirectory     withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do         let configFile  = tmpDir </> "tmp.config"-        createDefaultConfigFile silent configFile+        _ <- createDefaultConfigFile silent configFile         exists <- doesFileExist configFile         assertBool ("Config file should be written to " ++ configFile) exists
+ cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs view
@@ -0,0 +1,608 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | DSL for testing the modular solver+module UnitTests.Distribution.Solver.Modular.DSL (+    ExampleDependency(..)+  , Dependencies(..)+  , ExTest(..)+  , ExExe(..)+  , ExPreference(..)+  , ExampleDb+  , ExampleVersionRange+  , ExamplePkgVersion+  , ExamplePkgName+  , ExampleAvailable(..)+  , ExampleInstalled(..)+  , ExampleQualifier(..)+  , ExampleVar(..)+  , EnableAllTests(..)+  , exAv+  , exInst+  , exFlag+  , exResolve+  , extractInstallPlan+  , withSetupDeps+  , withTest+  , withTests+  , withExe+  , withExes+  , runProgress+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++-- base+import Data.Either (partitionEithers)+import Data.List (elemIndex)+import Data.Ord (comparing)+import qualified Data.Map as Map++-- Cabal+import qualified Distribution.Compiler                 as C+import qualified Distribution.InstalledPackageInfo     as IPI+import           Distribution.License (License(..))+import qualified Distribution.ModuleName               as Module+import qualified Distribution.Package                  as C+  hiding (HasUnitId(..))+import qualified Distribution.PackageDescription       as C+import qualified Distribution.PackageDescription.Check as C+import qualified Distribution.Simple.PackageIndex      as C.PackageIndex+import           Distribution.Simple.Setup (BooleanFlag(..))+import qualified Distribution.System                   as C+import           Distribution.Text (display)+import qualified Distribution.Version                  as C+import Language.Haskell.Extension (Extension(..), Language(..))++-- cabal-install+import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types+import Distribution.Client.Types+import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan++import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import qualified Distribution.Solver.Types.PackageIndex      as CI.PackageIndex+import qualified Distribution.Solver.Types.PackagePath as P+import qualified Distribution.Solver.Types.PkgConfigDb as PC+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.SourcePackage+import           Distribution.Solver.Types.Variable++{-------------------------------------------------------------------------------+  Example package database DSL++  In order to be able to set simple examples up quickly, we define a very+  simple version of the package database here explicitly designed for use in+  tests.++  The design of `ExampleDb` takes the perspective of the solver, not the+  perspective of the package DB. This makes it easier to set up tests for+  various parts of the solver, but makes the mapping somewhat awkward,  because+  it means we first map from "solver perspective" `ExampleDb` to the package+  database format, and then the modular solver internally in `IndexConversion`+  maps this back to the solver specific data structures.++  IMPLEMENTATION NOTES+  --------------------++  TODO: Perhaps these should be made comments of the corresponding data type+  definitions. For now these are just my own conclusions and may be wrong.++  * The difference between `GenericPackageDescription` and `PackageDescription`+    is that `PackageDescription` describes a particular _configuration_ of a+    package (for instance, see documentation for `checkPackage`). A+    `GenericPackageDescription` can be turned into a `PackageDescription` in+    two ways:++      a. `finalizePD` does the proper translation, by taking+         into account the platform, available dependencies, etc. and picks a+         flag assignment (or gives an error if no flag assignment can be found)+      b. `flattenPackageDescription` ignores flag assignment and just joins all+         components together.++    The slightly odd thing is that a `GenericPackageDescription` contains a+    `PackageDescription` as a field; both of the above functions do the same+    thing: they take the embedded `PackageDescription` as a basis for the result+    value, but override `library`, `executables`, `testSuites`, `benchmarks`+    and `buildDepends`.+  * The `condTreeComponents` fields of a `CondTree` is a list of triples+    `(condition, then-branch, else-branch)`, where the `else-branch` is+    optional.+-------------------------------------------------------------------------------}++type ExamplePkgName    = String+type ExamplePkgVersion = Int+type ExamplePkgHash    = String  -- for example "installed" packages+type ExampleFlagName   = String+type ExampleTestName   = String+type ExampleExeName    = String+type ExampleVersionRange = C.VersionRange++data Dependencies = NotBuildable | Buildable [ExampleDependency]+  deriving Show++data ExampleDependency =+    -- | Simple dependency on any version+    ExAny ExamplePkgName++    -- | Simple dependency on a fixed version+  | ExFix ExamplePkgName ExamplePkgVersion++    -- | Build-tools dependency+  | ExBuildToolAny ExamplePkgName++    -- | Build-tools dependency on a fixed version+  | ExBuildToolFix ExamplePkgName ExamplePkgVersion++    -- | Dependencies indexed by a flag+  | ExFlag ExampleFlagName Dependencies Dependencies++    -- | Dependency on a language extension+  | ExExt Extension++    -- | Dependency on a language version+  | ExLang Language++    -- | Dependency on a pkg-config package+  | ExPkg (ExamplePkgName, ExamplePkgVersion)+  deriving Show++data ExTest = ExTest ExampleTestName [ExampleDependency]++data ExExe = ExExe ExampleExeName [ExampleDependency]++exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]+       -> ExampleDependency+exFlag n t e = ExFlag n (Buildable t) (Buildable e)++data ExPreference =+    ExPkgPref ExamplePkgName ExampleVersionRange+  | ExStanzaPref ExamplePkgName [OptionalStanza]++data ExampleAvailable = ExAv {+    exAvName    :: ExamplePkgName+  , exAvVersion :: ExamplePkgVersion+  , exAvDeps    :: ComponentDeps [ExampleDependency]+  } deriving Show++data ExampleVar =+    P ExampleQualifier ExamplePkgName+  | F ExampleQualifier ExamplePkgName ExampleFlagName+  | S ExampleQualifier ExamplePkgName OptionalStanza++data ExampleQualifier =+    None+  | Indep Int+  | Setup ExamplePkgName+  | IndepSetup Int ExamplePkgName++-- | Whether to enable tests in all packages in a test case.+newtype EnableAllTests = EnableAllTests Bool+  deriving BooleanFlag++-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',+-- given:+--+--      1. The name 'ExamplePkgName' of the available package,+--      2. The version 'ExamplePkgVersion' available+--      3. The list of dependency constraints 'ExampleDependency'+--         that this package has.  'ExampleDependency' provides+--         a number of pre-canned dependency types to look at.+--+exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]+     -> ExampleAvailable+exAv n v ds = ExAv { exAvName = n, exAvVersion = v+                   , exAvDeps = CD.fromLibraryDeps ds }++withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable+withSetupDeps ex setupDeps = ex {+      exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps+    }++withTest :: ExampleAvailable -> ExTest -> ExampleAvailable+withTest ex test = withTests ex [test]++withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable+withTests ex tests =+  let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps)+                            | ExTest name deps <- tests]+  in ex { exAvDeps = exAvDeps ex <> testCDs }++withExe :: ExampleAvailable -> ExExe -> ExampleAvailable+withExe ex exe = withExes ex [exe]++withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable+withExes ex exes =+  let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps)+                           | ExExe name deps <- exes]+  in ex { exAvDeps = exAvDeps ex <> exeCDs }++-- | An installed package in 'ExampleDb'; construct me with 'exInst'.+data ExampleInstalled = ExInst {+    exInstName         :: ExamplePkgName+  , exInstVersion      :: ExamplePkgVersion+  , exInstHash         :: ExamplePkgHash+  , exInstBuildAgainst :: [ExamplePkgHash]+  } deriving Show++-- | Constructs an example installed package given:+--+--      1. The name of the package 'ExamplePkgName', i.e., 'String'+--      2. The version of the package 'ExamplePkgVersion', i.e., 'Int'+--      3. The IPID for the package 'ExamplePkgHash', i.e., 'String'+--         (just some unique identifier for the package.)+--      4. The 'ExampleInstalled' packages which this package was+--         compiled against.)+--+exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash+       -> [ExampleInstalled] -> ExampleInstalled+exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)++-- | An example package database is a list of installed packages+-- 'ExampleInstalled' and available packages 'ExampleAvailable'.+-- Generally, you want to use 'exInst' and 'exAv' to construct+-- these packages.+type ExampleDb = [Either ExampleInstalled ExampleAvailable]++type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a++type DependencyComponent a = ( C.Condition C.ConfVar+                             , DependencyTree a+                             , Maybe (DependencyTree a))++exDbPkgs :: ExampleDb -> [ExamplePkgName]+exDbPkgs = map (either exInstName exAvName)++exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage+exAvSrcPkg ex =+    let pkgId = exAvPkgId ex+        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]+        executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]+        setup = case CD.setupDeps (exAvDeps ex) of+                  []   -> Nothing+                  deps -> Just C.SetupBuildInfo {+                            C.setupDepends = mkSetupDeps deps,+                            C.defaultSetupDepends = False+                          }+        package = SourcePackage {+            packageInfoId        = pkgId+          , packageSource        = LocalTarballPackage "<<path>>"+          , packageDescrOverride = Nothing+          , packageDescription   = C.GenericPackageDescription {+                C.packageDescription = C.emptyPackageDescription {+                    C.package        = pkgId+                  , C.setupBuildInfo = setup+                  , C.license = BSD3+                  , C.buildType = if isNothing setup+                                  then Just C.Simple+                                  else Just C.Custom+                  , C.category = "category"+                  , C.maintainer = "maintainer"+                  , C.description = "description"+                  , C.synopsis = "synopsis"+                  , C.licenseFiles = ["LICENSE"]+                  , C.specVersionRaw = Left $ C.mkVersion [1,12]+                  }+              , C.genPackageFlags = nub $ concatMap extractFlags $+                                    CD.libraryDeps (exAvDeps ex)+                                     ++ concatMap snd testSuites+                                     ++ concatMap snd executables+              , C.condLibrary =+                  let mkLib bi = mempty { C.libBuildInfo = bi }+                  in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $+                     Buildable (CD.libraryDeps (exAvDeps ex))+              , C.condSubLibraries = []+              , C.condForeignLibs = []+              , C.condExecutables =+                  let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable+                      mkExe bi = mempty { C.buildInfo = bi }+                  in map (\(t, deps) -> (t, mkTree deps)) executables+              , C.condTestSuites =+                  let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable+                      mkTest bi = mempty { C.testBuildInfo = bi }+                  in map (\(t, deps) -> (t, mkTree deps)) testSuites+              , C.condBenchmarks  = []+              }+            }+        pkgCheckErrors =+          -- We ignore these warnings because some unit tests test that the+          -- solver allows unknown extensions/languages when the compiler+          -- supports them.+          let ignore = ["Unknown extensions:", "Unknown languages:"]+          in [ err | err <- C.checkPackage (packageDescription package) Nothing+             , not $ any (`isPrefixOf` C.explanation err) ignore ]+    in if null pkgCheckErrors+       then package+       else error $ "invalid GenericPackageDescription for package "+                 ++ display pkgId ++ ": " ++ show pkgCheckErrors+  where+    defaultTopLevelBuildInfo :: C.BuildInfo+    defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 }++    defaultLib :: C.Library+    defaultLib = mempty { C.exposedModules = [Module.fromString "Module"] }++    defaultExe :: C.Executable+    defaultExe = mempty { C.modulePath = "Main.hs" }++    defaultTest :: C.TestSuite+    defaultTest = mempty {+        C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"+      }++    -- Split the set of dependencies into the set of dependencies of the library,+    -- the dependencies of the test suites and extensions.+    splitTopLevel :: [ExampleDependency]+                  -> ( [ExampleDependency]+                     , [Extension]+                     , Maybe Language+                     , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config+                     , [(ExamplePkgName, Maybe Int)] -- build tools+                     )+    splitTopLevel [] =+        ([], [], Nothing, [], [])+    splitTopLevel (ExBuildToolAny p:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, Nothing):exes)+    splitTopLevel (ExBuildToolFix p v:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, Just v):exes)+    splitTopLevel (ExExt ext:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, ext:exts, lang, pcpkgs, exes)+    splitTopLevel (ExLang lang:deps) =+        case splitTopLevel deps of+            (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes)+            _ -> error "Only 1 Language dependency is supported"+    splitTopLevel (ExPkg pkg:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, exts, lang, pkg:pcpkgs, exes)+    splitTopLevel (dep:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (dep:other, exts, lang, pcpkgs, exes)++    -- Extract the total set of flags used+    extractFlags :: ExampleDependency -> [C.Flag]+    extractFlags (ExAny _)      = []+    extractFlags (ExFix _ _)    = []+    extractFlags (ExBuildToolAny _)   = []+    extractFlags (ExBuildToolFix _ _) = []+    extractFlags (ExFlag f a b) = C.MkFlag {+                                      C.flagName        = C.mkFlagName f+                                    , C.flagDescription = ""+                                    , C.flagDefault     = True+                                    , C.flagManual      = False+                                    }+                                : concatMap extractFlags (deps a ++ deps b)+      where+        deps :: Dependencies -> [ExampleDependency]+        deps NotBuildable = []+        deps (Buildable ds) = ds+    extractFlags (ExExt _)      = []+    extractFlags (ExLang _)     = []+    extractFlags (ExPkg _)      = []++    -- Convert a tree of BuildInfos into a tree of a specific component type.+    -- 'defaultTopLevel' contains the default values for the component, and+    -- 'mkComponent' creates a component from a 'BuildInfo'.+    mkCondTree :: forall a. Semigroup a =>+                  a -> (C.BuildInfo -> a)+               -> DependencyTree C.BuildInfo+               -> DependencyTree a+    mkCondTree defaultTopLevel mkComponent (C.CondNode topData topConstraints topComps) =+        C.CondNode {+            C.condTreeData =+                defaultTopLevel <> mkComponent (defaultTopLevelBuildInfo <> topData)+          , C.condTreeConstraints = topConstraints+          , C.condTreeComponents = goComponents topComps+          }+      where+        go :: DependencyTree C.BuildInfo -> DependencyTree a+        go (C.CondNode ctData constraints comps) =+            C.CondNode (mkComponent ctData) constraints (goComponents comps)++        goComponents :: [DependencyComponent C.BuildInfo]+                     -> [DependencyComponent a]+        goComponents comps = [(cond, go t, go <$> me) | (cond, t, me) <- comps]++    mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo+    mkBuildInfoTree NotBuildable =+      C.CondNode {+             C.condTreeData        = mempty { C.buildable = False }+           , C.condTreeConstraints = []+           , C.condTreeComponents  = []+           }+    mkBuildInfoTree (Buildable deps) =+      let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps+          (directDeps, flaggedDeps) = splitDeps libraryDeps+          bi = mempty {+                  C.otherExtensions = exts+                , C.defaultLanguage = mlang+                , C.buildTools = [ C.LegacyExeDependency n $ mkVersion v+                                 | (n,v) <- buildTools ]+                , C.pkgconfigDepends = [ C.PkgconfigDependency n' v'+                                       | (n,v) <- pcpkgs+                                       , let n' = C.mkPkgconfigName n+                                       , let v' = mkVersion $ Just v ]+              }+      in C.CondNode {+             C.condTreeData        = bi -- Necessary for language extensions+           -- TODO: Arguably, build-tools dependencies should also+           -- effect constraints on conditional tree. But no way to+           -- distinguish between them+           , C.condTreeConstraints = map mkDirect directDeps+           , C.condTreeComponents  = map mkFlagged flaggedDeps+           }++    mkVersion :: Maybe ExamplePkgVersion -> C.VersionRange+    mkVersion Nothing  = C.anyVersion+    mkVersion (Just n) = C.thisVersion v+      where+        v = C.mkVersion [n, 0, 0]++    mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency+    mkDirect (dep, v) = C.Dependency (C.mkPackageName dep) $ mkVersion $v++    mkFlagged :: (ExampleFlagName, Dependencies, Dependencies)+              -> ( C.Condition C.ConfVar+                 , DependencyTree C.BuildInfo+                 , Maybe (DependencyTree C.BuildInfo))+    mkFlagged (f, a, b) = ( C.Var (C.Flag (C.mkFlagName f))+                                    , mkBuildInfoTree a+                                    , Just (mkBuildInfoTree b)+                                    )++    -- Split a set of dependencies into direct dependencies and flagged+    -- dependencies. A direct dependency is a tuple of the name of package and+    -- maybe its version (no version means any version) meant to be converted+    -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is+    -- the set of dependencies guarded by a flag.+    splitDeps :: [ExampleDependency]+              -> ( [(ExamplePkgName, Maybe Int)]+                 , [(ExampleFlagName, Dependencies, Dependencies)]+                 )+    splitDeps [] =+      ([], [])+    splitDeps (ExAny p:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, Nothing):directDeps, flaggedDeps)+    splitDeps (ExFix p v:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, Just v):directDeps, flaggedDeps)+    splitDeps (ExFlag f a b:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in (directDeps, (f, a, b):flaggedDeps)+    splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep++    -- custom-setup only supports simple dependencies+    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]+    mkSetupDeps deps =+      let (directDeps, []) = splitDeps deps in map mkDirect directDeps++exAvPkgId :: ExampleAvailable -> C.PackageIdentifier+exAvPkgId ex = C.PackageIdentifier {+      pkgName    = C.mkPackageName (exAvName ex)+    , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]+    }++exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo+exInstInfo ex = IPI.emptyInstalledPackageInfo {+      IPI.installedUnitId    = C.mkUnitId (exInstHash ex)+    , IPI.sourcePackageId    = exInstPkgId ex+    , IPI.depends            = map C.mkUnitId (exInstBuildAgainst ex)+    }++exInstPkgId :: ExampleInstalled -> C.PackageIdentifier+exInstPkgId ex = C.PackageIdentifier {+      pkgName    = C.mkPackageName (exInstName ex)+    , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0]+    }++exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage+exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg++exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex+exInstIdx = C.PackageIndex.fromList . map exInstInfo++exResolve :: ExampleDb+          -- List of extensions supported by the compiler, or Nothing if unknown.+          -> Maybe [Extension]+          -- List of languages supported by the compiler, or Nothing if unknown.+          -> Maybe [Language]+          -> PC.PkgConfigDb+          -> [ExamplePkgName]+          -> Solver+          -> Maybe Int+          -> IndependentGoals+          -> ReorderGoals+          -> EnableBackjumping+          -> Maybe [ExampleVar]+          -> [ExPreference]+          -> EnableAllTests+          -> Progress String String CI.SolverInstallPlan.SolverInstallPlan+exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder+          enableBj vars prefs enableAllTests+    = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params+  where+    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag+    compiler = defaultCompiler { C.compilerInfoExtensions = exts+                               , C.compilerInfoLanguages  = langs+                               }+    (inst, avai) = partitionEithers db+    instIdx      = exInstIdx inst+    avaiIdx      = SourcePackageDb {+                       packageIndex       = exAvIdx avai+                     , packagePreferences = Map.empty+                     }+    enableTests+        | asBool enableAllTests = fmap (\p -> PackageConstraintStanzas+                                              (C.mkPackageName p) [TestStanzas])+                                       (exDbPkgs db)+        | otherwise             = []+    targets'     = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets+    params       =   addPreferences (fmap toPref prefs)+                   $ addConstraints (fmap toLpc enableTests)+                   $ setIndependentGoals indepGoals+                   $ setReorderGoals reorder+                   $ setMaxBackjumps mbj+                   $ setEnableBackjumping enableBj+                   $ setGoalOrder goalOrder+                   $ standardInstallPolicy instIdx avaiIdx targets'+    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown++    toPref (ExPkgPref n v)          = PackageVersionPreference (C.mkPackageName n) v+    toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas++    goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)+    goalOrder = (orderFromList . map toVariable) `fmap` vars++    -- Sort elements in the list ahead of elements not in the list. Otherwise,+    -- follow the order in the list.+    orderFromList :: Eq a => [a] -> a -> a -> Ordering+    orderFromList xs =+        comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)++    toVariable :: ExampleVar -> Variable P.QPN+    toVariable (P q pn)        = PackageVar (toQPN q pn)+    toVariable (F q pn fn)     = FlagVar    (toQPN q pn) (C.mkFlagName fn)+    toVariable (S q pn stanza) = StanzaVar  (toQPN q pn) stanza++    toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN+    toQPN q pn = P.Q pp (C.mkPackageName pn)+      where+        pp = case q of+               None           -> P.PackagePath P.DefaultNamespace P.Unqualified+               Indep x        -> P.PackagePath (P.Independent x) P.Unqualified+               Setup p        -> P.PackagePath P.DefaultNamespace (P.Setup (C.mkPackageName p))+               IndepSetup x p -> P.PackagePath (P.Independent x) (P.Setup (C.mkPackageName p))++extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan+                   -> [(ExamplePkgName, ExamplePkgVersion)]+extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList+  where+    confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int)+    confPkg (CI.SolverInstallPlan.Configured pkg) = Just $ srcPkg pkg+    confPkg _                               = Nothing++    srcPkg :: SolverPackage UnresolvedPkgLoc -> (String, Int)+    srcPkg cpkg =+      let C.PackageIdentifier pn ver = packageInfoId (solverPkgSource cpkg)+      in (C.unPackageName pn, head (C.versionNumbers ver))++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Run Progress computation+runProgress :: Progress step e a -> ([step], Either e a)+runProgress = go+  where+    go (Step s p) = let (ss, result) = go p in (s:ss, result)+    go (Fail e)   = ([], Left e)+    go (Done a)   = ([], Right a)
+ cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs view
@@ -0,0 +1,22 @@+module UnitTests.Distribution.Solver.Modular.PSQ (+  tests+  ) where++import Distribution.Solver.Modular.PSQ++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests = [ testProperty "splitsAltImplementation" splitsTest+        ]++-- | Original splits implementation+splits' :: PSQ k a -> PSQ k (a, PSQ k a)+splits' xs =+  casePSQ xs+    (PSQ [])+    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys)))++splitsTest :: [(Int, Int)] -> Bool+splitsTest psq = splits' (PSQ psq) == splits (PSQ psq)
+ cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where++import Control.DeepSeq (NFData, force)+import Control.Monad (foldM)+import Data.Either (lefts)+import Data.Function (on)+import Data.List (groupBy, isInfixOf, nub, nubBy, sort)+import Data.Maybe (isJust)+import GHC.Generics (Generic)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+import Data.Monoid (Monoid)+#endif++import Text.Show.Pretty (parseValue, valToStr)++import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck++import Distribution.Client.Dependency.Types+         ( Solver(..) )+import Distribution.Client.Setup (defaultMaxBackjumps)++import           Distribution.Package (UnqualComponentName, mkUnqualComponentName)++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ComponentDeps+                   ( Component(..), ComponentDep, ComponentDeps )+import           Distribution.Solver.Types.PkgConfigDb+                   (pkgConfigDbFromList)+import           Distribution.Solver.Types.Settings++import UnitTests.Distribution.Solver.Modular.DSL++tests :: [TestTree]+tests = [+      -- This test checks that certain solver parameters do not affect the+      -- existence of a solution. It runs the solver twice, and only sets those+      -- parameters on the second run. The test also applies parameters that+      -- can affect the existence of a solution to both runs.+      testProperty "target order and --reorder-goals do not affect solvability" $+          \(SolverTest db targets) targetOrder reorderGoals indepGoals solver ->+            let r1 = solve' (ReorderGoals False) targets  db+                r2 = solve' reorderGoals         targets2 db+                solve' reorder = solve (EnableBackjumping True) reorder+                                       indepGoals solver+                targets2 = case targetOrder of+                             SameOrder -> targets+                             ReverseOrder -> reverse targets+            in counterexample (showResults r1 r2) $+               noneReachedBackjumpLimit [r1, r2] ==>+               isRight (resultPlan r1) === isRight (resultPlan r2)++    , testProperty+          "solvable without --independent-goals => solvable with --independent-goals" $+          \(SolverTest db targets) reorderGoals solver ->+            let r1 = solve' (IndependentGoals False) targets db+                r2 = solve' (IndependentGoals True)  targets db+                solve' indep = solve (EnableBackjumping True)+                                     reorderGoals indep solver+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                isRight (resultPlan r1) `implies` isRight (resultPlan r2)++    , testProperty "backjumping does not affect solvability" $+          \(SolverTest db targets) reorderGoals indepGoals ->+            let r1 = solve' (EnableBackjumping True)  targets db+                r2 = solve' (EnableBackjumping False) targets db+                solve' enableBj = solve enableBj reorderGoals indepGoals Modular+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                isRight (resultPlan r1) === isRight (resultPlan r2)+    ]+  where+    noneReachedBackjumpLimit :: [Result] -> Bool+    noneReachedBackjumpLimit =+        not . any (\r -> resultPlan r == Left BackjumpLimitReached)++    showResults :: Result -> Result -> String+    showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2++    showResult :: Int -> Result -> String+    showResult n result =+        unlines $ ["", "Run " ++ show n ++ ":"]+               ++ resultLog result+               ++ ["result: " ++ show (resultPlan result)]++    implies :: Bool -> Bool -> Bool+    implies x y = not x || y++    isRight :: Either a b -> Bool+    isRight (Right _) = True+    isRight _         = False++solve :: EnableBackjumping -> ReorderGoals -> IndependentGoals+      -> Solver -> [PN] -> TestDb -> Result+solve enableBj reorder indep solver targets (TestDb db) =+  let (lg, result) =+        runProgress $ exResolve db Nothing Nothing+                  (pkgConfigDbFromList [])+                  (map unPN targets)+                  solver+                  -- The backjump limit prevents individual tests from using+                  -- too much time and memory.+                  (Just defaultMaxBackjumps)+                  indep reorder enableBj Nothing [] (EnableAllTests True)++      failure :: String -> Failure+      failure msg+        | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached+        | otherwise                                = OtherFailure+  in Result {+       resultLog = lg+     , resultPlan =+         -- Force the result so that we check for internal errors when we check+         -- for success or failure. See D.C.Dependency.validateSolverResult.+         force $ either (Left . failure) (Right . extractInstallPlan) result+     }++-- | How to modify the order of the input targets.+data TargetOrder = SameOrder | ReverseOrder+  deriving Show++instance Arbitrary TargetOrder where+  arbitrary = elements [SameOrder, ReverseOrder]++  shrink SameOrder = []+  shrink ReverseOrder = [SameOrder]++data Result = Result {+    resultLog :: [String]+  , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)]+  }++data Failure = BackjumpLimitReached | OtherFailure+  deriving (Eq, Generic, Show)++instance NFData Failure++-- | Package name.+newtype PN = PN { unPN :: String }+  deriving (Eq, Ord, Show)++instance Arbitrary PN where+  arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']])++-- | Package version.+newtype PV = PV { unPV :: Int }+  deriving (Eq, Ord, Show)++instance Arbitrary PV where+  arbitrary = PV <$> elements [1..10]++type TestPackage = Either ExampleInstalled ExampleAvailable++getName :: TestPackage -> PN+getName = PN . either exInstName exAvName++getVersion :: TestPackage -> PV+getVersion = PV . either exInstVersion exAvVersion++data SolverTest = SolverTest {+    testDb :: TestDb+  , testTargets :: [PN]+  }++-- | Pretty-print the test when quickcheck calls 'show'.+instance Show SolverTest where+  show test =+    let str = "SolverTest {testDb = " ++ show (testDb test)+                     ++ ", testTargets = " ++ show (testTargets test) ++ "}"+    in maybe str valToStr $ parseValue str++instance Arbitrary SolverTest where+  arbitrary = do+    db <- arbitrary+    let pkgs = nub $ map getName (unTestDb db)+    Positive n <- arbitrary+    targets <- randomSubset n pkgs+    return (SolverTest db targets)++  shrink test =+         [test { testDb = db } | db <- shrink (testDb test)]+      ++ [test { testTargets = targets } | targets <- shrink (testTargets test)]++-- | Collection of source and installed packages.+newtype TestDb = TestDb { unTestDb :: ExampleDb }+  deriving Show++instance Arbitrary TestDb where+  arbitrary = do+      -- Avoid cyclic dependencies by grouping packages by name and only+      -- allowing each package to depend on packages in the groups before it.+      groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<<+                     boundedListOf 10 arbitrary+      db <- foldM nextPkgs (TestDb []) groupedPkgs+      TestDb <$> shuffle (unTestDb db)+    where+      nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb+      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs++      nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage+      nextPkg db (pn, v) = do+        installed <- arbitrary+        if installed+        then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)+        else Right <$> arbitraryExAv pn v db++  shrink (TestDb pkgs) = map TestDb $ shrink pkgs++arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable+arbitraryExAv pn v db =+    ExAv (unPN pn) (unPV v) <$> arbitraryComponentDeps db++arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled+arbitraryExInst pn v pkgs = do+  hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']+  numDeps <- min 3 <$> arbitrary+  deps <- randomSubset numDeps pkgs+  return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps)++arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency])+arbitraryComponentDeps (TestDb []) = return $ CD.fromList []+arbitraryComponentDeps db =+    -- dedupComponentNames removes components with duplicate names, for example,+    -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines+    -- duplicate unnamed components.+    CD.fromList . dedupComponentNames <$>+    boundedListOf 5 (arbitraryComponentDep db)+  where+    dedupComponentNames =+        nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst)++    componentName :: Component -> Maybe UnqualComponentName+    componentName ComponentLib        = Nothing+    componentName ComponentSetup      = Nothing+    componentName (ComponentSubLib n) = Just n+    componentName (ComponentFLib   n) = Just n+    componentName (ComponentExe    n) = Just n+    componentName (ComponentTest   n) = Just n+    componentName (ComponentBench  n) = Just n++arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])+arbitraryComponentDep db = do+  comp <- arbitrary+  deps <- case comp of+            ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)+            _              -> boundedListOf 5 (arbitraryExDep db NonSetupDep)+  return (comp, deps)++-- | Location of an 'ExampleDependency'. It determines which values are valid.+data ExDepLocation = SetupDep | NonSetupDep++arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency+arbitraryExDep db@(TestDb pkgs) level =+  let flag = ExFlag <$> arbitraryFlagName+                    <*> arbitraryDeps db+                    <*> arbitraryDeps db+      other =+          -- Package checks require dependencies on "base" to have bounds.+        let notBase = filter ((/= PN "base") . getName) pkgs+        in  [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]+         ++ [+              -- existing version+              let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)+              in fixed <$> elements pkgs++              -- random version of an existing package+            , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)+            ]+  in oneof $+      case level of+        NonSetupDep -> flag : other+        SetupDep -> other++arbitraryDeps :: TestDb -> Gen Dependencies+arbitraryDeps db = frequency+    [ (1, return NotBuildable)+    , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetupDep))+    ]++arbitraryFlagName :: Gen String+arbitraryFlagName = (:[]) <$> elements ['A'..'E']++instance Arbitrary ReorderGoals where+  arbitrary = ReorderGoals <$> arbitrary++  shrink (ReorderGoals reorder) = [ReorderGoals False | reorder]++instance Arbitrary IndependentGoals where+  arbitrary = IndependentGoals <$> arbitrary++  shrink (IndependentGoals indep) = [IndependentGoals False | indep]++instance Arbitrary Solver where+  arbitrary = return Modular++  shrink Modular = []++instance Arbitrary UnqualComponentName where+  arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC"++instance Arbitrary Component where+  arbitrary = oneof [ return ComponentLib+                    , ComponentSubLib <$> arbitrary+                    , ComponentExe <$> arbitrary+                    , ComponentTest <$> arbitrary+                    , ComponentBench <$> arbitrary+                    , return ComponentSetup+                    ]++  shrink ComponentLib = []+  shrink _ = [ComponentLib]++instance Arbitrary ExampleInstalled where+  arbitrary = error "arbitrary not implemented: ExampleInstalled"++  shrink ei = [ ei { exInstBuildAgainst = deps }+              | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)]++instance Arbitrary ExampleAvailable where+  arbitrary = error "arbitrary not implemented: ExampleAvailable"++  shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)]++instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where+  arbitrary = error "arbitrary not implemented: ComponentDeps"++  shrink = map CD.fromList . shrink . CD.toList++instance Arbitrary ExampleDependency where+  arbitrary = error "arbitrary not implemented: ExampleDependency"++  shrink (ExAny _) = []+  shrink (ExFix "base" _) = [] -- preserve bounds on base+  shrink (ExFix pn _) = [ExAny pn]+  shrink (ExFlag flag th el) =+         deps th ++ deps el+      ++ [ExFlag flag th' el | th' <- shrink th]+      ++ [ExFlag flag th el' | el' <- shrink el]+    where+      deps NotBuildable = []+      deps (Buildable ds) = ds+  shrink dep = error $ "Dependency not handled: " ++ show dep++instance Arbitrary Dependencies where+  arbitrary = error "arbitrary not implemented: Dependencies"++  shrink NotBuildable = [Buildable []]+  shrink (Buildable deps) = map Buildable (shrink deps)++randomSubset :: Int -> [a] -> Gen [a]+randomSubset n xs = take n <$> shuffle xs++boundedListOf :: Int -> Gen a -> Gen [a]+boundedListOf n gen = take n <$> listOf gen++-- | Generates lists with average length less than 1.+smallListOf :: Gen a -> Gen [a]+smallListOf gen =+    frequency [ (fr, vectorOf n gen)+              | (fr, n) <- [(3, 0), (5, 1), (2, 2)]]
+ cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module UnitTests.Distribution.Solver.Modular.RetryLog (+  tests+  ) where++import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.RetryLog+import Distribution.Solver.Types.Progress++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck+         ( Arbitrary(..), Blind(..), listOf, oneof, testProperty, (===))++type Log a = Progress a String String++tests :: [TestTree]+tests = [+    testProperty "'toProgress . fromProgress' is identity" $ \p ->+        toProgress (fromProgress p) === (p :: Log Int)++  , testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $+        let mapFailureProgress f = foldProgress Step (Fail . f) Done+        in \(Blind f) p ->+               toProgress (mapFailure f (fromProgress p))+               === mapFailureProgress (f :: String -> Int) (p :: Log Int)++  , testProperty "'retry p f' is like 'foldProgress Step f Done p'" $+      \p (Blind f) ->+        toProgress (retry (fromProgress p) (fromProgress . f))+        === (foldProgress Step f Done (p :: Log Int) :: Log Int)++  , testProperty "failWith" $ \step failure ->+        toProgress (failWith step failure)+        === (Step step (Fail failure) :: Log Int)++  , testProperty "succeedWith" $ \step success ->+        toProgress (succeedWith step success)+        === (Step step (Done success) :: Log Int)++  , testProperty "continueWith" $ \step p ->+        toProgress (continueWith step (fromProgress p))+        === (Step step p :: Log Int)++  , testCase "tryWith with failure" $+        let failure = Fail "Error"+            s = Step Success+        in toProgress (tryWith Success $ fromProgress (s (s failure)))+           @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message)++  , testCase "tryWith with success" $+        let done = Done "Done"+            s = Step Success+        in toProgress (tryWith Success $ fromProgress (s (s done)))+           @?= (s (Step Enter (s (s done))) :: Log Message)+  ]++instance (Arbitrary step, Arbitrary fail, Arbitrary done)+    => Arbitrary (Progress step fail done) where+  arbitrary = do+    steps <- listOf arbitrary+    end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary]+    return $ foldr Step end steps++deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done)++deriving instance (Show step, Show fail, Show done)+    => Show (Progress step fail done)++deriving instance Eq Message+deriving instance Show Message
+ cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs view
@@ -0,0 +1,1192 @@+{-# LANGUAGE RecordWildCards #-}+-- | This is a set of unit tests for the dependency solver,+-- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL")+-- to more conveniently create package databases to run the solver tests on.+module UnitTests.Distribution.Solver.Modular.Solver (tests)+       where++-- base+import Data.List (isInfixOf)++import qualified Distribution.Version as V++-- test-framework+import Test.Tasty as TF+import Test.Tasty.HUnit (testCase, assertEqual, assertBool)++-- Cabal+import Language.Haskell.Extension ( Extension(..)+                                  , KnownExtension(..), Language(..))++-- cabal-install+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)+import Distribution.Solver.Types.Settings+import Distribution.Client.Dependency (foldProgress)+import Distribution.Client.Dependency.Types+         ( Solver(Modular) )+import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Options++tests :: [TF.TestTree]+tests = [+      testGroup "Simple dependencies" [+          runTest $         mkTest db1 "alreadyInstalled"   ["A"]      (solverSuccess [])+        , runTest $         mkTest db1 "installLatest"      ["B"]      (solverSuccess [("B", 2)])+        , runTest $         mkTest db1 "simpleDep1"         ["C"]      (solverSuccess [("B", 1), ("C", 1)])+        , runTest $         mkTest db1 "simpleDep2"         ["D"]      (solverSuccess [("B", 2), ("D", 1)])+        , runTest $         mkTest db1 "failTwoVersions"    ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db1 "indepTwoVersions"   ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)])+        , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)])+        , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $         mkTest db1 "buildDepAgainstOld" ["F"]      (solverSuccess [("B", 1), ("E", 1), ("F", 1)])+        , runTest $         mkTest db1 "buildDepAgainstNew" ["G"]      (solverSuccess [("B", 2), ("E", 1), ("G", 1)])+        , runTest $ indep $ mkTest db1 "multipleInstances"  ["F", "G"] anySolverFailure+        , runTest $         mkTest db21 "unknownPackage1"   ["A"]      (solverSuccess [("A", 1), ("B", 1)])+        , runTest $         mkTest db22 "unknownPackage2"   ["A"]      (solverFaiure (isInfixOf "unknown package: C"))+        , runTest $         mkTest db23 "unknownPackage3"   ["A"]      (solverFaiure (isInfixOf "unknown package: B"))+        ]+    , testGroup "Flagged dependencies" [+          runTest $         mkTest db3 "forceFlagOn"  ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $         mkTest db3 "forceFlagOff" ["D"]      (solverSuccess [("A", 2), ("B", 1), ("D", 1)])+        , runTest $ indep $ mkTest db3 "linkFlags1"   ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db4 "linkFlags2"   ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db18 "linkFlags3"  ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])+        ]+    , testGroup "Stanzas" [+          runTest $         enableAllTests $ mkTest db5 "simpleTest1" ["C"]      (solverSuccess [("A", 2), ("C", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest2" ["D"]      anySolverFailure+        , runTest $         enableAllTests $ mkTest db5 "simpleTest3" ["E"]      (solverSuccess [("A", 1), ("E", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest4" ["F"]      anySolverFailure -- TODO+        , runTest $         enableAllTests $ mkTest db5 "simpleTest5" ["G"]      (solverSuccess [("A", 2), ("G", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure+        , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])+        , runTest $         enableAllTests $ mkTest db6 "depsWithTests1" ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])+        ]+    , testGroup "Setup dependencies" [+          runTest $         mkTest db7  "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)])+        , runTest $         mkTest db7  "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)])+        , runTest $         mkTest db7  "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)])+        , runTest $         mkTest db7  "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)])+        , runTest $         mkTest db7  "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)])+        , runTest $         mkTest db8  "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $         mkTest db9  "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])+        , runTest $         mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)])+        , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])+        ]+    , testGroup "Base shim" [+          runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)])+        , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure+        , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)])+        ]+    , testGroup "Cycles" [+          runTest $ mkTest db14 "simpleCycle1"          ["A"]      anySolverFailure+        , runTest $ mkTest db14 "simpleCycle2"          ["A", "B"] anySolverFailure+        , runTest $ mkTest db14 "cycleWithFlagChoice1"  ["C"]      (solverSuccess [("C", 1), ("E", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"]      anySolverFailure+        , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"]      anySolverFailure+        , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (solverSuccess [("C", 2), ("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (solverSuccess [("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (solverSuccess [("C", 2), ("D", 1), ("E", 1)])+        ]+    , testGroup "Extensions" [+          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure+        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A",1)])+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A",1),("B",1), ("C",1)])+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure+        , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A",1),("B",1),("C",1),("E",1)])+        ]+    , testGroup "Languages" [+          runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure+        , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A",1)])+        , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure+        , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)])+        ]++     , testGroup "Package Preferences" [+          runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2+                                , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1+                                , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)])+        ]+     , testGroup "Stanza Preferences" [+          runTest $+          mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $+          solverSuccess [("pkg", 1)]++        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $+          mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $+          solverSuccess [("pkg", 1), ("test-dep", 1)]++        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $+          mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $+          solverSuccess [("pkg", 1)]+        ]+     , testGroup "Buildable Field" [+          testBuildable "avoid building component with unknown dependency" (ExAny "unknown")+        , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))+        , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))+        , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])+        , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)])+         ]+    , testGroup "Pkg-config dependencies" [+          runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] anySolverFailure+        , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] anySolverFailure+        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])+        ]+    , testGroup "Independent goals" [+          runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])+        , runTest $ testIndepGoals2 "indepGoals2"+        , runTest $ testIndepGoals3 "indepGoals3"+        , runTest $ testIndepGoals4 "indepGoals4"+        , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder+        , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder+        , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder+        , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder+        ]+      -- Tests designed for the backjumping blog post+    , testGroup "Backjumping" [+          runTest $         mkTest dbBJ1a "bj1a" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ1b "bj1b" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ1c "bj1c" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ2  "bj2"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $         mkTest dbBJ3  "bj3 " ["A"]      (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)])+        , runTest $         mkTest dbBJ4  "bj4"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $         mkTest dbBJ5  "bj5"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("D", 1)])+        , runTest $         mkTest dbBJ6  "bj6"  ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ7  "bj7"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $ indep $ mkTest dbBJ8  "bj8"  ["A", "B"] (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        ]+    -- Build-tools dependencies+    , testGroup "build-tools" [+          runTest $ mkTest dbBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)])+        , runTest $ mkTest dbBuildTools2 "bt2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest dbBuildTools3 "bt3" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)])+        , runTest $ mkTest dbBuildTools4 "bt4" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)])+        , runTest $ mkTest dbBuildTools5 "bt5" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)])+        , runTest $ mkTest dbBuildTools6 "bt6" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)])+        ]+      -- Tests for the contents of the solver's log+    , testGroup "Solver log" [+          -- See issue #3203. The solver should only choose a version for A once.+          runTest $+              let db = [Right $ exAv "A" 1 []]+                  p lg =    elem "targets: A" lg+                         && length (filter ("trying: A" `isInfixOf`) lg) == 1+              in mkTest db "deduplicate targets" ["A", "A"] $+                 SolverResult p $ Right [("A", 1)]+        ]+    ]+  where+    mkvrThis        = V.thisVersion . makeV+    mkvrOrEarlier   = V.orEarlierVersion . makeV+    makeV v         = V.mkVersion [v,0,0]++-- | Combinator to turn on --independent-goals behavior, i.e. solve+-- for the goals as if we were solving for each goal independently.+indep :: SolverTest -> SolverTest+indep test = test { testIndepGoals = IndependentGoals True }++goalOrder :: [ExampleVar] -> SolverTest -> SolverTest+goalOrder order test = test { testGoalOrder = Just order }++preferences :: [ExPreference] -> SolverTest -> SolverTest+preferences prefs test = test { testSoftConstraints = prefs }++enableAllTests :: SolverTest -> SolverTest+enableAllTests test = test { testEnableAllTests = EnableAllTests True }++data GoalOrder = FixedGoalOrder | DefaultGoalOrder++{-------------------------------------------------------------------------------+  Solver tests+-------------------------------------------------------------------------------}++data SolverTest = SolverTest {+    testLabel          :: String+  , testTargets        :: [String]+  , testResult         :: SolverResult+  , testIndepGoals     :: IndependentGoals+  , testGoalOrder      :: Maybe [ExampleVar]+  , testSoftConstraints :: [ExPreference]+  , testDb             :: ExampleDb+  , testSupportedExts  :: Maybe [Extension]+  , testSupportedLangs :: Maybe [Language]+  , testPkgConfigDb    :: PkgConfigDb+  , testEnableAllTests :: EnableAllTests+  }++-- | Expected result of a solver test.+data SolverResult = SolverResult {+    -- | The solver's log should satisfy this predicate. Note that we also print+    -- the log, so evaluating a large log here can cause a space leak.+    resultLogPredicate            :: [String] -> Bool,++    -- | Fails with an error message satisfying the predicate, or succeeds with+    -- the given plan.+    resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)]+  }++solverSuccess :: [(String, Int)] -> SolverResult+solverSuccess = SolverResult (const True) . Right++solverFaiure :: (String -> Bool) -> SolverResult+solverFaiure = SolverResult (const True) . Left++-- | Can be used for test cases where we just want to verify that+-- they fail, but do not care about the error message.+anySolverFailure :: SolverResult+anySolverFailure = solverFaiure (const True)++-- | Makes a solver test case, consisting of the following components:+--+--      1. An 'ExampleDb', representing the package database (both+--         installed and remote) we are doing dependency solving over,+--      2. A 'String' name for the test,+--      3. A list '[String]' of package names to solve for+--      4. The expected result, either 'Nothing' if there is no+--         satisfying solution, or a list '[(String, Int)]' of+--         packages to install, at which versions.+--+-- See 'UnitTests.Distribution.Solver.Modular.DSL' for how+-- to construct an 'ExampleDb', as well as definitions of 'db1' etc.+-- in this file.+mkTest :: ExampleDb+       -> String+       -> [String]+       -> SolverResult+       -> SolverTest+mkTest = mkTestExtLangPC Nothing Nothing []++mkTestExts :: [Extension]+           -> ExampleDb+           -> String+           -> [String]+           -> SolverResult+           -> SolverTest+mkTestExts exts = mkTestExtLangPC (Just exts) Nothing []++mkTestLangs :: [Language]+            -> ExampleDb+            -> String+            -> [String]+            -> SolverResult+            -> SolverTest+mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) []++mkTestPCDepends :: [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> SolverResult+                -> SolverTest+mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb++mkTestExtLangPC :: Maybe [Extension]+                -> Maybe [Language]+                -> [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> SolverResult+                -> SolverTest+mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {+    testLabel          = label+  , testTargets        = targets+  , testResult         = result+  , testIndepGoals     = IndependentGoals False+  , testGoalOrder      = Nothing+  , testSoftConstraints = []+  , testDb             = db+  , testSupportedExts  = exts+  , testSupportedLangs = langs+  , testPkgConfigDb    = pkgConfigDbFromList pkgConfigDb+  , testEnableAllTests = EnableAllTests False+  }++runTest :: SolverTest -> TF.TestTree+runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->+    testCase testLabel $ do+      let progress = exResolve testDb testSupportedExts+                     testSupportedLangs testPkgConfigDb testTargets+                     Modular Nothing testIndepGoals (ReorderGoals False)+                     (EnableBackjumping True) testGoalOrder testSoftConstraints+                     testEnableAllTests+          printMsg msg = if showSolverLog+                         then putStrLn msg+                         else return ()+          msgs = foldProgress (:) (const []) (const []) progress+      assertBool ("Unexpected solver log:\n" ++ unlines msgs) $+                 resultLogPredicate testResult $ concatMap lines msgs+      result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress+      case result of+        Left  err  -> assertBool ("Unexpected error:\n" ++ err)+                                 (checkErrorMsg testResult err)+        Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan))+  where+    toMaybe :: SolverResult -> Maybe [(String, Int)]+    toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan++    checkErrorMsg :: SolverResult -> String -> Bool+    checkErrorMsg result msg =+        case resultErrorMsgPredicateOrPlan result of+          Left f  -> f msg+          Right _ -> False++{-------------------------------------------------------------------------------+  Specific example database for the tests+-------------------------------------------------------------------------------}++db1 :: ExampleDb+db1 =+    let a = exInst "A" 1 "A-1" []+    in [ Left a+       , Right $ exAv "B" 1 [ExAny "A"]+       , Right $ exAv "B" 2 [ExAny "A"]+       , Right $ exAv "C" 1 [ExFix "B" 1]+       , Right $ exAv "D" 1 [ExFix "B" 2]+       , Right $ exAv "E" 1 [ExAny "B"]+       , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]+       , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]+       , Right $ exAv "Z" 1 []+       ]++-- In this example, we _can_ install C and D as independent goals, but we have+-- to pick two diferent versions for B (arbitrarily)+db2 :: ExampleDb+db2 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "B" 2 [ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1]+  , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2]+  ]++db3 :: ExampleDb+db3 = [+     Right $ exAv "A" 1 []+   , Right $ exAv "A" 2 []+   , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]+   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]+   , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]+   ]++-- | Like db3, but the flag picks a different package rather than a+-- different package version+--+-- In db3 we cannot install C and D as independent goals because:+--+-- * The multiple instance restriction says C and D _must_ share B+-- * Since C relies on A-1, C needs B to be compiled with flagB on+-- * Since D relies on A-2, D needs B to be compiled with flagB off+-- * Hence C and D have incompatible requirements on B's flags.+--+-- However, _even_ if we don't check explicitly that we pick the same flag+-- assignment for 0.B and 1.B, we will still detect the problem because+-- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to+-- 1.A and therefore we cannot link 0.B to 1.B.+--+-- In db4 the situation however is trickier. We again cannot install+-- packages C and D as independent goals because:+--+-- * As above, the multiple instance restriction says that C and D _must_ share B+-- * Since C relies on Ax-2, it requires B to be compiled with flagB off+-- * Since D relies on Ay-2, it requires B to be compiled with flagB on+-- * Hence C and D have incompatible requirements on B's flags.+--+-- But now this requirement is more indirect. If we only check dependencies+-- we don't see the problem:+--+-- * We link 0.B to 1.B+-- * 0.B relies on Ay-1+-- * 1.B relies on Ax-1+--+-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since+-- we only ever assign to one of these, these constraints are never broken.+db4 :: ExampleDb+db4 = [+     Right $ exAv "Ax" 1 []+   , Right $ exAv "Ax" 2 []+   , Right $ exAv "Ay" 1 []+   , Right $ exAv "Ay" 2 []+   , Right $ exAv "B"  1 [exFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]+   , Right $ exAv "C"  1 [ExFix "Ax" 2, ExAny "B"]+   , Right $ exAv "D"  1 [ExFix "Ay" 2, ExAny "B"]+   ]++-- | Some tests involving testsuites+--+-- Note that in this test framework test suites are always enabled; if you+-- want to test without test suites just set up a test database without+-- test suites.+--+-- * C depends on A (through its test suite)+-- * D depends on B-2 (through its test suite), but B-2 is unavailable+-- * E depends on A-1 directly and on A through its test suite. We prefer+--     to use A-1 for the test suite in this case.+-- * F depends on A-1 directly and on A-2 through its test suite. In this+--     case we currently fail to install F, although strictly speaking+--     test suites should be considered independent goals.+-- * G is like E, but for version A-2. This means that if we cannot install+--     E and G together, unless we regard them as independent goals.+db5 :: ExampleDb+db5 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"]+  , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2]+  , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"]+  , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2]+  , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"]+  ]++-- Now the _dependencies_ have test suites+--+-- * Installing C is a simple example. C wants version 1 of A, but depends on+--   B, and B's testsuite depends on an any version of A. In this case we prefer+--   to link (if we don't regard test suites as independent goals then of course+--   linking here doesn't even come into it).+-- * Installing [C, D] means that we prefer to link B -- depending on how we+--   set things up, this means that we should also link their test suites.+db6 :: ExampleDb+db6 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"]+  , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]+  , Right $ exAv "D" 1 [ExAny "B"]+  ]++-- Packages with setup dependencies+--+-- Install..+-- * B: Simple example, just make sure setup deps are taken into account at all+-- * C: Both the package and the setup script depend on any version of A.+--      In this case we prefer to link+-- * D: Variation on C.1 where the package requires a specific (not latest)+--      version but the setup dependency is not fixed. Again, we prefer to+--      link (picking the older version)+-- * E: Variation on C.2 with the setup dependency the more inflexible.+--      Currently, in this case we do not see the opportunity to link because+--      we consider setup dependencies after normal dependencies; we will+--      pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick+--      A.1 instead. This isn't so easy to fix (if we want to fix it at all);+--      in particular, considering setup dependencies _before_ other deps is+--      not an improvement, because in general we would prefer to link setup+--      setups to package deps, rather than the other way around. (For example,+--      if we change this ordering then the test for D would start to install+--      two versions of A).+-- * F: The package and the setup script depend on different versions of A.+--      This will only work if setup dependencies are considered independent.+db7 :: ExampleDb+db7 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 []            `withSetupDeps` [ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "A"  ] `withSetupDeps` [ExAny "A"  ]+  , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"  ]+  , Right $ exAv "E" 1 [ExAny "A"  ] `withSetupDeps` [ExFix "A" 1]+  , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]+  ]++-- If we install C and D together (not as independent goals), we need to build+-- both B.1 and B.2, both of which depend on A.+db8 :: ExampleDb+db8 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "B" 2 [ExAny "A"]+  , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1]+  , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2]+  ]++-- Extended version of `db8` so that we have nested setup dependencies+db9 :: ExampleDb+db9 = db8 ++ [+    Right $ exAv "E" 1 [ExAny "C"]+  , Right $ exAv "E" 2 [ExAny "D"]+  , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]+  , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]+  ]++-- Multiple already-installed packages with inter-dependencies, and one package+-- (C) that depends on package A-1 for its setup script and package A-2 as a+-- library dependency.+db10 :: ExampleDb+db10 =+  let rts         = exInst "rts"         1 "rts-inst"         []+      ghc_prim    = exInst "ghc-prim"    1 "ghc-prim-inst"    [rts]+      base        = exInst "base"        1 "base-inst"        [rts, ghc_prim]+      a1          = exInst "A"           1 "A1-inst"          [base]+      a2          = exInst "A"           2 "A2-inst"          [base]+  in [+      Left rts+    , Left ghc_prim+    , Left base+    , Left a1+    , Left a2+    , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]+    ]++-- | This database tests that a package's setup dependencies are correctly+-- linked when the package is linked. See pull request #3268.+--+-- When A and B are installed as independent goals, their dependencies on C must+-- be linked, due to the single instance restriction. Since C depends on D, 0.D+-- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D+-- and 1.C-setup.D must be linked. However, D's two link groups must remain+-- independent. The solver should be able to choose D-1 for C's library and D-2+-- for C's setup script.+dbSetupDeps :: ExampleDb+dbSetupDeps = [+    Right $ exAv "A" 1 [ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  ]++-- | Tests for dealing with base shims+db11 :: ExampleDb+db11 =+  let base3 = exInst "base" 3 "base-3-inst" [base4]+      base4 = exInst "base" 4 "base-4-inst" []+  in [+      Left base3+    , Left base4+    , Right $ exAv "A" 1 [ExFix "base" 3]+    ]++-- | Slightly more realistic version of db11 where base-3 depends on syb+-- This means that if a package depends on base-3 and on syb, then they MUST+-- share the version of syb+--+-- * Package A relies on base-3 (which relies on base-4)+-- * Package B relies on base-4+-- * Package C relies on both A and B+-- * Package D relies on base-3 and on syb-2, which is not possible because+--     base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier)+-- * Package E relies on base-4 and on syb-2, which is fine.+db12 :: ExampleDb+db12 =+  let base3 = exInst "base" 3 "base-3-inst" [base4, syb1]+      base4 = exInst "base" 4 "base-4-inst" []+      syb1  = exInst "syb" 1 "syb-1-inst" [base4]+  in [+      Left base3+    , Left base4+    , Left syb1+    , Right $ exAv "syb" 2 [ExFix "base" 4]+    , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]+    , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]+    , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]+    , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]+    , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]+    ]++db13 :: ExampleDb+db13 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "A" 3 []+  ]++dbStanzaPreferences1 :: ExampleDb+dbStanzaPreferences1 = [+    Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "test-dep"]+  , Right $ exAv "test-dep" 1 []+  ]++dbStanzaPreferences2 :: ExampleDb+dbStanzaPreferences2 = [+    Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"]+  ]++-- | Database with some cycles+--+-- * Simplest non-trivial cycle: A -> B and B -> A+-- * There is a cycle C -> D -> C, but it can be broken by picking the+--   right flag assignment.+db14 :: ExampleDb+db14 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]]+  , Right $ exAv "D" 1 [ExAny "C"]+  , Right $ exAv "E" 1 []+  ]++-- | Cycles through setup dependencies+--+-- The first cycle is unsolvable: package A has a setup dependency on B,+-- B has a regular dependency on A, and we only have a single version available+-- for both.+--+-- The second cycle can be broken by picking different versions: package C-2.0+-- has a setup dependency on D, and D has a regular dependency on C-*. However,+-- version C-1.0 is already available (perhaps it didn't have this setup dep).+-- Thus, we should be able to break this cycle even if we are installing package+-- E, which explictly depends on C-2.0.+db15 :: ExampleDb+db15 = [+    -- First example (real cycle, no solution)+    Right $ exAv   "A" 1            []            `withSetupDeps` [ExAny "B"]+  , Right $ exAv   "B" 1            [ExAny "A"]+    -- Second example (cycle can be broken by picking versions carefully)+  , Left  $ exInst "C" 1 "C-1-inst" []+  , Right $ exAv   "C" 2            []            `withSetupDeps` [ExAny "D"]+  , Right $ exAv   "D" 1            [ExAny "C"  ]+  , Right $ exAv   "E" 1            [ExFix "C" 2]+  ]++-- | Check that the solver can backtrack after encountering the SIR (issue #2843)+--+-- When A and B are installed as independent goals, the single instance+-- restriction prevents B from depending on C.  This database tests that the+-- solver can backtrack after encountering the single instance restriction and+-- choose the only valid flag assignment (-flagA +flagB):+--+-- > flagA flagB  B depends on+-- >  On    _     C-*+-- >  Off   On    E-*               <-- only valid flag assignment+-- >  Off   Off   D-2.0, C-*+--+-- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D,+-- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have+-- C in the transitive closure of B's dependencies, because that would mean we+-- would need two instances of C: one built against D-1.0 and one built against+-- D-2.0.+db16 :: ExampleDb+db16 = [+    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]+  , Right $ exAv "B" 1 [ ExFix "D" 2+                       , exFlag "flagA"+                             [ExAny "C"]+                             [exFlag "flagB"+                                 [ExAny "E"]+                                 [ExAny "C"]]]+  , Right $ exAv "C" 1 [ExAny "D"]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  , Right $ exAv "E" 1 []+  ]++-- | This test checks that when the solver discovers a constraint on a+-- package's version after choosing to link that package, it can backtrack to+-- try alternative versions for the linked-to package. See pull request #3327.+--+-- When A and B are installed as independent goals, their dependencies on C+-- must be linked. Since C depends on D, A and B's dependencies on D must also+-- be linked. This test fixes the goal order so that the solver chooses D-2 for+-- both 0.D and 1.D before it encounters the test suites' constraints. The+-- solver must backtrack to try D-1 for both 0.D and 1.D.+testIndepGoals2 :: String -> SolverTest+testIndepGoals2 name =+    goalOrder goals $ indep $+    enableAllTests $ mkTest db name ["A", "B"] $+    solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]+      , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]+      , Right $ exAv "C" 1 [ExAny "D"]+      , Right $ exAv "D" 1 []+      , Right $ exAv "D" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "A"+      , P (Indep 0) "C"+      , P (Indep 0) "D"+      , P (Indep 1) "B"+      , P (Indep 1) "C"+      , P (Indep 1) "D"+      , S (Indep 1) "B" TestStanzas+      , S (Indep 0) "A" TestStanzas+      ]++-- | Issue #2834+-- When both A and B are installed as independent goals, their dependencies on+-- C must be linked. The only combination of C's flags that is consistent with+-- A and B's dependencies on D is -flagA +flagB. This database tests that the+-- solver can backtrack to find the right combination of flags (requiring F, but+-- not E or G) and apply it to both 0.C and 1.C.+--+-- > flagA flagB  C depends on+-- >  On    _     D-1, E-*+-- >  Off   On    F-*        <-- Only valid choice+-- >  Off   Off   D-2, G-*+--+-- The single instance restriction means we cannot have one instance of C+-- built against D-1 and one instance built against D-2; since A depends on+-- D-1, and B depends on C-2, it is therefore important that C cannot depend+-- on any version of D.+db18 :: ExampleDb+db18 = [+    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]+  , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2]+  , Right $ exAv "C" 1 [exFlag "flagA"+                           [ExFix "D" 1, ExAny "E"]+                           [exFlag "flagB"+                               [ExAny "F"]+                               [ExFix "D" 2, ExAny "G"]]]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  , Right $ exAv "E" 1 []+  , Right $ exAv "F" 1 []+  , Right $ exAv "G" 1 []+  ]++-- | Tricky test case with independent goals (issue #2842)+--+-- Suppose we are installing D, E, and F as independent goals:+--+-- * D depends on A-* and C-1, requiring A-1 to be built against C-1+-- * E depends on B-* and C-2, requiring B-1 to be built against C-2+-- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built+--     against the same version of C, violating the single instance restriction.+--+-- We can visualize this DB as:+--+-- >    C-1   C-2+-- >    /|\   /|\+-- >   / | \ / | \+-- >  /  |  X  |  \+-- > |   | / \ |   |+-- > |   |/   \|   |+-- > |   +     +   |+-- > |   |     |   |+-- > |   A     B   |+-- >  \  |\   /|  /+-- >   \ | \ / | /+-- >    \|  V  |/+-- >     D  F  E+testIndepGoals3 :: String -> SolverTest+testIndepGoals3 name =+    goalOrder goals $ indep $+    mkTest db name ["D", "E", "F"] anySolverFailure+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExAny "C"]+      , Right $ exAv "B" 1 [ExAny "C"]+      , Right $ exAv "C" 1 []+      , Right $ exAv "C" 2 []+      , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1]+      , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2]+      , Right $ exAv "F" 1 [ExAny "A", ExAny "B"]+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "D"+      , P (Indep 0) "C"+      , P (Indep 0) "A"+      , P (Indep 1) "E"+      , P (Indep 1) "C"+      , P (Indep 1) "B"+      , P (Indep 2) "F"+      , P (Indep 2) "B"+      , P (Indep 2) "C"+      , P (Indep 2) "A"+      ]++-- | This test checks that the solver correctly backjumps when dependencies+-- of linked packages are not linked. It is an example where the conflict set+-- from enforcing the single instance restriction is not sufficient. See pull+-- request #3327.+--+-- When A, B, and C are installed as independent goals with the specified goal+-- order, the first choice that the solver makes for E is 0.E-2. Then, when it+-- chooses dependencies for B and C, it links both 1.E and 2.E to 0.E. Finally,+-- the solver discovers C's test's constraint on E. It must backtrack to try+-- 1.E-1 and then link 2.E to 1.E. Backjumping all the way to 0.E does not lead+-- to a solution, because 0.E's version is constrained by A and cannot be+-- changed.+testIndepGoals4 :: String -> SolverTest+testIndepGoals4 name =+    goalOrder goals $ indep $+    enableAllTests $ mkTest db name ["A", "B", "C"] $+    solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExFix "E" 2]+      , Right $ exAv "B" 1 [ExAny "D"]+      , Right $ exAv "C" 1 [ExAny "D"] `withTest` ExTest "test" [ExFix "E" 1]+      , Right $ exAv "D" 1 [ExAny "E"]+      , Right $ exAv "E" 1 []+      , Right $ exAv "E" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "A"+      , P (Indep 0) "E"+      , P (Indep 1) "B"+      , P (Indep 1) "D"+      , P (Indep 1) "E"+      , P (Indep 2) "C"+      , P (Indep 2) "D"+      , P (Indep 2) "E"+      , S (Indep 2) "C" TestStanzas+      ]++-- | Test the trace messages that we get when a package refers to an unknown pkg+--+-- TODO: Currently we don't actually test the trace messages, and this particular+-- test still suceeds. The trace can only be verified by hand.+db21 :: ExampleDb+db21 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown+  , Right $ exAv "B" 1 []+  ]++-- | A variant of 'db21', which actually fails.+db22 :: ExampleDb+db22 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "A" 2 [ExAny "C"]+  ]++-- | Another test for the unknown package message.  This database tests that+-- filtering out redundant conflict set messages in the solver log doesn't+-- interfere with generating a message about a missing package (part of issue+-- #3617). The conflict set for the missing package is {A, B}. That conflict set+-- is propagated up the tree to the level of A. Since the conflict set is the+-- same at both levels, the solver only keeps one of the backjumping messages.+db23 :: ExampleDb+db23 = [+    Right $ exAv "A" 1 [ExAny "B"]+  ]++-- | Database for (unsuccessfully) trying to expose a bug in the handling+-- of implied linking constraints. The question is whether an implied linking+-- constraint should only have the introducing package in its conflict set,+-- or also its link target.+--+-- It turns out that as long as the Single Instance Restriction is in place,+-- it does not matter, because there will aways be an option that is failing+-- due to the SIR, which contains the link target in its conflict set.+--+-- Even if the SIR is not in place, if there is a solution, one will always+-- be found, because without the SIR, linking is always optional, but never+-- necessary.+--+testIndepGoals5 :: String -> GoalOrder -> SolverTest+testIndepGoals5 name fixGoalOrder =+    case fixGoalOrder of+      FixedGoalOrder   -> goalOrder goals test+      DefaultGoalOrder -> test+  where+    test :: SolverTest+    test = indep $ mkTest db name ["X", "Y"] $+           solverSuccess+           [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)]++    db :: ExampleDb+    db = [+        Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"]+      , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2]+      , Right $ exAv "A" 1 []+      , Right $ exAv "A" 2 [ExAny "B"]+      , Right $ exAv "B" 1 [ExAny "C"]+      , Right $ exAv "C" 1 []+      , Right $ exAv "C" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "X"+      , P (Indep 0) "A"+      , P (Indep 0) "B"+      , P (Indep 0) "C"+      , P (Indep 1) "Y"+      , P (Indep 1) "A"+      , P (Indep 1) "B"+      , P (Indep 1) "C"+      ]++-- | A simplified version of 'testIndepGoals5'.+testIndepGoals6 :: String -> GoalOrder -> SolverTest+testIndepGoals6 name fixGoalOrder =+    case fixGoalOrder of+      FixedGoalOrder   -> goalOrder goals test+      DefaultGoalOrder -> test+  where+    test :: SolverTest+    test = indep $ mkTest db name ["X", "Y"] $+           solverSuccess+           [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)]++    db :: ExampleDb+    db = [+        Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"]+      , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2]+      , Right $ exAv "A" 1 []+      , Right $ exAv "A" 2 [ExAny "B"]+      , Right $ exAv "B" 1 []+      , Right $ exAv "B" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "X"+      , P (Indep 0) "A"+      , P (Indep 0) "B"+      , P (Indep 1) "Y"+      , P (Indep 1) "A"+      , P (Indep 1) "B"+      ]++dbExts1 :: ExampleDb+dbExts1 = [+    Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]+  , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]+  , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]+  ]++dbLangs1 :: ExampleDb+dbLangs1 = [+    Right $ exAv "A" 1 [ExLang Haskell2010]+  , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]+  , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]+  ]++-- | cabal must set enable-exe to false in order to avoid the unavailable+-- dependency. Flags are true by default. The flag choice causes "pkg" to+-- depend on "false-dep".+testBuildable :: String -> ExampleDependency -> TestTree+testBuildable testName unavailableDep =+    runTest $+    mkTestExtLangPC (Just []) (Just [Haskell98]) [] db testName ["pkg"] expected+  where+    expected = solverSuccess [("false-dep", 1), ("pkg", 1)]+    db = [+        Right $ exAv "pkg" 1 [exFlag "enable-exe"+                                 [ExAny "true-dep"]+                                 [ExAny "false-dep"]]+         `withExe`+            ExExe "exe" [ unavailableDep+                        , ExFlag "enable-exe" (Buildable []) NotBuildable ]+      , Right $ exAv "true-dep" 1 []+      , Right $ exAv "false-dep" 1 []+      ]++-- | cabal must choose -flag1 +flag2 for "pkg", which requires packages+-- "flag1-false" and "flag2-true".+dbBuildable1 :: ExampleDb+dbBuildable1 = [+    Right $ exAv "pkg" 1+        [ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]+        , exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]+     `withExes`+        [ ExExe "exe1"+            [ ExAny "unknown"+            , ExFlag "flag1" (Buildable []) NotBuildable+            , ExFlag "flag2" (Buildable []) NotBuildable]+        , ExExe "exe2"+            [ ExAny "unknown"+            , ExFlag "flag1"+                  (Buildable [])+                  (Buildable [ExFlag "flag2" NotBuildable (Buildable [])])]+         ]+  , Right $ exAv "flag1-true" 1 []+  , Right $ exAv "flag1-false" 1 []+  , Right $ exAv "flag2-true" 1 []+  , Right $ exAv "flag2-false" 1 []+  ]++-- | cabal must pick B-2 to avoid the unknown dependency.+dbBuildable2 :: ExampleDb+dbBuildable2 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "unknown"]+  , Right $ exAv "B" 2 []+     `withExe`+        ExExe "exe"+        [ ExAny "unknown"+        , ExFlag "disable-exe" NotBuildable (Buildable [])+        ]+  , Right $ exAv "B" 3 [ExAny "unknown"]+  ]++-- | Package databases for testing @pkg-config@ dependencies.+dbPC1 :: ExampleDb+dbPC1 = [+    Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]+  , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"]+  , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  ]++{-------------------------------------------------------------------------------+  Simple databases for the illustrations for the backjumping blog post+-------------------------------------------------------------------------------}++-- | Motivate conflict sets+dbBJ1a :: ExampleDb+dbBJ1a = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "A" 2 [ExFix "B" 2]+  , Right $ exAv "B" 1 []+  ]++-- | Show that we can skip some decisions+dbBJ1b :: ExampleDb+dbBJ1b = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "A" 2 [ExFix "B" 2, ExAny "C"]+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 []+  , Right $ exAv "C" 2 []+  ]++-- | Motivate why both A and B need to be in the conflict set+dbBJ1c :: ExampleDb+dbBJ1c = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "B" 1 []+  , Right $ exAv "B" 2 []+  ]++-- | Motivate the need for accumulating conflict sets while we walk the tree+dbBJ2 :: ExampleDb+dbBJ2 = [+    Right $ exAv "A"  1 [ExFix "B" 1]+  , Right $ exAv "A"  2 [ExFix "B" 2]+  , Right $ exAv "B"  1 [ExFix "C" 1]+  , Right $ exAv "B"  2 [ExFix "C" 2]+  , Right $ exAv "C"  1 []+  ]++-- | Motivate the need for `QGoalReason`+dbBJ3 :: ExampleDb+dbBJ3 = [+    Right $ exAv "A"  1 [ExAny "Ba"]+  , Right $ exAv "A"  2 [ExAny "Bb"]+  , Right $ exAv "Ba" 1 [ExFix "C" 1]+  , Right $ exAv "Bb" 1 [ExFix "C" 2]+  , Right $ exAv "C"  1 []+  ]++-- | `QGOalReason` not unique+dbBJ4 :: ExampleDb+dbBJ4 = [+    Right $ exAv "A" 1 [ExAny "B", ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 []+  ]++-- | Flags are represented somewhat strangely in the tree+--+-- This example probably won't be in the blog post itself but as a separate+-- bug report (#3409)+dbBJ5 :: ExampleDb+dbBJ5 = [+    Right $ exAv "A" 1 [exFlag "flagA" [ExFix "B" 1] [ExFix "C" 1]]+  , Right $ exAv "B" 1 [ExFix "D" 1]+  , Right $ exAv "C" 1 [ExFix "D" 2]+  , Right $ exAv "D" 1 []+  ]++-- | Conflict sets for cycles+dbBJ6 :: ExampleDb+dbBJ6 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 []+  , Right $ exAv "B" 2 [ExAny "C"]+  , Right $ exAv "C" 1 [ExAny "A"]+  ]++-- | Conflicts not unique+dbBJ7 :: ExampleDb+dbBJ7 = [+    Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1]+  , Right $ exAv "B" 1 [ExFix "C" 1]+  , Right $ exAv "C" 1 []+  , Right $ exAv "C" 2 []+  ]++-- | Conflict sets for SIR (C shared subgoal of independent goals A, B)+dbBJ8 :: ExampleDb+dbBJ8 = [+    Right $ exAv "A" 1 [ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 []+  ]++{-------------------------------------------------------------------------------+  Databases for build-tools+-------------------------------------------------------------------------------}+dbBuildTools1 :: ExampleDb+dbBuildTools1 = [+    Right $ exAv "alex" 1 [],+    Right $ exAv "A" 1 [ExBuildToolAny "alex"]+  ]++-- Test that build-tools on a random thing doesn't matter (only+-- the ones we recognize need to be in db)+dbBuildTools2 :: ExampleDb+dbBuildTools2 = [+    Right $ exAv "A" 1 [ExBuildToolAny "otherdude"]+  ]++-- Test that we can solve for different versions of executables+dbBuildTools3 :: ExampleDb+dbBuildTools3 = [+    Right $ exAv "alex" 1 [],+    Right $ exAv "alex" 2 [],+    Right $ exAv "A" 1 [ExBuildToolFix "alex" 1],+    Right $ exAv "B" 1 [ExBuildToolFix "alex" 2],+    Right $ exAv "C" 1 [ExAny "A", ExAny "B"]+  ]++-- Test that exe is not related to library choices+dbBuildTools4 :: ExampleDb+dbBuildTools4 = [+    Right $ exAv "alex" 1 [ExFix "A" 1],+    Right $ exAv "A" 1 [],+    Right $ exAv "A" 2 [],+    Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2]+  ]++-- Test that build-tools on build-tools works+dbBuildTools5 :: ExampleDb+dbBuildTools5 = [+    Right $ exAv "alex" 1 [],+    Right $ exAv "happy" 1 [ExBuildToolAny "alex"],+    Right $ exAv "A" 1 [ExBuildToolAny "happy"]+  ]++-- Test that build-depends on library/executable package works.+-- Extracted from https://github.com/haskell/cabal/issues/3775+dbBuildTools6 :: ExampleDb+dbBuildTools6 = [+    Right $ exAv "warp" 1 [],+    -- NB: the warp build-depends refers to the package, not the internal+    -- executable!+    Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` ExExe "warp" [ExAny "A"],+    Right $ exAv "B" 2 [ExAny "A", ExAny "warp"]+  ]
+ cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ParallelListComp #-}+module UnitTests.Distribution.Solver.Modular.WeightedPSQ (+  tests+  ) where++import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Data.List (sort)++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (Blind(..), testProperty)++tests :: [TestTree]+tests = [+    testProperty "'toList . fromList' preserves elements" $ \xs ->+        sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs))++  , testProperty "'toList . fromList' sorts stably" $ \xs ->+        let indexAsValue :: [(Int, (), Int)]+            indexAsValue = [(x, (), i) | x <- xs | i <- [0..]]+        in isSorted $ W.toList $ W.fromList indexAsValue++  , testProperty "'mapWeightsWithKey' sorts by weight" $ \xs (Blind f) ->+        isSorted $ W.weights $+        W.mapWeightsWithKey (f :: Int -> Int -> Int) $+        W.fromList (xs :: [(Int, Int, Int)])++  , testCase "applying 'mapWeightsWithKey' twice sorts twice" $+        let indexAsKey :: [((), Int, ())]+            indexAsKey = [((), i, ()) | i <- [0..10]]+            actual = W.toList $+                     W.mapWeightsWithKey (\_ _ -> ()) $+                     W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored+                     W.fromList indexAsKey+        in reverse indexAsKey @?= actual++  , testProperty "'union' sorts by weight" $ \xs ys ->+        isSorted $ W.weights $+        W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)]))++  , testProperty "'union' preserves elements" $ \xs ys ->+        let union = W.union (W.fromList xs)+                            (W.fromList (ys :: [(Int, Int, Int)]))+        in sort (xs ++ ys) == sort (W.toList union)++  , testCase "'lookup' returns first occurrence" $+        let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')]+        in Just 'C' @?= W.lookup True xs+  ]++isSorted :: Ord a => [a] -> Bool+isSorted (x1 : xs@(x2 : _)) = x1 <= x2 && isSorted xs+isSorted _ = True
+ cabal/cabal-testsuite/LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2003-2016, Cabal Development Team.+See the AUTHORS file for the full list of copyright holders.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Isaac Jones nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ cabal/cabal-testsuite/PackageTests.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}++-- This is the runner for the package-tests suite.  The actual+-- tests are in in PackageTests.Tests++module Main where++import PackageTests.Options+import PackageTests.PackageTester+import PackageTests.Tests++import Distribution.Simple.Configure+    ( ConfigStateFileError(..), findDistPrefOrDefault, getConfigStateFile+    , interpretPackageDbFlags, configCompilerEx )+import Distribution.Simple.Compiler (PackageDB(..), PackageDBStack+                                    ,CompilerFlavor(GHC))+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.Program (defaultProgramDb)+import Distribution.Simple.Setup (Flag(..), readPackageDbList, showPackageDbList)+import Distribution.Simple.Utils (cabalVersion)+import Distribution.Text (display)+import Distribution.Verbosity (normal, flagToVerbosity, lessVerbose)+import Distribution.ReadE (readEOrFail)+import Distribution.Compat.Time (calibrateMtimeChangeDelay)++import Control.Exception+import Data.Proxy                      ( Proxy(..) )+import Distribution.Compat.Environment ( lookupEnv )+import System.Directory+import Test.Tasty+import Test.Tasty.Options+import Test.Tasty.Ingredients++#if MIN_VERSION_base(4,6,0)+import System.Environment ( getExecutablePath )+#endif++main :: IO ()+main = do+    -- In abstract, the Cabal test suite makes calls to the "Setup"+    -- executable and tests the output of Cabal.  However, we have to+    -- responsible for building this executable in the first place,+    -- since (1) Cabal doesn't support a test-suite depending on an+    -- executable, so we can't put a "Setup" executable in the Cabal+    -- file and then depend on it, (2) we don't want to call the Cabal+    -- functions *directly* because we need to capture and save the+    -- stdout and stderr, and (3) even if we could do all that, we will+    -- want to test some Custom setup scripts, which will be specific to+    -- the test at hand and need to be compiled against Cabal.+    --+    -- To be able to build the executable, there is some information+    -- we need:+    --+    --      1. We need to know what ghc to use,+    --+    --      2. We need to know what package databases (plural!) contain+    --      all of the necessary dependencies to make our Cabal package+    --      well-formed.+    --+    -- We could have the user pass these all in as arguments,  but+    -- there's a more convenient way to get this information: the *build+    -- configuration* that was used to build the Cabal library (and this+    -- test suite) in the first place.  To do this, we need to find the+    -- 'dist' directory that was set as the build directory for Cabal.++    -- First, figure out the dist directory associated with this Cabal.+    dist_dir :: FilePath <- guessDistDir++    -- Next, attempt to read out the LBI.  This may not work, in which+    -- case we'll try to guess the correct parameters.  This is ignored+    -- if values are explicitly passed into the test suite.+    mb_lbi <- getPersistBuildConfig_ (dist_dir </> "setup-config")++    -- You need to run the test suite in the right directory, sorry.+    -- This variable is modestly misnamed: this refers to the base+    -- directory of Cabal (so, CHECKOUT_DIR/Cabal, not+    -- CHECKOUT_DIR/Cabal/test).+    cabal_dir <- getCurrentDirectory++    -- TODO: make this controllable by a flag.  We do have a flag+    -- parser but it's not called early enough for this verbosity...+    verbosity <- maybe normal (readEOrFail flagToVerbosity)+                 `fmap` lookupEnv "VERBOSE"++    -------------------------------------------------------------------+    -- SETTING UP GHC AND GHC-PKG+    -------------------------------------------------------------------++    -- NOTE: There are TWO configurations of GHC we have to manage+    -- when running the test suite.+    --+    --  1. The primary GHC is the one that was used to build the+    --  copy of Cabal that we are testing.  This configuration+    --  can be pulled out of the LBI.+    --+    --  2. The "with" GHC is the version of GHC we ask the Cabal+    --  we are testing to use (i.e., using --with-compiler).  Notice+    --  that this does NOT have to match the version we compiled+    --  the library with!  (Not all tests will work in this situation,+    --  however, since some need to link against the Cabal library.)+    --  By default we use the same configuration as the one from the+    --  LBI, but a user can override it to test against a different+    --  version of GHC.+    mb_ghc_path     <- lookupEnv "CABAL_PACKAGETESTS_GHC"+    mb_ghc_pkg_path <- lookupEnv "CABAL_PACKAGETESTS_GHC_PKG"+    boot_programs <-+        case (mb_ghc_path, mb_ghc_pkg_path) of+            (Nothing, Nothing) | Just lbi <- mb_lbi -> do+                putStrLn "Using configuration from LBI"+                return (withPrograms lbi)+            _ -> do+                putStrLn "(Re)configuring test suite (ignoring LBI)"+                (_comp, _compPlatform, programDb)+                    <- configCompilerEx+                        (Just GHC) mb_ghc_path mb_ghc_pkg_path+                        -- NB: if we accept full ConfigFlags parser then+                        -- should use (mkProgramDb cfg (configPrograms cfg))+                        -- instead.+                        defaultProgramDb+                        (lessVerbose verbosity)+                return programDb++    mb_with_ghc_path     <- lookupEnv "CABAL_PACKAGETESTS_WITH_GHC"+    mb_with_ghc_pkg_path <- lookupEnv "CABAL_PACKAGETESTS_WITH_GHC_PKG"+    with_programs <-+        case (mb_with_ghc_path, mb_with_ghc_path) of+            (Nothing, Nothing) -> return boot_programs+            _ -> do+                putStrLn "Configuring test suite for --with-compiler"+                (_comp, _compPlatform, with_programs)+                    <- configCompilerEx+                        (Just GHC) mb_with_ghc_path mb_with_ghc_pkg_path+                        defaultProgramDb+                        (lessVerbose verbosity)+                return with_programs++    -- TODO: maybe have to configure gcc?++    -------------------------------------------------------------------+    -- SETTING UP THE DATABASE STACK+    -------------------------------------------------------------------++    -- Figure out what database stack to use. (This is the tricky bit,+    -- because we need to have enough databases to make the just-built+    -- Cabal package well-formed).+    db_stack_env <- lookupEnv "CABAL_PACKAGETESTS_DB_STACK"+    let packageDBStack0 = case db_stack_env of+            Just str -> interpretPackageDbFlags True -- user install? why not.+                            (concatMap readPackageDbList+                                (splitSearchPath str))+            Nothing ->+                case mb_lbi of+                    Just lbi -> withPackageDB lbi+                    -- A wild guess!+                    Nothing -> interpretPackageDbFlags True []++    -- Package DBs are not guaranteed to be absolute, so make them so in+    -- case a subprocess using the package DB needs a different CWD.+    packageDBStack1 <- mapM canonicalizePackageDB packageDBStack0++    -- The LBI's database stack does *not* contain the inplace installed+    -- Cabal package.  So we need to add that to the stack.+    let package_db_stack+            = packageDBStack1 +++              [SpecificPackageDB+                (dist_dir </> "package.conf.inplace")]++    -- NB: It's possible that our database stack is broken (e.g.,+    -- it's got a database for the wrong version of GHC, or it+    -- doesn't have enough to let us build Cabal.)  We'll notice+    -- when we attempt to compile setup.++    -- There is also is a parameter for the stack for --with-compiler,+    -- since if GHC is a different version we need a different set of+    -- databases.  The default should actually be quite reasonable+    -- as, unlike in the case of the GHC used to build Cabal, we don't+    -- expect htere to be a Cabal available.+    with_ghc_db_stack_env :: Maybe String+        <- lookupEnv "CABAL_PACKAGETESTS_WITH_DB_STACK"+    let withGhcDBStack0 :: PackageDBStack+        withGhcDBStack0 =+              interpretPackageDbFlags True+            $ case with_ghc_db_stack_env of+                Nothing -> []+                Just str -> concatMap readPackageDbList (splitSearchPath str)+    with_ghc_db_stack :: PackageDBStack+        <- mapM canonicalizePackageDB withGhcDBStack0++    -- THIS ISN'T EVEN MY FINAL FORM.  The package database stack+    -- controls where we install a package; specifically, the package is+    -- installed to the top-most package on the stack (this makes the+    -- most sense, since it could depend on any of the packages below+    -- it.)  If the test wants to register anything (as opposed to just+    -- working in place), then we need to have another temporary+    -- database we can install into (and not accidentally clobber any of+    -- the other stacks.)  This is done on a per-test basis.+    --+    -- ONE MORE THING. On the subject of installing the package (with+    -- copy/register) it is EXTREMELY important that we also overload+    -- the install directories, so we don't clobber anything in the+    -- default install paths.  VERY IMPORTANT.++    -- Figure out how long we need to delay for recompilation tests+    (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay++    let suite = SuiteConfig+                 { cabalDistPref      = dist_dir+                 , bootProgramDb      = boot_programs+                 , withProgramDb      = with_programs+                 , packageDBStack     = package_db_stack+                 , withGhcDBStack     = with_ghc_db_stack+                 , suiteVerbosity     = verbosity+                 , absoluteCWD        = cabal_dir+                 , mtimeChangeDelay   = mtimeChange'+                 }++    let toMillis :: Int -> Double+        toMillis x = fromIntegral x / 1000.0++    putStrLn $ "Cabal test suite - testing cabal version "+      ++ display cabalVersion+    putStrLn $ "Cabal build directory: " ++ dist_dir+    putStrLn $ "Cabal source directory: " ++ cabal_dir+    putStrLn $ "File modtime calibration: " ++ show (toMillis mtimeChange')+            ++ " (maximum observed: " ++ show (toMillis mtimeChange) ++ ")"+    -- TODO: it might be useful to factor this out so that ./Setup+    -- configure dumps this file, so we can read it without in a version+    -- stable way.+    putStrLn $ "Environment:"+    putStrLn $ "CABAL_PACKAGETESTS_GHC=" ++ show (ghcPath suite) ++ " \\"+    putStrLn $ "CABAL_PACKAGETESTS_GHC_PKG=" ++ show (ghcPkgPath suite) ++ " \\"+    putStrLn $ "CABAL_PACKAGETESTS_WITH_GHC=" ++ show (withGhcPath suite) ++ " \\"+    putStrLn $ "CABAL_PACKAGETESTS_WITH_GHC_PKG=" ++ show (withGhcPkgPath suite) ++ " \\"+    -- For brevity, we use the pre-canonicalized values+    let showDBStack = show+                    . intercalate [searchPathSeparator]+                    . showPackageDbList+                    . uninterpretPackageDBFlags+    putStrLn $ "CABAL_PACKAGETESTS_DB_STACK=" ++ showDBStack packageDBStack0+    putStrLn $ "CABAL_PACKAGETESTS_WITH_DB_STACK=" ++ showDBStack withGhcDBStack0++    -- Create a shared Setup executable to speed up Simple tests+    putStrLn $ "Building shared ./Setup executable"+    rawCompileSetup verbosity suite [] "."++    defaultMainWithIngredients options $+        runTestTree "Package Tests" (tests suite)++-- Reverse of 'interpretPackageDbFlags'.+-- prop_idem stk b+--      = interpretPackageDbFlags b (uninterpretPackageDBFlags stk) == stk+uninterpretPackageDBFlags :: PackageDBStack -> [Maybe PackageDB]+uninterpretPackageDBFlags stk = Nothing : map (\x -> Just x) stk++-- | Guess what the 'dist' directory Cabal was installed in is.  There's+-- no 100% reliable way to find this, but there are a few good shots:+--+--     1. Test programs are ~always built in-place, in a directory+--        that looks like dist/build/package-tests/package-tests;+--        thus the directory can be determined by looking at $0.+--        This method is robust against sandboxes, Nix local+--        builds, and Stack, but doesn't work if you're running+--        in an interpreter.+--+--     2. We can use the normal input methods (as per Cabal),+--        checking for the CABAL_BUILDDIR environment variable as+--        well as the default location in the current working directory.+--+-- NB: If you update this, also update its copy in cabal-install's+-- IntegrationTests+guessDistDir :: IO FilePath+guessDistDir = do+#if MIN_VERSION_base(4,6,0)+    -- Method (1)+    -- TODO: this needs to be BC'ified, probably.+    exe_path <- canonicalizePath =<< getExecutablePath+    -- exe_path is something like /path/to/dist/build/package-tests/package-tests+    let dist0 = dropFileName exe_path </> ".." </> ".."+    b <- doesFileExist (dist0 </> "setup-config")+#else+    let dist0 = error "no path"+        b = False+#endif+    -- Method (2)+    if b then canonicalizePath dist0+         else findDistPrefOrDefault NoFlag >>= canonicalizePath++canonicalizePackageDB :: PackageDB -> IO PackageDB+canonicalizePackageDB (SpecificPackageDB path)+    = SpecificPackageDB `fmap` canonicalizePath path+canonicalizePackageDB x = return x++-- | Like Distribution.Simple.Configure.getPersistBuildConfig but+-- doesn't check that the Cabal version matches, which it doesn't when+-- we run Cabal's own test suite, due to bootstrapping issues.+-- Here's the situation:+--+--      1. There's some system Cabal-1.0 installed.  We use this+--         to build Setup.hs+--      2. We run ./Setup configure, which uses Cabal-1.0 to+--         write out the LocalBuildInfo+--      3. We build the Cabal library, whose version is Cabal-2.0+--      4. We build the package-tests executable, which LINKS AGAINST+--         Cabal-2.0+--      5. We try to read the LocalBuildInfo that ./Setup configure+--         wrote out, but it's Cabal-1.0 format!+--+-- It's a bit skeevy that we're trying to read Cabal-1.0 LocalBuildInfo+-- using Cabal-2.0's parser, but this seems to work OK in practice+-- because LocalBuildInfo is a slow-moving data structure.  If+-- we ever make a major change, this won't work, and we'll have to+-- take a different approach (either setting "build-type: Custom"+-- so we bootstrap with the most recent Cabal, or by writing the+-- information we need in another format.)+getPersistBuildConfig_ :: FilePath -> IO (Maybe LocalBuildInfo)+getPersistBuildConfig_ filename = do+    eLBI <- try $ getConfigStateFile filename+    case eLBI of+      -- If the version doesn't match but we still got a successful+      -- parse, don't complain and just use it!+      Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return (Just lbi)+      Left _ -> return Nothing+      Right lbi -> return (Just lbi)++options :: [Ingredient]+options = includingOptions+          [Option (Proxy :: Proxy OptionEnableAllTests)] :+          defaultIngredients
+ cabal/cabal-testsuite/PackageTests/.gitignore view
@@ -0,0 +1,4 @@+test-log.txt+Setup+/TestSuiteExeV10/dist-*+tmp.package.conf
+ cabal/cabal-testsuite/PackageTests/AllowNewer/AllowNewer.cabal view
@@ -0,0 +1,25 @@+name:                AllowNewer+version:             0.1.0.0+license:             BSD3+author:              Foo Bar+maintainer:          cabal-dev@haskell.org+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Foo+  hs-source-dirs:      src+  build-depends:       base < 1+  default-language:    Haskell2010++test-suite foo-test+  type: exitcode-stdio-1.0+  main-is:             Test.hs+  hs-source-dirs:      tests+  build-depends:       base < 1++benchmark foo-bench+  type: exitcode-stdio-1.0+  main-is:             Bench.hs+  hs-source-dirs:      benchmarks+  build-depends:       base < 1
+ cabal/cabal-testsuite/PackageTests/AllowNewer/benchmarks/Bench.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ cabal/cabal-testsuite/PackageTests/AllowNewer/src/Foo.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ cabal/cabal-testsuite/PackageTests/AllowNewer/tests/Test.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ cabal/cabal-testsuite/PackageTests/AllowOlder/AllowOlder.cabal view
@@ -0,0 +1,25 @@+name:                AllowOlder+version:             0.1.0.0+license:             BSD3+author:              Foo Bar+maintainer:          cabal-dev@haskell.org+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Foo+  hs-source-dirs:      src+  build-depends:       base > 42+  default-language:    Haskell2010++test-suite foo-test+  type: exitcode-stdio-1.0+  main-is:             Test.hs+  hs-source-dirs:      tests+  build-depends:       base > 42++benchmark foo-bench+  type: exitcode-stdio-1.0+  main-is:             Bench.hs+  hs-source-dirs:      benchmarks+  build-depends:       base > 42
+ cabal/cabal-testsuite/PackageTests/AllowOlder/benchmarks/Bench.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ cabal/cabal-testsuite/PackageTests/AllowOlder/src/Foo.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ cabal/cabal-testsuite/PackageTests/AllowOlder/tests/Test.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ cabal/cabal-testsuite/PackageTests/Ambiguity/p/Dupe.hs view
@@ -0,0 +1,2 @@+module Dupe where+pkg = "p"
+ cabal/cabal-testsuite/PackageTests/Ambiguity/p/p.cabal view
@@ -0,0 +1,12 @@+name:                p+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Dupe+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Ambiguity/package-import/A.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}++import qualified "p" Dupe as PDupe+import qualified "q" Dupe as QDupe++main = putStrLn (PDupe.pkg ++ " " ++ QDupe.pkg)+
+ cabal/cabal-testsuite/PackageTests/Ambiguity/package-import/package-import.cabal view
@@ -0,0 +1,13 @@+name:                package-import+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable package-import+  main-is:             A.hs+  other-extensions:    PackageImports+  build-depends:       base, p, q+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Ambiguity/q/Dupe.hs view
@@ -0,0 +1,2 @@+module Dupe where+pkg = "q"
+ cabal/cabal-testsuite/PackageTests/Ambiguity/q/q.cabal view
@@ -0,0 +1,12 @@+name:                q+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Dupe+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Ambiguity/reexport-test/Main.hs view
@@ -0,0 +1,5 @@+module Main where+import qualified PDupe+import qualified QDupe++main = putStrLn (PDupe.pkg ++ " " ++ QDupe.pkg)
+ cabal/cabal-testsuite/PackageTests/Ambiguity/reexport-test/reexport-test.cabal view
@@ -0,0 +1,12 @@+name:                reexport-test+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable reexport-test+  main-is:             Main.hs+  build-depends:       base, reexport+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Ambiguity/reexport/reexport.cabal view
@@ -0,0 +1,12 @@+name:                reexport+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.21++library+  reexported-modules:  p:Dupe as PDupe, q:Dupe as QDupe+  build-depends:       base, p, q+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/Check.hs view
@@ -0,0 +1,51 @@+module PackageTests.AutogenModules.Package.Check where++import PackageTests.PackageTester++suite :: TestM ()+suite = do++        configureResult <- shouldFail $ cabal' "configure" []+        sdistResult <- shouldFail $ cabal' "sdist" []++        -- Package check messages.+        let libAutogenMsg =+                   "An 'autogen-module' is neither on 'exposed-modules' or "+                ++ "'other-modules'"+        let exeAutogenMsg =+                   "On executable 'Exe' an 'autogen-module' is not on "+                ++ "'other-modules'"+        let testAutogenMsg =+                   "On test suite 'Test' an 'autogen-module' is not on "+                ++ "'other-modules'"+        let benchAutogenMsg =+                   "On benchmark 'Bench' an 'autogen-module' is not on "+                ++ "'other-modules'"+        let pathsAutogenMsg =+                "Packages using 'cabal-version: >= 1.25' and the autogenerated"++        -- Asserts for the desired check messages after configure.+        assertOutputContains libAutogenMsg   configureResult+        assertOutputContains exeAutogenMsg   configureResult+        assertOutputContains testAutogenMsg  configureResult+        assertOutputContains benchAutogenMsg configureResult++        -- Asserts for the desired check messages after sdist.+        assertOutputContains "Distribution quality errors:" sdistResult+        assertOutputContains libAutogenMsg   sdistResult+        assertOutputContains exeAutogenMsg   sdistResult+        assertOutputContains testAutogenMsg  sdistResult+        assertOutputContains benchAutogenMsg sdistResult+        assertOutputContains pathsAutogenMsg sdistResult+        -- Asserts for the undesired check messages after sdist.+        assertOutputDoesNotContain "Distribution quality warnings:" sdistResult++        -- Asserts for the error messages of the modules not found.+        assertOutputContains+            "Error: Could not find module: MyLibHelperModule with any suffix"+            sdistResult+        assertOutputContains+            "module is autogenerated it should be added to 'autogen-modules'"+            sdistResult++        return ()
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/Dummy.hs view
@@ -0,0 +1,4 @@+module Dummy where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/LICENSE view
@@ -0,0 +1,1 @@+LICENSE
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/MyBenchModule.hs view
@@ -0,0 +1,4 @@+module MyBenchModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/MyExeModule.hs view
@@ -0,0 +1,4 @@+module MyExeModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/MyLibModule.hs view
@@ -0,0 +1,4 @@+module MyLibModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/MyLibrary.hs view
@@ -0,0 +1,4 @@+module MyLibrary where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/MyTestModule.hs view
@@ -0,0 +1,4 @@+module MyTestModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/my.cabal view
@@ -0,0 +1,60 @@+name: AutogenModules+version: 0.1+license: BSD3+license-file: LICENSE+author: Federico Mastellone+maintainer: Federico Mastellone+synopsis: AutogenModules+category: PackageTests+build-type: Simple+cabal-version: >= 1.25++description:+    Check that Cabal recognizes the autogen-modules fields below.++Library+    default-language: Haskell2010+    build-depends: base+    exposed-modules:+        MyLibrary+        Paths_AutogenModules+        MyLibHelperModule+    other-modules:+        MyLibModule+    autogen-modules:+        MyHelperModule++Executable Exe+    default-language: Haskell2010+    main-is: Dummy.hs+    build-depends: base+    other-modules:+        MyExeModule+        Paths_AutogenModules+        MyExeHelperModule+    autogen-modules:+        MyHelperModule++Test-Suite Test+    default-language: Haskell2010+    main-is: Dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base+    other-modules:+        MyTestModule+        Paths_AutogenModules+        MyTestHelperModule+    autogen-modules:+        MyHelperModule++Benchmark Bench+    default-language: Haskell2010+    main-is: Dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base+    other-modules:+        MyBenchModule+        Paths_AutogenModules+        MyBenchHelperModule+    autogen-modules:+        MyHelperModule
+ cabal/cabal-testsuite/PackageTests/AutogenModules/Package/tmp view
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/Check.hs view
@@ -0,0 +1,104 @@+module PackageTests.AutogenModules.SrcDist.Check where++import Distribution.ModuleName+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import PackageTests.PackageTester++suite :: TestM ()+suite = do++        dist_dir <- distDir++        -- Calling sdist without running configure first makes test fail with:+        -- "Exception: Run the 'configure' command first."+        -- This is becuase we are calling getPersistBuildConfig++        configureResult <- cabal' "configure" []+        sdistResult <- cabal' "sdist" []++        -- Now check that all the correct modules were parsed.+        lbi <- liftIO $ getPersistBuildConfig dist_dir+        let (Just gotLibrary) = library (localPkgDescr lbi)+        let gotExecutable = head $ executables (localPkgDescr lbi)+        let gotTestSuite  = head $ testSuites  (localPkgDescr lbi)+        let gotBenchmark  = head $ benchmarks  (localPkgDescr lbi)+        assertEqual "library 'autogen-modules' field does not match expected"+                [fromString "MyLibHelperModule"]+                (libModulesAutogen gotLibrary)+        assertEqual "executable 'autogen-modules' field does not match expected"+                [fromString "MyExeHelperModule"]+                (exeModulesAutogen gotExecutable)+        assertEqual "test-suite 'autogen-modules' field does not match expected"+                [fromString "MyTestHelperModule"]+                (testModulesAutogen gotTestSuite)+        assertEqual "benchmark 'autogen-modules' field does not match expected"+                [fromString "MyBenchHelperModule"]+                (benchmarkModulesAutogen gotBenchmark)++        -- Package check messages.+        let libAutogenMsg =+                   "An 'autogen-module' is neither on 'exposed-modules' or "+                ++ "'other-modules'"+        let exeAutogenMsg =+                   "On executable 'Exe' an 'autogen-module' is not on "+                ++ "'other-modules'"+        let testAutogenMsg =+                   "On test suite 'Test' an 'autogen-module' is not on "+                ++ "'other-modules'"+        let benchAutogenMsg =+                   "On benchmark 'Bench' an 'autogen-module' is not on "+                ++ "'other-modules'"+        let pathsAutogenMsg =+                "Packages using 'cabal-version: >= 1.25' and the autogenerated"++        -- Asserts for the undesired check messages after configure.+        assertOutputDoesNotContain libAutogenMsg   configureResult+        assertOutputDoesNotContain exeAutogenMsg   configureResult+        assertOutputDoesNotContain testAutogenMsg  configureResult+        assertOutputDoesNotContain benchAutogenMsg configureResult+        assertOutputDoesNotContain pathsAutogenMsg configureResult++        -- Asserts for the undesired check messages after sdist.+        assertOutputDoesNotContain "Distribution quality errors:" sdistResult+        assertOutputDoesNotContain libAutogenMsg   sdistResult+        assertOutputDoesNotContain exeAutogenMsg   sdistResult+        assertOutputDoesNotContain testAutogenMsg  sdistResult+        assertOutputDoesNotContain benchAutogenMsg sdistResult+        assertOutputDoesNotContain "Distribution quality warnings:" sdistResult+        assertOutputDoesNotContain pathsAutogenMsg sdistResult++        -- Assert sdist --list-sources output.+        -- If called before configure fails, dist directory is not created.+        let listSourcesFileGot = dist_dir ++ "/" ++ "list-sources.txt"+        cabal "sdist" ["--list-sources=" ++ listSourcesFileGot]+        let listSourcesStrExpected =+#if defined(mingw32_HOST_OS)+                   ".\\MyLibrary.hs\n"+                ++ ".\\MyLibModule.hs\n"+                ++ ".\\Dummy.hs\n"+                ++ ".\\MyExeModule.hs\n"+                ++ ".\\Dummy.hs\n"+                ++ ".\\MyTestModule.hs\n"+                ++ ".\\Dummy.hs\n"+                ++ ".\\MyBenchModule.hs\n"+                ++ "LICENSE\n"+                ++ ".\\my.cabal\n"+#else+                   "./MyLibrary.hs\n"+                ++ "./MyLibModule.hs\n"+                ++ "./Dummy.hs\n"+                ++ "./MyExeModule.hs\n"+                ++ "./Dummy.hs\n"+                ++ "./MyTestModule.hs\n"+                ++ "./Dummy.hs\n"+                ++ "./MyBenchModule.hs\n"+                ++ "LICENSE\n"+                ++ "./my.cabal\n"+#endif+        listSourcesStrGot <- liftIO $ readFile listSourcesFileGot+        assertEqual "sdist --list-sources does not match the expected files"+                listSourcesStrExpected+                listSourcesStrGot++        return ()
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/Dummy.hs view
@@ -0,0 +1,4 @@+module Dummy where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/LICENSE view
@@ -0,0 +1,1 @@+LICENSE
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/MyBenchModule.hs view
@@ -0,0 +1,4 @@+module MyBenchModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/MyExeModule.hs view
@@ -0,0 +1,4 @@+module MyExeModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/MyLibModule.hs view
@@ -0,0 +1,4 @@+module MyLibModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/MyLibrary.hs view
@@ -0,0 +1,4 @@+module MyLibrary where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/MyTestModule.hs view
@@ -0,0 +1,4 @@+module MyTestModule where++main :: IO ()+main = error ""
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/list-sources.txt view
+ cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/my.cabal view
@@ -0,0 +1,60 @@+name: AutogenModules+version: 0.1+license: BSD3+license-file: LICENSE+author: Federico Mastellone+maintainer: Federico Mastellone+synopsis: AutogenModules+category: PackageTests+build-type: Simple+cabal-version: >= 1.24++description:+    Check that Cabal recognizes the autogen-modules fields below.++Library+    default-language: Haskell2010+    build-depends: base+    exposed-modules:+        MyLibrary+        Paths_AutogenModules+        MyLibHelperModule+    other-modules:+        MyLibModule+    autogen-modules:+        MyLibHelperModule++Executable Exe+    default-language: Haskell2010+    main-is: Dummy.hs+    build-depends: base+    other-modules:+        MyExeModule+        Paths_AutogenModules+        MyExeHelperModule+    autogen-modules:+        MyExeHelperModule++Test-Suite Test+    default-language: Haskell2010+    main-is: Dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base+    other-modules:+        MyTestModule+        Paths_AutogenModules+        MyTestHelperModule+    autogen-modules:+        MyTestHelperModule++Benchmark Bench+    default-language: Haskell2010+    main-is: Dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base+    other-modules:+        MyBenchModule+        Paths_AutogenModules+        MyBenchHelperModule+    autogen-modules:+        MyBenchHelperModule
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes1/A.hs view
@@ -0,0 +1,2 @@+module A where+import Data.Map
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes1/B.hs view
@@ -0,0 +1,3 @@+module B where+import A+import Data.Set
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes1/Includes1.cabal view
@@ -0,0 +1,13 @@+name:                Includes1+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base, containers+  exposed-modules:     A B+  mixins:   containers (Data.Map)+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/Includes2.cabal view
@@ -0,0 +1,41 @@+name:                Includes2+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library mylib+  build-depends:       base+  signatures: Database+  exposed-modules:     Mine+  hs-source-dirs:      mylib+  default-language:    Haskell2010++library mysql+  build-depends:       base+  exposed-modules:     Database.MySQL+  hs-source-dirs:      mysql+  default-language:    Haskell2010++library postgresql+  build-depends:       base+  exposed-modules:     Database.PostgreSQL+  hs-source-dirs:      postgresql+  default-language:    Haskell2010++library+  build-depends:       base, mysql, postgresql, mylib+  mixins:+    mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL),+    mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL)+  exposed-modules:     App+  hs-source-dirs:      src+  default-language:    Haskell2010++executable exe+  build-depends:       base, Includes2+  main-is:             Main.hs+  hs-source-dirs:      exe+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/exe/Main.hs view
@@ -0,0 +1,3 @@+import App++main = print app
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/exe/exe.cabal view
@@ -0,0 +1,12 @@+name:                exe+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++executable exe+  build-depends:       base, src+  main-is:             Main.hs+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/fail.cabal view
@@ -0,0 +1,35 @@+name:                fail+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library mylib+  build-depends:       base+  signatures: Database+  exposed-modules:     Mine+  hs-source-dirs:      mylib+  default-language:    Haskell2010++library mysql+  build-depends:       base+  exposed-modules:     Database.MySQL+  hs-source-dirs:      mysql+  default-language:    Haskell2010++library postgresql+  build-depends:       base+  exposed-modules:     Database.PostgreSQL+  hs-source-dirs:      postgresql+  default-language:    Haskell2010++library+  build-depends:       base, mysql, postgresql, mylib+  mixins:+    mysql (Database.MySQL as Database),+    postgresql (Database.PostgreSQL as Database)+  exposed-modules:     App+  hs-source-dirs:      src+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/mylib/Database.hsig view
@@ -0,0 +1,3 @@+signature Database where+data Database+databaseName :: String
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/mylib/Mine.hs view
@@ -0,0 +1,4 @@+module Mine where+import Database+data Mine = Mine Database+mine = "mine" ++ databaseName
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/mylib/mylib.cabal view
@@ -0,0 +1,13 @@+name:                mylib+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  signatures: Database+  exposed-modules:     Mine+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs view
@@ -0,0 +1,3 @@+module Database.MySQL where+data Database = Database Int+databaseName = "mysql"
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/mysql/mysql.cabal view
@@ -0,0 +1,12 @@+name:                mysql+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  exposed-modules:     Database.MySQL+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs view
@@ -0,0 +1,3 @@+module Database.PostgreSQL where+data Database = Database Bool+databaseName = "postgresql"
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/postgresql/postgresql.cabal view
@@ -0,0 +1,12 @@+name:                postgresql+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  exposed-modules:     Database.PostgreSQL+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/src/App.hs view
@@ -0,0 +1,7 @@+module App where+import Database.MySQL+import Database.PostgreSQL+import qualified Mine.MySQL+import qualified Mine.PostgreSQL++app = Mine.MySQL.mine ++ " " ++ Mine.PostgreSQL.mine
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes2/src/src.cabal view
@@ -0,0 +1,15 @@+name:                src+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base, mysql, postgresql, mylib+  mixins:+    mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL),+    mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL)+  exposed-modules:     App+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes3/Includes3.cabal view
@@ -0,0 +1,23 @@+name:                Includes3+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library sigs+  build-depends:       base+  signatures: Data.Map+  hs-source-dirs:      sigs++library indef+  build-depends:       base, sigs+  exposed-modules:     Foo+  hs-source-dirs:      indef++executable exe+  build-depends:       base, containers, indef+  main-is:             Main.hs+  hs-source-dirs:      exe+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/Main.hs view
@@ -0,0 +1,4 @@+import qualified Data.Map as Map+import Data.Map (Map)+import Foo+main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int)
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/exe.cabal view
@@ -0,0 +1,12 @@+name:                exe+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++executable exe+  build-depends:       base, containers, indef+  main-is:             Main.hs+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/Foo.hs view
@@ -0,0 +1,6 @@+module Foo where++import Data.Map++f :: (a -> b) -> Map k a -> Map k b+f = fmap
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal view
@@ -0,0 +1,11 @@+name:                indef+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base, sigs+  exposed-modules:     Foo
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig view
@@ -0,0 +1,5 @@+{-# LANGUAGE RoleAnnotations #-}+signature Data.Map where+type role Map nominal representational+data Map k a+instance Functor (Map k)
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal view
@@ -0,0 +1,11 @@+name:                sigs+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  build-depends:       base+  signatures: Data.Map
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/Includes4.cabal view
@@ -0,0 +1,25 @@+name:                Includes4+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library indef+  build-depends: base+  signatures: A, B, Rec+  exposed-modules: C+  hs-source-dirs: indef+  default-language:    Haskell2010++library impl+  build-depends: base+  exposed-modules: A, B, Rec+  hs-source-dirs: impl+  default-language:    Haskell2010++executable exe+  build-depends: indef, impl, base+  main-is: Main.hs+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/Main.hs view
@@ -0,0 +1,2 @@+import C+main = putStrLn (take 10 (show x))
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/impl/A.hs view
@@ -0,0 +1,4 @@+module A where+import B+data A = A B+    deriving (Show)
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/impl/A.hs-boot view
@@ -0,0 +1,3 @@+module A where+data A+instance Show A
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/impl/B.hs view
@@ -0,0 +1,4 @@+module B where+import {-# SOURCE #-} A+data B = B A+    deriving (Show)
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/impl/Rec.hs view
@@ -0,0 +1,3 @@+module Rec(A(..), B(..)) where+import A+import B
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/indef/A.hsig view
@@ -0,0 +1,2 @@+signature A(A(..)) where+import Rec
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/indef/B.hsig view
@@ -0,0 +1,2 @@+signature B(B(..)) where+import Rec
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/indef/C.hs view
@@ -0,0 +1,4 @@+module C where+import A+import B+x = A (B x)
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes4/indef/Rec.hsig view
@@ -0,0 +1,3 @@+signature Rec(A(..), B(..)) where+data A = A B+data B = B A
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes5/A.hs view
@@ -0,0 +1,2 @@+module A where+import Quxbaz
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes5/B.hs view
@@ -0,0 +1,2 @@+module B where+import Foobar -- fails
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes5/Includes5.cabal view
@@ -0,0 +1,25 @@+name:                Includes5+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library impl+  build-depends: base+  exposed-modules: Foobar, Quxbaz+  hs-source-dirs: impl+  default-language:    Haskell2010++library good+  build-depends: base, impl+  mixins: impl hiding (Foobar)+  exposed-modules: A+  default-language:    Haskell2010++library bad+  build-depends: base, impl, good+  mixins: impl hiding (Foobar)+  exposed-modules: B+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes5/impl/Foobar.hs view
@@ -0,0 +1,1 @@+module Foobar where
+ cabal/cabal-testsuite/PackageTests/Backpack/Includes5/impl/Quxbaz.hs view
@@ -0,0 +1,1 @@+module Quxbaz where
+ cabal/cabal-testsuite/PackageTests/Backpack/Indef1/Indef1.cabal view
@@ -0,0 +1,13 @@+name:                Indef1+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  exposed-modules:     Provide+  signatures: Map+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Indef1/Map.hsig view
@@ -0,0 +1,5 @@+{-# LANGUAGE RoleAnnotations #-}+signature Data.Map where+type role Map nominal representational+data Map k a+instance Functor (Map k)
+ cabal/cabal-testsuite/PackageTests/Backpack/Indef1/Provide.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Provide where+import Map+newtype MyMap a = MyMap (Map String a)+    deriving (Functor)
+ cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/p/P.hs view
@@ -0,0 +1,1 @@+module P where
+ cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/p/p.cabal view
@@ -0,0 +1,14 @@+name:                p+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.25++library+  mixins: containers (Data.Map as Map)+  exposed-modules: P+  reexported-modules: Map+  build-depends:       base, containers+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/q/Q.hs view
@@ -0,0 +1,2 @@+module Q where+import Map
+ cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/q/q.cabal view
@@ -0,0 +1,12 @@+name:                q+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Q+  build-depends:       base, p+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs view
@@ -0,0 +1,8 @@+module Main where++import Foo+import System.Exit++main :: IO ()+main | fooTest [] = exitSuccess+     | otherwise = exitFailure
+ cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/my.cabal view
@@ -0,0 +1,15 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++benchmark bench-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: benchmarks+    main-is:    bench-Foo.hs+    build-depends: base, my
+ cabal/cabal-testsuite/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal view
@@ -0,0 +1,20 @@+name: BenchmarkOptions+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >= 1.9.2++description:+    Check that Cabal passes the correct test options to test suites.++executable dummy+    main-is: test-BenchmarkOptions.hs+    build-depends: base++benchmark test-BenchmarkOptions+    main-is: test-BenchmarkOptions.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment ( getArgs )+import System.Exit ( exitFailure, exitSuccess )++main :: IO ()+main = do+    args <- getArgs+    if args == ["1", "2", "3"]+        then exitSuccess+        else putStrLn ("Got: " ++ show args) >> exitFailure
+ cabal/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs view
@@ -0,0 +1,29 @@+module PackageTests.BenchmarkStanza.Check where++import PackageTests.PackageTester++import Distribution.Version+import Distribution.Simple.LocalBuildInfo+import Distribution.Package+import Distribution.PackageDescription++suite :: TestM ()+suite = do+    assertOutputDoesNotContain "unknown section type"+        =<< cabal' "configure" []+    dist_dir <- distDir+    lbi <- liftIO $ getPersistBuildConfig dist_dir+    let anticipatedBenchmark = emptyBenchmark+            { benchmarkName = mkUnqualComponentName "dummy"+            , benchmarkInterface = BenchmarkExeV10 (mkVersion [1,0])+                                                   "dummy.hs"+            , benchmarkBuildInfo = emptyBuildInfo+                    { targetBuildDepends =+                            [ Dependency (mkPackageName "base") anyVersion ]+                    , hsSourceDirs = ["."]+                    }+            }+        gotBenchmark = head $ benchmarks (localPkgDescr lbi)+    assertEqual "parsed benchmark stanza does not match anticipated"+                            anticipatedBenchmark gotBenchmark+    return ()
+ cabal/cabal-testsuite/PackageTests/BenchmarkStanza/my.cabal view
@@ -0,0 +1,19 @@+name: BenchmarkStanza+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that Cabal recognizes the benchmark stanza defined below.++Library+    exposed-modules: MyLibrary+    build-depends: base++benchmark dummy+    main-is: dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs view
@@ -0,0 +1,22 @@+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where++import Test.Tasty.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+import Control.Exception+import Prelude hiding (catch)+++suite :: FilePath -> Assertion+suite ghcPath = do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive1") []+    result <- cabal_build spec ghcPath+    do+        assertEqual "cabal build should fail - see test-log.txt" False (successful result)+        let sb = "Could not find module `Prelude'"+        assertBool ("cabal output should be "++show sb) $+            sb `isInfixOf` outputText result+      `catch` \exc -> do+        putStrLn $ "Cabal result was "++show result+        throwIO (exc :: SomeException)
+ cabal/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    a library without base, it fails to find 'base' for the library.++---------------------------------------++build-depends: base++Library+    exposed-modules: MyLibrary+    build-depends: bytestring, pretty
+ cabal/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs view
@@ -0,0 +1,22 @@+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where++import Test.Tasty.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+import Control.Exception+import Prelude hiding (catch)+++suite :: FilePath -> Assertion+suite ghcPath = do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive2") []+    result <- cabal_build spec ghcPath+    do+        assertEqual "cabal build should fail - see test-log.txt" False (successful result)+        let sb = "Could not find module `Prelude'"+        assertBool ("cabal output should be "++show sb) $+            sb `isInfixOf` outputText result+      `catch` \exc -> do+        putStrLn $ "Cabal result was "++show result+        throwIO (exc :: SomeException)
+ cabal/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    an executable without base, it fails to find 'base' for the executable++---------------------------------------++build-depends: base++Executable lemon+    main-is: lemon.hs+    build-depends: bytestring, pretty
+ cabal/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++main = do+    putStrLn (render (text "foo"))+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/my.cabal view
@@ -0,0 +1,24 @@+name: InternalLibrary0+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that with 'cabal-version:' containing versions less than 1.7, we do *not*+    have the new behaviour to allow executables to refer to the library defined+    in the same module.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, pretty, InternalLibrary0
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs view
@@ -0,0 +1,6 @@+import Text.PrettyPrint+import MyLibrary++main = do+    putStrLn (render (text "foo"))+    myLibFunc
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new (in >= 1.7.1) ability to allow executables to refer to+    the library defined in the same module.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, pretty, InternalLibrary1
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs view
@@ -0,0 +1,6 @@+import Text.PrettyPrint+import MyLibrary++main = do+    putStrLn (render (text "foo"))+    myLibFunc
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc internal"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary2+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name and version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, pretty, InternalLibrary2
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs view
@@ -0,0 +1,6 @@+import Text.PrettyPrint+import MyLibrary++main = do+    putStrLn (render (text "foo"))+    myLibFunc
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc installed"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary2+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name and version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc internal"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary3+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name, but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, pretty, InternalLibrary3
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs view
@@ -0,0 +1,6 @@+import Text.PrettyPrint+import MyLibrary++main = do+    putStrLn (render (text "foo"))+    myLibFunc
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc installed"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary3+version: 0.2+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc internal"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary4+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that we can explicitly say we want InternalLibrary4-0.2+    and it will give us the *installed* version 0.2 instead of the internal 0.1.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, pretty, InternalLibrary4 >= 0.2
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs view
@@ -0,0 +1,6 @@+import Text.PrettyPrint+import MyLibrary++main = do+    putStrLn (render (text "foo"))+    myLibFunc
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc installed"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary4+version: 0.2+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty
+ cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal view
@@ -0,0 +1,31 @@+name: SameDepsAllRound+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+synopsis: Same dependencies all round+category: PackageTests+build-type: Simple++description:+    Check for the "old build-dep behaviour" namely that we get the same+    package dependencies on all build targets, even if different ones+    were specified for different targets+    .+    Here all .hs files use the three packages mentioned, so this shows+    that build-depends is not target-specific.  This is the behaviour+    we want when cabal-version contains versions less than 1.7.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring++Executable lemon+    main-is: lemon.hs+    build-depends: pretty++Executable pineapple+    main-is: pineapple.hs
+ cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++main = do+    putStrLn (render (text "foo"))+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++main = do+    putStrLn (render (text "foo"))+    let text = "pineapple"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++main = do+    putStrLn (render (text "foo"))+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal view
@@ -0,0 +1,22 @@+name: TargetSpecificDeps1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring, pretty
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs view
@@ -0,0 +1,5 @@+import qualified Data.ByteString.Char8 as C++main = do+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal view
@@ -0,0 +1,24 @@+name: TargetSpecificDeps1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target+    This one is a control against TargetSpecificDeps1 - it is correct and should+    succeed.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++myLibFunc :: IO ()+myLibFunc = do+    putStrLn (render (text "foo"))+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint++main = do+    putStrLn (render (text "foo"))+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal view
@@ -0,0 +1,22 @@+name: test+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, pretty++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring
+ cabal/cabal-testsuite/PackageTests/BuildTargetErrors/BuildTargetErrors.cabal view
@@ -0,0 +1,10 @@+name: BuildTargetErrors+version: 1.0+build-type: Simple+cabal-version: >= 1.9++library++executable not-buildable-exe+    main-is: Main.hs+    buildable: False
+ cabal/cabal-testsuite/PackageTests/BuildTargetErrors/Main.hs view
@@ -0,0 +1,1 @@+main = return ()
+ cabal/cabal-testsuite/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs view
@@ -0,0 +1,6 @@+module Dummy2 where++import Distribution.TestSuite (Test)++tests :: IO [Test]+tests = return []
+ cabal/cabal-testsuite/PackageTests/BuildToolsPath/A.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-}+module A where++a :: String+a = "0000"
+ cabal/cabal-testsuite/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment+import System.IO++main :: IO ()+main = do+  (_:source:target:_) <- getArgs+  let f '0' = '1'+      f c = c+  writeFile target . map f  =<< readFile source
+ cabal/cabal-testsuite/PackageTests/BuildToolsPath/build-tools-path.cabal view
@@ -0,0 +1,25 @@+name:                build-tools-path+version:             0.1.0.0+synopsis:            Checks build-tools are put in PATH+license:             BSD3+category:            Testing+build-type:          Simple+cabal-version:       >=1.10++executable             my-custom-preprocessor+  main-is:             MyCustomPreprocessor.hs+  build-depends:       base, directory+  default-language:    Haskell2010++library+  exposed-modules:     A+  build-depends:       base+  build-tools:         my-custom-preprocessor+  -- ^ Note the internal dependency.+  default-language:    Haskell2010++executable             hello-world+  main-is:             Hello.hs+  build-depends:       base, build-tools-path+  default-language:    Haskell2010+  hs-source-dirs:      hello
+ cabal/cabal-testsuite/PackageTests/BuildToolsPath/hello/Hello.hs view
@@ -0,0 +1,6 @@+module Main where++import A++main :: IO ()+main = putStrLn a
+ cabal/cabal-testsuite/PackageTests/BuildableField/BuildableField.cabal view
@@ -0,0 +1,16 @@+name: BuildableField+version: 0.1.0.0+cabal-version: >=1.2+build-type: Simple+license: BSD3++flag build-exe+  default: True++library++executable my-executable+  build-depends: base, unavailable-package+  main-is: Main.hs+  if !flag(build-exe)+    buildable: False
+ cabal/cabal-testsuite/PackageTests/BuildableField/Main.hs view
@@ -0,0 +1,4 @@+import UnavailableModule++main :: IO ()+main = putStrLn "Hello"
+ cabal/cabal-testsuite/PackageTests/CMain/Bar.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Bar where++bar :: IO ()+bar = return ()++foreign export ccall bar :: IO ()
+ cabal/cabal-testsuite/PackageTests/CMain/foo.c view
@@ -0,0 +1,13 @@+#include <stdio.h>+#include "HsFFI.h"++#ifdef __GLASGOW_HASKELL__+#include "Bar_stub.h"+#endif++int main(int argc, char **argv) {+    hs_init(&argc, &argv);+    bar();+    printf("Hello world!");+    return 0;+}
+ cabal/cabal-testsuite/PackageTests/CMain/my.cabal view
@@ -0,0 +1,10 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++executable foo+    main-is:    foo.c+    other-modules: Bar+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/CaretOperator/Check.hs view
@@ -0,0 +1,34 @@+module PackageTests.CaretOperator.Check where++import PackageTests.PackageTester++import Distribution.Version+import Distribution.Simple.LocalBuildInfo+import Distribution.Package+import Distribution.PackageDescription+import Language.Haskell.Extension (Language(..))+++suite :: TestM ()+suite = do+    assertOutputDoesNotContain "Parse of field 'build-depends' failed"+        =<< cabal' "configure" []+    dist_dir <- distDir+    lbi <- liftIO $ getPersistBuildConfig dist_dir++    let anticipatedLib = emptyLibrary+           { libBuildInfo = emptyBuildInfo+               { defaultLanguage = Just Haskell2010+               , targetBuildDepends =+                     [ Dependency (mkPackageName "base")+                       (withinVersion (mkVersion [4]))+                     , Dependency (mkPackageName "pretty")+                       (majorBoundVersion (mkVersion [1,1,1,0]))+                     ]+               , hsSourceDirs = ["."]+               }+           }+        Just gotLib = library (localPkgDescr lbi)+    assertEqual "parsed library component does not match anticipated"+                            anticipatedLib gotLib+    return ()
+ cabal/cabal-testsuite/PackageTests/CaretOperator/my.cabal view
@@ -0,0 +1,15 @@+name: CaretOperator+version: 0+license: BSD3+author: HVR+category: PackageTests+build-type: Simple+cabal-version: >= 1.25++description:+    Check that Cabal recognizes the caret operator++Library+    default-language: Haskell2010+    build-depends: base == 4.*+                 , pretty ^>= 1.1.1.0
+ cabal/cabal-testsuite/PackageTests/Configure/.gitignore view
@@ -0,0 +1,6 @@+X11.buildinfo+autom4te.cache/+*.log+*.status+include/HsX11Config.h+configure
+ cabal/cabal-testsuite/PackageTests/Configure/A.hs view
@@ -0,0 +1,1 @@+module A where
+ cabal/cabal-testsuite/PackageTests/Configure/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks autoconfUserHooks
+ cabal/cabal-testsuite/PackageTests/Configure/configure.ac view
@@ -0,0 +1,20 @@+AC_INIT([Haskell zlib package], [1.1], [libraries@haskell.org], [zlib])++# Safety check: Ensure that we are in the correct source directory.+AC_CONFIG_SRCDIR([zlib.cabal])++# Header file to place defines in+AC_CONFIG_HEADERS([include/HsZlibConfig.h])++# Check for zlib include+AC_CHECK_HEADER(zlib.h, [ZLIB_HEADER=yes], [], [])++# Build the package if we found X11 stuff+if test "x$ZLIB_HEADER" = "x"+then BUILD_PACKAGE_BOOL=False+else BUILD_PACKAGE_BOOL=True+fi+AC_SUBST([BUILD_PACKAGE_BOOL])++AC_CONFIG_FILES([zlib.buildinfo])+AC_OUTPUT
+ cabal/cabal-testsuite/PackageTests/Configure/include/HsZlibConfig.h.in view
@@ -0,0 +1,49 @@+/* include/HsZlibConfig.h.in.  Generated from configure.ac by autoheader.  */++/* Define to 1 if you have the <inttypes.h> header file. */+#undef HAVE_INTTYPES_H++/* Define to 1 if you have the <memory.h> header file. */+#undef HAVE_MEMORY_H++/* Define to 1 if you have the <stdint.h> header file. */+#undef HAVE_STDINT_H++/* Define to 1 if you have the <stdlib.h> header file. */+#undef HAVE_STDLIB_H++/* Define to 1 if you have the <strings.h> header file. */+#undef HAVE_STRINGS_H++/* Define to 1 if you have the <string.h> header file. */+#undef HAVE_STRING_H++/* Define to 1 if you have the <sys/stat.h> header file. */+#undef HAVE_SYS_STAT_H++/* Define to 1 if you have the <sys/types.h> header file. */+#undef HAVE_SYS_TYPES_H++/* Define to 1 if you have the <unistd.h> header file. */+#undef HAVE_UNISTD_H++/* Define to the address where bug reports for this package should be sent. */+#undef PACKAGE_BUGREPORT++/* Define to the full name of this package. */+#undef PACKAGE_NAME++/* Define to the full name and version of this package. */+#undef PACKAGE_STRING++/* Define to the one symbol short name of this package. */+#undef PACKAGE_TARNAME++/* Define to the home page for this package. */+#undef PACKAGE_URL++/* Define to the version of this package. */+#undef PACKAGE_VERSION++/* Define to 1 if you have the ANSI C header files. */+#undef STDC_HEADERS
+ cabal/cabal-testsuite/PackageTests/Configure/zlib.buildinfo.in view
@@ -0,0 +1,3 @@+buildable: @BUILD_PACKAGE_BOOL@+cc-options: @CFLAGS@+ld-options: @LIBS@
+ cabal/cabal-testsuite/PackageTests/Configure/zlib.cabal view
@@ -0,0 +1,12 @@+name:                zlib+version:             1.1+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Configure+cabal-version:       >=1.10++library+  exposed-modules:     A+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/Bad.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/Exe.cabal view
@@ -0,0 +1,18 @@+name:                Exe+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable goodexe+  main-is:             Good.hs+  build-depends:       base+  default-language:    Haskell2010++-- We deliberately don't configure badexe, so that we can build ONLY goodexe+executable badexe+  main-is:             Bad.hs+  build-depends:       totally-impossible-dependency-to-fill == 10000.25.6+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/Good.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "OK"
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/Lib.cabal view
@@ -0,0 +1,18 @@+name:                Lib+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library sublib+  build-depends:       base+  exposed-modules:     Lib+  default-language:    Haskell2010++executable exe+  main-is:             Exe.hs+  build-depends:       base, sublib+  hs-source-dirs:      exe+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/Lib.hs view
@@ -0,0 +1,2 @@+module Lib where+lib = "OK"
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs view
@@ -0,0 +1,2 @@+import Lib+main = putStrLn lib
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/Lib.hs view
@@ -0,0 +1,2 @@+module Lib where+lib = "OK"
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/Test.cabal view
@@ -0,0 +1,18 @@+name:                test-for-cabal+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Lib+  build-depends:       base+  default-language:    Haskell2010++test-suite testsuite+  build-depends: test-for-cabal, testlib, base+  type: exitcode-stdio-1.0+  main-is:             Test.hs+  hs-source-dirs:      tests
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs view
@@ -0,0 +1,3 @@+module TestLib where+import Lib+testlib = lib
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/testlib/testlib.cabal view
@@ -0,0 +1,12 @@+name:                testlib+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     TestLib+  build-depends:       test-for-cabal, base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/tests/Test.hs view
@@ -0,0 +1,2 @@+import TestLib+main = putStrLn testlib
+ cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/Main2.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/myprog.cabal view
@@ -0,0 +1,15 @@+name:                myprog+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable myprog+  main-is:             Main.hs+  build-depends:       base++executable myprog2+  main-is:             Main2.hs+  build-depends:       base
+ cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/Main.hs view
@@ -0,0 +1,2 @@+import P+main = print p
+ cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/p.cabal view
@@ -0,0 +1,17 @@+name:                p+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     P+  hs-source-dirs:      src+  build-depends:       base+  default-language:    Haskell2010++executable pprog+  main-is:             Main.hs+  build-depends:       p
+ cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/src/P.hs view
@@ -0,0 +1,2 @@+module P where+p = 12
+ cabal/cabal-testsuite/PackageTests/CustomPreProcess/A.pre view
@@ -0,0 +1,4 @@+module A where++a :: String+a = "hello from A"
+ cabal/cabal-testsuite/PackageTests/CustomPreProcess/Hello.hs view
@@ -0,0 +1,6 @@+module Main where++import A++main :: IO ()+main = putStrLn a
+ cabal/cabal-testsuite/PackageTests/CustomPreProcess/MyCustomPreprocessor.hs view
@@ -0,0 +1,9 @@+module Main where++import System.Directory+import System.Environment++main :: IO ()+main = do+  (source:target:_) <- getArgs+  copyFile source target
+ cabal/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -Wall #-}++import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PreProcess+import Distribution.Simple.Utils+import System.Exit+import System.FilePath+import System.Process (rawSystem)++main :: IO ()+main = defaultMainWithHooks+       simpleUserHooks { hookedPreProcessors = [("pre", myCustomPreprocessor)] }+  where+    myCustomPreprocessor :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+    myCustomPreprocessor _bi lbi _clbi =+      PreProcessor {+        platformIndependent = True,+        runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+          do info verbosity ("Preprocessing " ++ inFile ++ " to " ++ outFile)+             callProcess progPath [inFile, outFile]+        }+      where+        builddir = buildDir lbi+        progName = "my-custom-preprocessor"+        progPath = builddir </> progName </> progName++    -- Backwards compat with process < 1.2.+    callProcess :: FilePath -> [String] -> IO ()+    callProcess path args =+      do exitCode <- rawSystem path args+         case exitCode of ExitSuccess       -> return ()+                          f@(ExitFailure _) -> fail $ "callProcess " ++ show path+                                               ++ " " ++ show args ++ " failed: "+                                               ++ show f
+ cabal/cabal-testsuite/PackageTests/CustomPreProcess/internal-preprocessor-test.cabal view
@@ -0,0 +1,31 @@+name:                internal-preprocessor-test+version:             0.1.0.0+synopsis:            Internal custom preprocessor example.+description:         See https://github.com/haskell/cabal/issues/1541#issuecomment-30155513+license:             GPL-3+author:              Mikhail Glushenkov+maintainer:          mikhail.glushenkov@gmail.com+category:            Testing+build-type:          Custom+cabal-version:       >=1.10++-- Note that exe comes before the library. +-- The reason is backwards compat: old versions of Cabal (< 1.18)+-- don't have a proper component build graph, so components are+-- built in declaration order.+executable             my-custom-preprocessor+  main-is:             MyCustomPreprocessor.hs+  build-depends:       base, directory+  default-language:    Haskell2010++library+  exposed-modules:     A+  build-depends:       base+  build-tools:         my-custom-preprocessor+  -- ^ Note the internal dependency.+  default-language:    Haskell2010++executable             hello-world+  main-is:             Hello.hs+  build-depends:       base, internal-preprocessor-test+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/DeterministicAr/Check.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module PackageTests.DeterministicAr.Check where++import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Char (isSpace)+import PackageTests.PackageTester+import System.IO++import Distribution.Compiler              (CompilerFlavor(..), CompilerId(..))+import Distribution.Package               (getHSLibraryName)+import Distribution.Version               (mkVersion)+import Distribution.Simple.Compiler       (compilerId)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, localUnitId)++suite :: TestM ()+suite = do+    cabal_build []+    dist_dir <- distDir+    lbi <- liftIO $ getPersistBuildConfig dist_dir+    liftIO $ checkMetadata lbi (dist_dir </> "build")++-- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata+checkMetadata :: LocalBuildInfo -> FilePath -> IO ()+checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> do+    hFileSize h >>= checkArchive h+  where+    path = dir </> "lib" ++ getHSLibraryName (localUnitId lbi) ++ ".a"++    _ghc_7_10 = case compilerId (compiler lbi) of+      CompilerId GHC version | version >= mkVersion [7, 10]  -> True+      _                                                      -> False++    checkError msg = assertFailure (+        "PackageTests.DeterministicAr.checkMetadata: " ++ msg +++        " in " ++ path) >> undefined+    archLF = "!<arch>\x0a" -- global magic, 8 bytes+    x60LF = "\x60\x0a" -- header magic, 2 bytes+    metadata = BS.concat+        [ "0           " -- mtime, 12 bytes+        , "0     " -- UID, 6 bytes+        , "0     " -- GID, 6 bytes+        , "0644    " -- mode, 8 bytes+        ]+    headerSize = 60++    -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details+    checkArchive :: Handle -> Integer -> IO ()+    checkArchive h archiveSize = do+        global <- BS.hGet h (BS.length archLF)+        unless (global == archLF) $ checkError "Bad global header"+        checkHeader (toInteger $ BS.length archLF)++      where+        checkHeader :: Integer -> IO ()+        checkHeader offset = case compare offset archiveSize of+            EQ -> return ()+            GT -> checkError (atOffset "Archive truncated")+            LT -> do+                header <- BS.hGet h headerSize+                unless (BS.length header == headerSize) $+                    checkError (atOffset "Short header")+                let magic = BS.drop 58 header+                unless (magic == x60LF) . checkError . atOffset $+                    "Bad magic " ++ show magic ++ " in header"++                unless (metadata == BS.take 32 (BS.drop 16 header))+                    . checkError . atOffset $ "Metadata has changed"++                let size = BS.take 10 $ BS.drop 48 header+                objSize <- case reads (BS8.unpack size) of+                    [(n, s)] | all isSpace s -> return n+                    _ -> checkError (atOffset "Bad file size in header")++                let nextHeader = offset + toInteger headerSize ++                        -- Odd objects are padded with an extra '\x0a'+                        if odd objSize then objSize + 1 else objSize+                hSeek h AbsoluteSeek nextHeader+                checkHeader nextHeader++          where+            atOffset msg = msg ++ " at offset " ++ show offset
+ cabal/cabal-testsuite/PackageTests/DeterministicAr/Lib.hs view
@@ -0,0 +1,5 @@+module Lib where++dummy :: IO ()+dummy = return ()+
+ cabal/cabal-testsuite/PackageTests/DeterministicAr/my.cabal view
@@ -0,0 +1,17 @@+name: DeterministicAr+version: 0+license: BSD3+cabal-version: >= 1.9.1+author: Liyang HU+stability: stable+category: PackageTests+build-type: Simple++description:+    Ensure our GNU ar -D emulation (#1537) works as advertised: check that+    all metadata in the resulting .a archive match the default.++Library+    exposed-modules: Lib+    build-depends: base+
+ cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal view
@@ -0,0 +1,25 @@+name:                DuplicateModuleName+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Foo+  hs-source-dirs: src+  build-depends:       base, Cabal+  default-language:    Haskell2010++test-suite foo+  type: detailed-0.9+  test-module:         Foo+  hs-source-dirs: tests+  build-depends: base, Cabal, DuplicateModuleName++test-suite foo2+  type: detailed-0.9+  test-module:         Foo+  hs-source-dirs: tests2+  build-depends: base, Cabal, DuplicateModuleName
+ cabal/cabal-testsuite/PackageTests/DuplicateModuleName/src/Foo.hs view
@@ -0,0 +1,12 @@+module Foo where++import Distribution.TestSuite++tests :: IO [Test]+tests = return [Test $ TestInstance+          { run = return (Finished (Fail "A"))+          , name = "test A"+          , tags = []+          , options = []+          , setOption = \_ _-> Left "No Options"+          }]
+ cabal/cabal-testsuite/PackageTests/DuplicateModuleName/tests/Foo.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE PackageImports #-}+module Foo where++import Distribution.TestSuite+import qualified "DuplicateModuleName" Foo as T++tests :: IO [Test]+tests = do+    r <- T.tests+    return $ [Test $ TestInstance+          { run = return (Finished (Fail "B"))+          , name = "test B"+          , tags = []+          , options = []+          , setOption = \_ _-> Left "No Options"+          }] ++ r++this_is_test = True
+ cabal/cabal-testsuite/PackageTests/DuplicateModuleName/tests2/Foo.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE PackageImports #-}+module Foo where++import Distribution.TestSuite+import qualified "DuplicateModuleName" Foo as T++tests :: IO [Test]+tests = do+    r <- T.tests+    return $ [Test $ TestInstance+          { run = return (Finished (Fail "C"))+          , name = "test C"+          , tags = []+          , options = []+          , setOption = \_ _-> Left "No Options"+          }] ++ r++this_is_test2 = True
+ cabal/cabal-testsuite/PackageTests/EmptyLib/empty/empty.cabal view
@@ -0,0 +1,6 @@+name: emptyLib+Cabal-version: >= 1.2+version: 1.0+build-type: Simple++Library
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/Check.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE RecordWildCards #-}+module PackageTests.ForeignLibs.Check where++import Control.Exception+import System.Environment+import System.FilePath+import System.IO.Error++import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Builtin+import Distribution.Simple.Program.Types+import Distribution.System+import Distribution.Verbosity+import Distribution.Version++import PackageTests.PackageTester++-- Foreign libraries don't work with GHC 7.6 and earlier+suite :: TestM ()+suite = whenGhcVersion (>= mkVersion [7,8]) . withPackageDb $ do+    cabal_install []+    dist_dir <- distDir+    pkg_dir <- packageDir+    lbi <- liftIO $ getPersistBuildConfig dist_dir+    let installDirs = absoluteInstallDirs (localPkgDescr lbi) lbi NoCopyDest++    -- Link a C program against the library+    (gcc, _) <- liftIO $ requireProgram normal gccProgram (withPrograms lbi)+    _ <- run (Just pkg_dir) (programPath gcc) [+        "-o", "uselib"+      , "UseLib.c"+      , "-l", "myforeignlib"+      , "-L", flibdir installDirs+      ]++    -- Run the C program+    let ldPath = case hostPlatform lbi of+                   Platform _ OSX     -> "DYLD_LIBRARY_PATH"+                   Platform _ Windows -> "PATH"+                   Platform _ _other  -> "LD_LIBRARY_PATH"+    oldLdPath <- liftIO $ getEnv' ldPath+    withEnv [ (ldPath, Just $ flibdir installDirs ++ [searchPathSeparator] ++ oldLdPath) ] $ do+        result <- run (Just pkg_dir)+                      (pkg_dir </> "uselib")+                      []+        assertOutputContains "5678" result+        assertOutputContains "189" result++getEnv' :: String -> IO String+getEnv' = handle handler . getEnv+  where+    handler e = if isDoesNotExistError e+                  then return ""+                  else throw e
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/LICENSE view
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/UseLib.c view
@@ -0,0 +1,9 @@+#include <stdio.h>++int main()+{+  myForeignLibInit();+  sayHi();+  myForeignLibExit();+  return 0;+}
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c view
@@ -0,0 +1,23 @@+#include <stdlib.h>+#include "HsFFI.h"++HsBool myForeignLibInit(void){+  int argc = 2;+  char *argv[] = { "+RTS", "-A32m", NULL };+  char **pargv = argv;++  // Initialize Haskell runtime+  hs_init(&argc, &pargv);++  // do any other initialization here and+  // return false if there was a problem+  return HS_BOOL_TRUE;+}++void myForeignLibExit(void){+  hs_exit();+}++int cFoo2() {+   return 1234;+}
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal view
@@ -0,0 +1,26 @@+name:                my-foreign-lib+version:             0.1.0.0+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     MyForeignLib.AnotherVal+  build-depends:       base+  hs-source-dirs:      src+  default-language:    Haskell2010++foreign-library myforeignlib+  type:                native-shared++  if os(windows)+    options: standalone++  other-modules:       MyForeignLib.Hello+                       MyForeignLib.SomeBindings+  build-depends:       base, my-foreign-lib+  hs-source-dirs:      src+  c-sources:           csrc/MyForeignLibWrapper.c+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/AnotherVal.hs view
@@ -0,0 +1,3 @@+module MyForeignLib.AnotherVal where++anotherVal = 189
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs view
@@ -0,0 +1,13 @@+-- | Module with single foreign export+module MyForeignLib.Hello (sayHi) where++import MyForeignLib.SomeBindings+import MyForeignLib.AnotherVal++foreign export ccall sayHi :: IO ()++-- | Say hi!+sayHi :: IO ()+sayHi = putStrLn $+     "Hi from a foreign library! Foo has value " ++ show valueOfFoo+  ++ " and anotherVal has value " ++ show anotherVal
+ cabal/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/SomeBindings.hsc view
@@ -0,0 +1,10 @@+-- | Module that needs the hsc2hs preprocessor+module MyForeignLib.SomeBindings where++#define FOO 1++#ifdef FOO+-- | Value guarded by a CPP flag+valueOfFoo :: Int+valueOfFoo = 5678+#endif
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal view
@@ -0,0 +1,11 @@+name:                SameDirectory+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/ghc view
@@ -0,0 +1,6 @@+#!/bin/sh+if [ -z "$WITH_GHC" ]; then+    echo "Need to set WITH_GHC"+    exit 1+fi+exec "$WITH_GHC" "$@"
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg view
@@ -0,0 +1,3 @@+#!/bin/sh+echo "GHC package manager version 9999999"+exit 0
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal view
@@ -0,0 +1,11 @@+name:                SameDirectory+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10 view
@@ -0,0 +1,6 @@+#!/bin/sh+if [ -z "$WITH_GHC" ]; then+    echo "Need to set WITH_GHC"+    exit 1+fi+exec "$WITH_GHC" "$@"
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10 view
@@ -0,0 +1,3 @@+#!/bin/sh+echo "GHC package manager version 9999999"+exit 0
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal view
@@ -0,0 +1,11 @@+name:                SameDirectory+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10 view
@@ -0,0 +1,6 @@+#!/bin/sh+if [ -z "$WITH_GHC" ]; then+    echo "Need to set WITH_GHC"+    exit 1+fi+exec "$WITH_GHC" "$@"
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10 view
@@ -0,0 +1,3 @@+#!/bin/sh+echo "GHC package manager version 9999999"+exit 0
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal view
@@ -0,0 +1,11 @@+name:                SameDirectory+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/bin/ghc view
@@ -0,0 +1,6 @@+#!/bin/sh+if [ -z "$WITH_GHC" ]; then+    echo "Need to set WITH_GHC"+    exit 1+fi+exec "$WITH_GHC" "$@"
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg view
@@ -0,0 +1,3 @@+#!/bin/sh+echo "GHC package manager version 9999999"+exit 0
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal view
@@ -0,0 +1,11 @@+name:                SameDirectory+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10 view
@@ -0,0 +1,6 @@+#!/bin/sh+if [ -z "$WITH_GHC" ]; then+    echo "Need to set WITH_GHC"+    exit 1+fi+exec "$WITH_GHC" "$@"
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10 view
@@ -0,0 +1,3 @@+#!/bin/sh+echo "GHC package manager version 9999999"+exit 0
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal view
@@ -0,0 +1,11 @@+name:                SameDirectory+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10 view
@@ -0,0 +1,6 @@+#!/bin/sh+if [ -z "$WITH_GHC" ]; then+    echo "Need to set WITH_GHC"+    exit 1+fi+exec "$WITH_GHC" "$@"
+ cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10 view
@@ -0,0 +1,3 @@+#!/bin/sh+echo "GHC package manager version 9999999"+exit 0
+ cabal/cabal-testsuite/PackageTests/Haddock/CPP.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++module CPP where++#define HIDING  hiding+#define NEEDLES needles++-- | For HIDING NEEDLES.+data Haystack = Haystack
+ cabal/cabal-testsuite/PackageTests/Haddock/Literate.lhs view
@@ -0,0 +1,4 @@+> module Literate where++> -- | For hiding needles.+> data Haystack = Haystack
+ cabal/cabal-testsuite/PackageTests/Haddock/NoCPP.hs view
@@ -0,0 +1,8 @@+module NoCPP (Haystack) where++-- | For hiding needles.+data Haystack = Haystack++-- | Causes a build failure if the CPP language extension is enabled.+stringGap = "Foo\+\Bar"
+ cabal/cabal-testsuite/PackageTests/Haddock/Simple.hs view
@@ -0,0 +1,4 @@+module Simple where++-- | For hiding needles.+data Haystack = Haystack
+ cabal/cabal-testsuite/PackageTests/Haddock/my.cabal view
@@ -0,0 +1,16 @@+name: Haddock+version: 0.1+license: BSD3+author: Iain Nicol+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that Cabal successfully invokes Haddock.++Library+    exposed-modules: CPP, Literate, NoCPP, Simple+    other-extensions: CPP+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/HaddockNewline/A.hs view
@@ -0,0 +1,1 @@+module A where
+ cabal/cabal-testsuite/PackageTests/HaddockNewline/ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for HaddockNewline++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ cabal/cabal-testsuite/PackageTests/HaddockNewline/HaddockNewline.cabal view
@@ -0,0 +1,20 @@+name:                HaddockNewline+version:             0.1.0.0+synopsis:            This has a+                     newline yo.+-- description:         +license:             BSD3+license-file:        LICENSE+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  exposed-modules:     A+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base+  -- hs-source-dirs:      +  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/HaddockNewline/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Edward Z. Yang++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Edward Z. Yang nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ cabal/cabal-testsuite/PackageTests/HaddockNewline/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/exe/Main.hs view
@@ -0,0 +1,2 @@+import Foo+main = print (foo 23)
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/foo.cabal view
@@ -0,0 +1,18 @@+name:                foo+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.23++library foo-internal+  exposed-modules:     Foo+  build-depends:       base+  hs-source-dirs:      src+  default-language:    Haskell2010++executable foo+  main-is: Main.hs+  build-depends:       base, foo-internal+  hs-source-dirs: exe
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/src/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where+{-# NOINLINE foo #-}+foo :: Int -> Int+foo x = x + 23
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/fooexe/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Foo++main :: IO ()+main = print foo
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/fooexe/fooexe.cabal view
@@ -0,0 +1,12 @@+name:                fooexe+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable fooexe+  main-is:             Main.hs+  build-depends:       base, foolib+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/Foo.hs view
@@ -0,0 +1,3 @@+module Foo where+import Internal+foo = internal + 2
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/foolib.cabal view
@@ -0,0 +1,17 @@+name:                foolib+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.23++library foolib-internal+  exposed-modules:     Internal+  hs-source-dirs:      private+  build-depends:       base++library+  exposed-modules:     Foo+  build-depends:       base, foolib-internal+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/private/Internal.hs view
@@ -0,0 +1,4 @@+module Internal where+{-# NOINLINE internal #-}+internal :: Int+internal = 23
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/p/Foo.hs view
@@ -0,0 +1,2 @@+import Q+main = putStrLn q
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/p/p.cabal view
@@ -0,0 +1,23 @@+name:                p+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.23++library q+  build-depends:       base+  exposed-modules:     Q+  hs-source-dirs:      q+  default-language:    Haskell2010++library+  build-depends:       base, q+  exposed-modules:     P+  hs-source-dirs:      p+  default-language:    Haskell2010++executable foo+  build-depends:       base, q+  main-is:             Foo.hs
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/p/p/P.hs view
@@ -0,0 +1,3 @@+module P where+import Q+p = "P: " ++ q
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/p/q/Q.hs view
@@ -0,0 +1,2 @@+module Q where+q = "I AM THE ONE"
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/q/Q.hs view
@@ -0,0 +1,2 @@+module Q where+q = "DO NOT SEE ME"
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/q/q.cabal view
@@ -0,0 +1,12 @@+name:                q+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Q+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/r/R.hs view
@@ -0,0 +1,3 @@+module R where+import P+r = "R: " ++ p
+ cabal/cabal-testsuite/PackageTests/InternalLibraries/r/r.cabal view
@@ -0,0 +1,12 @@+name:                r+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     R+  build-depends:       base, p+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Macros/A.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+import C+#ifdef VERSION_filepath+#error "Should not see macro from library"+#endif+#ifdef VERSION_containers+#error "Should not see macro from executable macros-b"+#endif+main = do+    putStrLn CURRENT_COMPONENT_ID
+ cabal/cabal-testsuite/PackageTests/Macros/B.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+import C+#ifdef VERSION_filepath+#error "Should not see macro from library"+#endif+#ifdef VERSION_directory+#error "Should not see macro from executable macros-a"+#endif+main = do+    putStrLn CURRENT_COMPONENT_ID
+ cabal/cabal-testsuite/PackageTests/Macros/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ cabal/cabal-testsuite/PackageTests/Macros/macros.cabal view
@@ -0,0 +1,23 @@+name:                macros+version:             0.1.0.0+license:             BSD3+license-file:        LICENSE+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     C+  hs-source-dirs:      src+  build-depends:       base, filepath++executable macros-a+  main-is:             A.hs+  build-depends:       base, directory, macros+  default-language:    Haskell2010++executable macros-b+  main-is:             B.hs+  build-depends:       base, containers, macros+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Macros/src/C.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+module C where+#ifdef VERSION_directory+#error "Should not see macro from executable macros-a"+#endif+#ifdef VERSION_containers+#error "Should not see macro from executable macros-b"+#endif+c :: String+c = CURRENT_COMPONENT_ID
+ cabal/cabal-testsuite/PackageTests/Options.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}++module PackageTests.Options+    ( OptionEnableAllTests(..)+    ) where++import Data.Typeable (Typeable)++import Test.Tasty.Options (IsOption(..), flagCLParser, safeRead)++newtype OptionEnableAllTests = OptionEnableAllTests Bool+  deriving Typeable++instance IsOption OptionEnableAllTests where+  defaultValue   = OptionEnableAllTests False+  parseValue     = fmap OptionEnableAllTests . safeRead+  optionName     = return "enable-all-tests"+  optionHelp     = return "Enable all tests"+  optionCLParser = flagCLParser Nothing (OptionEnableAllTests True)
+ cabal/cabal-testsuite/PackageTests/OrderFlags/Foo.hs view
@@ -0,0 +1,8 @@+module Foo where++x :: IO Int+x = return 5++f :: IO Int+f = do x+       return 3
+ cabal/cabal-testsuite/PackageTests/OrderFlags/my.cabal view
@@ -0,0 +1,20 @@+name: OrderFlags+version: 0.1+license: BSD3+author: Oleksandr Manzyuk+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >=1.9.2++description:+    Check that Cabal correctly orders flags that are passed to GHC.++library+    exposed-modules: Foo+    build-depends: base++    ghc-options: -Wall -Werror++    if impl(ghc >= 6.12.1)+        ghc-options: -fno-warn-unused-do-bind
+ cabal/cabal-testsuite/PackageTests/PackageTester.hs view
@@ -0,0 +1,832 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE CPP #-}++module PackageTests.PackageTester+    ( PackageSpec+    , SuiteConfig(..)+    , TestConfig(..)+    , Result(..)+    , TestM+    , runTestM++    -- * Paths+    , ghcPath+    , withGhcPath+    , ghcPkgPath+    , withGhcPkgPath++    , packageDir+    , distDir+    , relativeDistDir+    , sharedDBPath+    , getWithGhcPath+    , prefixDir++    -- * Running cabal commands+    , cabal+    , cabal'+    , cabal_build+    , cabal_install+    , cabal_install_with_docs+    , ghcPkg+    , ghcPkg'+    , compileSetup+    , shell+    , run+    , runExe+    , runExe'+    , runInstalledExe+    , runInstalledExe'+    , rawRun+    , rawCompileSetup+    , withPackage+    , withEnv+    , withPackageDb++    -- * Polymorphic versions of HUnit functions+    , assertFailure+    , assertEqual+    , assertBool+    , shouldExist+    , shouldNotExist++    -- * Test helpers+    , shouldFail+    , whenGhcVersion+    , assertOutputContains+    , assertOutputDoesNotContain+    , assertFindInFile+    , concatOutput+    , ghcFileModDelay+    , withSymlink++    -- * Test trees+    , TestTreeM+    , runTestTree+    , testTree+    , testTreeSteps+    , testTreeSub+    , testTreeSubSteps+    , testTree'+    , groupTests+    , mapTestTrees+    , testWhen+    , testUnless+    , unlessWindows+    , hasSharedLibraries+    , hasCabalForGhc++    , getPersistBuildConfig++    -- Common utilities+    , module System.FilePath+    , module Data.List+    , module Control.Monad.IO.Class+    , module Text.Regex.Posix+    ) where++import PackageTests.Options++import Distribution.Compat.CreatePipe (createPipe)+import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..))+import Distribution.Simple.Program.Run (getEffectiveEnvironment)+import Distribution.Simple.Program.Types+import Distribution.Simple.Program.Db+import Distribution.Simple.Program+import Distribution.System (OS(Windows), buildOS)+import Distribution.Simple.Utils+    ( printRawCommandAndArgsAndEnv, withFileContents )+import Distribution.Simple.Configure+    ( getPersistBuildConfig )+import Distribution.Verbosity (Verbosity)+import Distribution.Version++import Distribution.Simple.BuildPaths (exeExtension)++import Distribution.Simple.Utils (cabalVersion)+import Distribution.Text (display)++import qualified Test.Tasty.HUnit as HUnit+import Text.Regex.Posix++import qualified Control.Exception as E+import Control.Monad+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+import Control.Monad.IO.Class+import qualified Data.ByteString.Char8 as C+import Data.List+import System.Directory+    ( doesFileExist, canonicalizePath, createDirectoryIfMissing+    , removeDirectoryRecursive, getPermissions, setPermissions+    , setOwnerExecutable )+import System.Exit+import System.FilePath+import System.IO+import System.IO.Error (isDoesNotExistError)+import System.Process (runProcess, waitForProcess, showCommandForUser)+import Control.Concurrent (threadDelay)+import Test.Tasty (TestTree, askOption, testGroup)++#ifndef mingw32_HOST_OS+import Control.Monad.Catch ( bracket_ )+import System.Directory    ( removeFile )+import System.Posix.Files  ( createSymbolicLink )+#endif++-- | Our test monad maintains an environment recording the global test+-- suite configuration 'SuiteConfig', and the local per-test+-- configuration 'TestConfig'.+type TestM = ReaderT (SuiteConfig, TestConfig) IO++-- | Run a test in the test monad.+runTestM :: SuiteConfig -> FilePath -> Maybe String -> TestM a -> IO ()+runTestM suite name subname m = do+    let test = TestConfig {+                    testMainName = name,+                    testSubName = subname,+                    testShouldFail = False,+                    testCurrentPackage = ".",+                    testPackageDb = False,+                    -- Try to avoid Unicode output+                    testEnvironment = [("LC_ALL", Just "C")]+               }+    void (runReaderT (cleanup >> m) (suite, test))+  where+    -- TODO: option not to clean up dist dirs; this should be+    -- harmless!+    cleanup = do+        onlyIfExists . removeDirectoryRecursive =<< topDir++-- | Run an IO action, and suppress a "does not exist" error.+onlyIfExists :: MonadIO m => IO () -> m ()+onlyIfExists m = liftIO $+                 E.catch m $ \(e :: IOError) ->+                    if isDoesNotExistError e+                        then return ()+                        else E.throwIO e++-- cleaning up:+--  cabal clean will clean up dist directory, but we also need to zap+--  Setup etc.+--+-- Suggestion: just copy the files somewhere else!++-- | Global configuration for the entire test suite.+data SuiteConfig = SuiteConfig+    -- | The programs used to build the Cabal under test.+    -- Invariant: ghc and ghc-pkg are configured.+    { bootProgramDb :: ProgramDb+    -- | The programs that are requested using @--with-compiler@+    -- and @--with-hc-pkg@ to Cabal the under-test.+    -- Invariant: ghc and ghc-pkg are configured.+    , withProgramDb :: ProgramDb+    -- | The build directory that was used to build Cabal (used+    -- to compile Setup scripts.)+    , cabalDistPref :: FilePath+    -- | The package database stack which makes the *built*+    -- Cabal well-formed.  In general, this is going to be+    -- the package DB stack from the LBI you used to build+    -- Cabal, PLUS the inplace database (since you also want Cabal).+    -- TODO: I forgot what this comment means:+    -- We don't add these by default because then you have to+    -- link against Cabal which makes the build go longer.+    , packageDBStack :: PackageDBStack+    -- | The package database stack for 'withGhcPath'.  This+    -- is ignored if @'withGhcPath' suite == 'ghcPath' suite@.+    -- We don't assume this includes the inplace database (since+    -- Cabal would have been built with the wrong version of GHC,+    -- so the databases aren't compatible anyway.)+    , withGhcDBStack :: PackageDBStack+    -- | How verbose should we be+    , suiteVerbosity :: Verbosity+    -- | The absolute current working directory+    , absoluteCWD :: FilePath+    -- | How long we should 'threadDelay' to make sure the file timestamp is+    -- updated correctly for recompilation tests.+    , mtimeChangeDelay :: Int+    }++getProgram :: ProgramDb -> Program -> ConfiguredProgram+getProgram progdb program = prog+    where Just prog = lookupProgram program progdb -- invariant!++getBootProgram :: SuiteConfig -> Program -> ConfiguredProgram+getBootProgram suite = getProgram (bootProgramDb suite)++getWithProgram :: SuiteConfig -> Program -> ConfiguredProgram+getWithProgram suite = getProgram (withProgramDb suite)++ghcProg :: SuiteConfig -> ConfiguredProgram+ghcProg suite = getBootProgram suite ghcProgram++withGhcProg :: SuiteConfig -> ConfiguredProgram+withGhcProg suite = getWithProgram suite ghcProgram++withGhcPkgProg :: SuiteConfig -> ConfiguredProgram+withGhcPkgProg suite = getWithProgram suite ghcPkgProgram++programVersion' :: ConfiguredProgram -> Version+programVersion' prog = version+    where Just version = programVersion prog -- invariant!++ghcPath :: SuiteConfig -> FilePath+ghcPath = programPath . ghcProg++-- Basically you should never use these two...++ghcPkgProg :: SuiteConfig -> ConfiguredProgram+ghcPkgProg suite = getBootProgram suite ghcPkgProgram++ghcPkgPath :: SuiteConfig -> FilePath+ghcPkgPath = programPath . ghcPkgProg++ghcVersion :: SuiteConfig -> Version+ghcVersion = programVersion' . ghcProg++withGhcPath :: SuiteConfig -> FilePath+withGhcPath = programPath . withGhcProg++withGhcVersion :: SuiteConfig -> Version+withGhcVersion = programVersion' . withGhcProg++-- Ditto...+withGhcPkgPath :: SuiteConfig -> FilePath+withGhcPkgPath = programPath . withGhcPkgProg++-- Selects the correct database stack to pass to the Cabal under+-- test as the "database stack" to use for testing.  This may be+-- something different if the GHC we want Cabal to use is different+-- from the GHC Cabal was built with.+testDBStack :: SuiteConfig -> PackageDBStack+testDBStack suite+    | withGhcPath suite == ghcPath suite+    = packageDBStack suite+    | otherwise+    = withGhcDBStack suite++data TestConfig = TestConfig+    -- | Test name, MUST be the directory the test packages live in+    -- relative to tests/PackageTests+    { testMainName :: FilePath+    -- | Test sub-name, used to qualify dist/database directory to avoid+    -- conflicts.+    , testSubName :: Maybe String+    -- | This gets modified sometimes+    , testShouldFail :: Bool+    -- | The "current" package, ala current directory+    , testCurrentPackage :: PackageSpec+    -- | Says if we've initialized the per-test package DB+    , testPackageDb :: Bool+    -- | Environment override+    , testEnvironment :: [(String, Maybe String)]+    }++-- | A package that can be built.+type PackageSpec = FilePath++------------------------------------------------------------------------+-- * Directories++simpleSetupPath :: TestM FilePath+simpleSetupPath = do+    (suite, _) <- ask+    return (absoluteCWD suite </> "Setup")++-- | The absolute path to the directory containing the files for+-- this tests; usually @Check.hs@ and any test packages.+testDir :: TestM FilePath+testDir = do+    (suite, test) <- ask+    return $ absoluteCWD suite </> "PackageTests" </> testMainName test++-- | The absolute path to the root of the package directory; it's+-- where the Cabal file lives.  This is what you want the CWD of cabal+-- calls to be.+packageDir :: TestM FilePath+packageDir = do+    (_, test) <- ask+    test_dir <- testDir+    return $ test_dir </> testCurrentPackage test++-- | The absolute path to the directory containing all the+-- files for ALL tests associated with a test (respecting+-- subtests.)  To clean, you ONLY need to delete this directory.+topDir :: TestM FilePath+topDir = do+    test_dir <- testDir+    (_, test) <- ask+    return $ test_dir </>+                case testSubName test of+                    Nothing -> "dist-test"+                    Just n -> "dist-test." ++ n++prefixDir :: TestM FilePath+prefixDir = do+    top_dir <- topDir+    return $ top_dir </> "usr"++-- | The absolute path to the build directory that should be used+-- for the current package in a test.+distDir :: TestM FilePath+distDir = do+    top_dir <- topDir+    (_, test) <- ask+    return $ top_dir </> testCurrentPackage test </> "dist"++definitelyMakeRelative :: FilePath -> FilePath -> FilePath+definitelyMakeRelative base0 path0 =+    let go [] path = joinPath path+        go base [] = joinPath (replicate (length base) "..")+        go (".":xs) ys = go xs ys+        go xs (".":ys) = go xs ys+        go (x:xs) (y:ys)+            | x == y    = go xs ys+            | otherwise = go (x:xs) [] </> go [] (y:ys)+    in go (splitPath base0) (splitPath path0)++-- hpc is stupid and doesn't understand absolute paths.+relativeDistDir :: TestM FilePath+relativeDistDir = do+    dist_dir0 <- distDir+    pkg_dir <- packageDir+    return $ definitelyMakeRelative pkg_dir dist_dir0++-- | The absolute path to the shared package database that should+-- be used by all packages in this test.+sharedDBPath :: TestM FilePath+sharedDBPath = do+    top_dir <- topDir+    return $ top_dir </> "packagedb"++getWithGhcPath :: TestM FilePath+getWithGhcPath = do+    (suite, _) <- ask+    return $ withGhcPath suite++------------------------------------------------------------------------+-- * Running cabal++cabal :: String -> [String] -> TestM ()+cabal cmd extraArgs0 = void (cabal' cmd extraArgs0)++cabal' :: String -> [String] -> TestM Result+cabal' cmd extraArgs0 = do+    (suite, test) <- ask+    prefix_dir <- prefixDir+    when ((cmd == "register" || cmd == "copy") && not (testPackageDb test)) $+        error "Cannot register/copy without using 'withPackageDb'"+    let extraArgs1 = case cmd of+            "configure" ->+                -- If the package database is empty, setting --global+                -- here will make us error loudly if we try to install+                -- into a bad place.+                [ "--global"+                , "--with-ghc", withGhcPath suite+                -- This improves precision but it increases the number+                -- of flags one has to specify and I don't like that;+                -- Cabal is going to configure it and usually figure+                -- out the right location in any case.+                -- , "--with-ghc-pkg", withGhcPkgPath suite+                -- These flags make the test suite run faster+                -- Can't do this unless we LD_LIBRARY_PATH correctly+                -- , "--enable-executable-dynamic"+                , "--disable-optimization"+                -- Specify where we want our installed packages to go+                , "--prefix=" ++ prefix_dir+                ] -- Only add the LBI package stack if the GHC version+                  -- matches.+                  ++ packageDBParams (testDBStack suite)+                  ++ extraArgs0+            _ -> extraArgs0+    -- This is a horrible hack to make hpc work correctly+    dist_dir <- relativeDistDir+    let extraArgs = ["-v", "--distdir", dist_dir] ++ extraArgs1+    doCabal (cmd:extraArgs)++-- | This abstracts the common pattern of configuring and then building.+cabal_build :: [String] -> TestM ()+cabal_build args = do+    cabal "configure" args+    cabal "build" []+    return ()++-- | This abstracts the common pattern of "installing" a package.+cabal_install :: [String] -> TestM ()+cabal_install args = do+    cabal "configure" args+    cabal "build" []+    cabal "copy" []+    cabal "register" []+    return ()++-- | This abstracts the common pattern of "installing" a package,+-- with haddock documentation.+cabal_install_with_docs :: [String] -> TestM ()+cabal_install_with_docs args = do+    cabal "configure" args+    cabal "build" []+    cabal "haddock" []+    cabal "copy" []+    cabal "register" []+    return ()++-- | Determines what Setup executable to run and runs it+doCabal :: [String]  -- ^ extra arguments+      -> TestM Result+doCabal cabalArgs = do+    pkg_dir <- packageDir+    customSetup <- liftIO $ doesFileExist (pkg_dir </> "Setup.hs")+    if customSetup+        then do+            compileSetup+            -- TODO make this less racey+            let path = pkg_dir </> "Setup"+            run (Just pkg_dir) path cabalArgs+        else do+            -- Use shared Setup executable (only for Simple build types).+            path <- simpleSetupPath+            run (Just pkg_dir) path cabalArgs++packageDBParams :: PackageDBStack -> [String]+packageDBParams dbs = "--package-db=clear"+                    : map (("--package-db=" ++) . convert) dbs+  where+    convert :: PackageDB -> String+    convert  GlobalPackageDB         = "global"+    convert  UserPackageDB           = "user"+    convert (SpecificPackageDB path) = path++------------------------------------------------------------------------+-- * Compiling setup scripts++compileSetup :: TestM ()+compileSetup = do+    (suite, test) <- ask+    pkg_path <- packageDir+    liftIO $ rawCompileSetup (suiteVerbosity suite) suite (testEnvironment test) pkg_path++rawCompileSetup :: Verbosity -> SuiteConfig -> [(String, Maybe String)] -> FilePath -> IO ()+rawCompileSetup verbosity suite e path = do+    -- NB: Use 'ghcPath', not 'withGhcPath', since we need to be able to+    -- link against the Cabal library which was built with 'ghcPath'.+    -- Ditto with packageDBStack.+    r <- rawRun verbosity (Just path) (ghcPath suite) e $+        [ "--make"] +++        ghcPackageDBParams (ghcVersion suite) (packageDBStack suite) +++        [ "-hide-package Cabal"+        -- This mostly works, UNLESS you've installed a+        -- version of Cabal with the SAME version number.+        -- Then old GHCs will incorrectly select the installed+        -- version (because it prefers the FIRST package it finds.)+        -- It also semi-works to not specify "-hide-all-packages"+        -- at all, except if there's a later version of Cabal+        -- installed GHC will prefer that.+        , "-package Cabal-" ++ display cabalVersion+        , "-O0"+        , "Setup.hs" ]+    unless (resultExitCode r == ExitSuccess) $+        error $+        "could not build shared Setup executable\n" +++        "  ran: " ++ resultCommand r ++ "\n" +++        "  output:\n" ++ resultOutput r ++ "\n\n"++ghcPackageDBParams :: Version -> PackageDBStack -> [String]+ghcPackageDBParams ghc_version dbs+    | ghc_version >= mkVersion [7,6]+    = "-clear-package-db" : map convert dbs+    | otherwise+    = concatMap convertLegacy dbs+  where+    convert :: PackageDB -> String+    convert  GlobalPackageDB         = "-global-package-db"+    convert  UserPackageDB           = "-user-package-db"+    convert (SpecificPackageDB path) = "-package-db=" ++ path++    convertLegacy :: PackageDB -> [String]+    convertLegacy (SpecificPackageDB path) = ["-package-conf=" ++ path]+    convertLegacy _ = []++------------------------------------------------------------------------+-- * Running ghc-pkg++ghcPkg :: String -> [String] -> TestM ()+ghcPkg cmd args = void (ghcPkg' cmd args)++ghcPkg' :: String -> [String] -> TestM Result+ghcPkg' cmd args = do+    (config, test) <- ask+    unless (testPackageDb test) $+        error "Must initialize package database using withPackageDb"+    -- NB: testDBStack already has the local database+    let db_stack = testDBStack config+        extraArgs = ghcPkgPackageDBParams (withGhcVersion config) db_stack+    run Nothing (withGhcPkgPath config) (cmd : extraArgs ++ args)++ghcPkgPackageDBParams :: Version -> PackageDBStack -> [String]+ghcPkgPackageDBParams version dbs = concatMap convert dbs where+    convert :: PackageDB -> [String]+    -- Ignoring global/user is dodgy but there's no way good+    -- way to give ghc-pkg the correct flags in this case.+    convert  GlobalPackageDB         = []+    convert  UserPackageDB           = []+    convert (SpecificPackageDB path)+        | version >= mkVersion [7,6]+        = ["--package-db=" ++ path]+        | otherwise+        = ["--package-conf=" ++ path]++------------------------------------------------------------------------+-- * Running other things++-- | Run an executable that was produced by cabal.  The @exe_name@+-- is precisely the name of the executable section in the file.+runExe :: String -> [String] -> TestM ()+runExe exe_name args = void (runExe' exe_name args)++runExe' :: String -> [String] -> TestM Result+runExe' exe_name args = do+    dist_dir <- distDir+    let exe = dist_dir </> "build" </> exe_name </> exe_name+    run Nothing exe args++-- | Run an executable that was installed by cabal.  The @exe_name@+-- is precisely the name of the executable.+runInstalledExe :: String -> [String] -> TestM ()+runInstalledExe exe_name args = void (runInstalledExe' exe_name args)++runInstalledExe' :: String -> [String] -> TestM Result+runInstalledExe' exe_name args = do+    usr <- prefixDir+    let exe = usr </> "bin" </> exe_name+    run Nothing exe args++shell :: String -> [String] -> TestM Result+shell exe args = do+    pkg_dir <- packageDir+    run (Just pkg_dir) exe args++run :: Maybe FilePath -> String -> [String] -> TestM Result+run mb_cwd path args = do+    verbosity <- getVerbosity+    (_, test) <- ask+    r <- liftIO $ rawRun verbosity mb_cwd path (testEnvironment test) args+    record r+    requireSuccess r++rawRun :: Verbosity -> Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO Result+rawRun verbosity mb_cwd path envOverrides args = do+    -- path is relative to the current directory; canonicalizePath makes it+    -- absolute, so that runProcess will find it even when changing directory.+    path' <- do pathExists <- doesFileExist path+                exePathExists <- doesFileExist (path <.> exeExtension)+                case () of+                 _ | pathExists    -> canonicalizePath path+                   | exePathExists -> canonicalizePath (path <.> exeExtension)+                   | otherwise     -> return path+    menv <- getEffectiveEnvironment envOverrides++    printRawCommandAndArgsAndEnv verbosity path' args menv+    (readh, writeh) <- createPipe+    pid <- runProcess path' args mb_cwd menv Nothing (Just writeh) (Just writeh)++    out <- hGetContents readh+    void $ E.evaluate (length out) -- force the output+    hClose readh++    -- wait for the program to terminate+    exitcode <- waitForProcess pid+    return Result {+            resultExitCode = exitcode,+            resultDirectory = mb_cwd,+            resultCommand = showCommandForUser path' args,+            resultOutput = out+        }++------------------------------------------------------------------------+-- * Subprocess run results++data Result = Result+    { resultExitCode :: ExitCode+    , resultDirectory :: Maybe FilePath+    , resultCommand :: String+    , resultOutput :: String+    } deriving Show++requireSuccess :: Result -> TestM Result+requireSuccess r@Result { resultCommand = cmd+                        , resultExitCode = exitCode+                        , resultOutput = output } = do+    (_, test) <- ask+    when (exitCode /= ExitSuccess && not (testShouldFail test)) $+        assertFailure $ "Command " ++ cmd ++ " failed.\n" +++        "Output:\n" ++ output ++ "\n"+    when (exitCode == ExitSuccess && testShouldFail test) $+        assertFailure $ "Command " ++ cmd ++ " succeeded.\n" +++        "Output:\n" ++ output ++ "\n"+    return r++record :: Result -> TestM ()+record res = do+    log_dir <- topDir+    (suite, _) <- ask+    liftIO $ createDirectoryIfMissing True log_dir+    liftIO $ C.appendFile (log_dir </> "test.log")+                         (C.pack $ "+ " ++ resultCommand res ++ "\n"+                            ++ resultOutput res ++ "\n\n")+    let test_sh = log_dir </> "test.sh"+    b <- liftIO $ doesFileExist test_sh+    when (not b) . liftIO $ do+        -- This is hella racey but this is not that security important+        C.appendFile test_sh+            (C.pack $ "#/bin/sh\nset -ev\n" +++                      "cd "++ show (absoluteCWD suite) ++"\n")+        perms <- getPermissions test_sh+        setPermissions test_sh (setOwnerExecutable True perms)++    liftIO $ C.appendFile test_sh+                (C.pack+                  (case resultDirectory res of+                    Nothing -> resultCommand res ++ "\n"+                    Just d -> "(cd " ++ show d ++ " && " ++ resultCommand res ++ ")\n"))++------------------------------------------------------------------------+-- * Test helpers++assertFailure :: MonadIO m => String -> m ()+assertFailure = liftIO . HUnit.assertFailure++assertEqual :: (Eq a, Show a, MonadIO m) => String -> a -> a -> m ()+assertEqual s x y = liftIO $ HUnit.assertEqual s x y++assertBool :: MonadIO m => String -> Bool -> m ()+assertBool s x = liftIO $ HUnit.assertBool s x++shouldExist :: MonadIO m => FilePath -> m ()+shouldExist path = liftIO $ doesFileExist path >>= assertBool (path ++ " should exist")++shouldNotExist :: MonadIO m => FilePath -> m ()+shouldNotExist path =+    liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not++shouldFail :: TestM a -> TestM a+shouldFail = withReaderT (\(suite, test) -> (suite, test { testShouldFail = not (testShouldFail test) }))++whenGhcVersion :: (Version -> Bool) -> TestM () -> TestM ()+whenGhcVersion p m = do+    (suite, _) <- ask+    when (p (withGhcVersion suite)) m++withPackage :: FilePath -> TestM a -> TestM a+withPackage f = withReaderT (\(suite, test) -> (suite, test { testCurrentPackage = f }))++-- We append to the environment list, as per 'getEffectiveEnvironment'+-- which prefers the latest override.+withEnv :: [(String, Maybe String)] -> TestM a -> TestM a+withEnv e m = do+    withReaderT (\(suite, test) -> (suite, test { testEnvironment = testEnvironment test ++ e })) m++withPackageDb :: TestM a -> TestM a+withPackageDb m = do+    (_, test0) <- ask+    db_path <- sharedDBPath+    if testPackageDb test0+        then m+        else withReaderT (\(suite, test) ->+                            (suite { packageDBStack+                                        = packageDBStack suite+                                       ++ [SpecificPackageDB db_path]+                                   , withGhcDBStack+                                        = withGhcDBStack suite+                                       ++ [SpecificPackageDB db_path]},+                             test { testPackageDb = True }))+               $ do ghcPkg "init" [db_path]+                    m++assertOutputContains :: MonadIO m => String -> Result -> m ()+assertOutputContains needle result =+    unless (needle `isInfixOf` (concatOutput output)) $+    assertFailure $+    " expected: " ++ needle ++ "\n" +++    " in output: " ++ output ++ ""+  where output = resultOutput result++assertOutputDoesNotContain :: MonadIO m => String -> Result -> m ()+assertOutputDoesNotContain needle result =+    when (needle `isInfixOf` (concatOutput output)) $+    assertFailure $+    "unexpected: " ++ needle +++    " in output: " ++ output+  where output = resultOutput result++assertFindInFile :: MonadIO m => String -> FilePath -> m ()+assertFindInFile needle path =+    liftIO $ withFileContents path+                 (\contents ->+                  unless (needle `isInfixOf` contents)+                         (assertFailure ("expected: " ++ needle ++ "\n" +++                                         " in file: " ++ path)))++-- | Replace line breaks with spaces, correctly handling "\r\n".+concatOutput :: String -> String+concatOutput = unwords . lines . filter ((/=) '\r')++-- | Delay a sufficient period of time to permit file timestamp+-- to be updated.+ghcFileModDelay :: TestM ()+ghcFileModDelay = do+    (suite, _) <- ask+    -- For old versions of GHC, we only had second-level precision,+    -- so we need to sleep a full second.  Newer versions use+    -- millisecond level precision, so we only have to wait+    -- the granularity of the underlying filesystem.+    -- TODO: cite commit when GHC got better precision; this+    -- version bound was empirically generated.+    let delay | withGhcVersion suite < mkVersion [7,7]+              = 1000000 -- 1s+              | otherwise+              = mtimeChangeDelay suite+    liftIO $ threadDelay delay++-- | Create a symlink for the duration of the provided action. If the symlink+-- already exists, it is deleted. Does not work on Windows.+withSymlink :: FilePath -> FilePath -> TestM a -> TestM a+#ifdef mingw32_HOST_OS+withSymlink _oldpath _newpath _act =+  error "PackageTests.PackageTester.withSymlink: does not work on Windows!"+#else+withSymlink oldpath newpath act = do+  symlinkExists <- liftIO $ doesFileExist newpath+  when symlinkExists $ liftIO $ removeFile newpath+  bracket_ (liftIO $ createSymbolicLink oldpath newpath)+           (liftIO $ removeFile newpath) act+#endif++------------------------------------------------------------------------+-- * Test trees++-- | Monad for creating test trees. The option --enable-all-tests determines+-- whether to filter tests with 'testWhen' and 'testUnless'.+type TestTreeM = WriterT [TestTree] (Reader OptionEnableAllTests)++runTestTree :: String -> TestTreeM () -> TestTree+runTestTree name ts = askOption $+                      testGroup name . runReader (execWriterT ts)++testTree :: SuiteConfig -> String -> TestM a -> TestTreeM ()+testTree config name m =+    testTree' $ HUnit.testCase name $ runTestM config name Nothing m++testTreeSteps :: SuiteConfig -> String -> ((String -> TestM ()) -> TestM a) -> TestTreeM ()+testTreeSteps config name f =+    testTree' . HUnit.testCaseSteps name+              $ \step -> runTestM config name Nothing (f (liftIO . step))++testTreeSub :: SuiteConfig -> String -> String -> TestM a -> TestTreeM ()+testTreeSub config name sub_name m =+    testTree' $ HUnit.testCase (name </> sub_name) $ runTestM config name (Just sub_name) m++testTreeSubSteps :: SuiteConfig -> String -> String+                 -> ((String -> TestM ()) -> TestM a)+                 -> TestTreeM ()+testTreeSubSteps config name sub_name f =+    testTree' . HUnit.testCaseSteps (name </> sub_name)+              $ \step -> runTestM config name (Just sub_name) (f (liftIO . step))++testTree' :: TestTree -> TestTreeM ()+testTree' tc = tell [tc]++-- | Create a test group from the output of the given action.+groupTests :: String -> TestTreeM () -> TestTreeM ()+groupTests name = censor (\ts -> [testGroup name ts])++-- | Apply a function to each top-level test tree.+mapTestTrees :: (TestTree -> TestTree) -> TestTreeM a -> TestTreeM a+mapTestTrees = censor . map++testWhen :: Bool -> TestTreeM () -> TestTreeM ()+testWhen c test = do+  OptionEnableAllTests enableAll <- lift ask+  when (enableAll || c) test++testUnless :: Bool -> TestTreeM () -> TestTreeM ()+testUnless = testWhen . not++unlessWindows :: TestTreeM () -> TestTreeM ()+unlessWindows = testUnless (buildOS == Windows)++hasSharedLibraries :: SuiteConfig -> Bool+hasSharedLibraries config =+    buildOS /= Windows || withGhcVersion config < mkVersion [7,8]++hasCabalForGhc :: SuiteConfig -> Bool+hasCabalForGhc config =+    withGhcPath config == ghcPath config++------------------------------------------------------------------------+-- Verbosity++getVerbosity :: TestM Verbosity+getVerbosity = fmap (suiteVerbosity . fst) ask
+ cabal/cabal-testsuite/PackageTests/PathsModule/Executable/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Paths_PathsModule (getBinDir)++main :: IO ()+main = do+    _ <- getBinDir+    return ()
+ cabal/cabal-testsuite/PackageTests/PathsModule/Executable/my.cabal view
@@ -0,0 +1,16 @@+name: PathsModule+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that the generated paths module compiles.++Executable TestPathsModule+    main-is: Main.hs+    other-modules: Paths_PathsModule+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/PathsModule/Library/my.cabal view
@@ -0,0 +1,15 @@+name: PathsModule+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that the generated paths module compiles.++Library+    exposed-modules: Paths_PathsModule+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/PreProcess/Foo.hsc view
@@ -0,0 +1,1 @@+module Foo where
+ cabal/cabal-testsuite/PackageTests/PreProcess/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Foo++main :: IO ()+main = return ()
+ cabal/cabal-testsuite/PackageTests/PreProcess/my.cabal view
@@ -0,0 +1,32 @@+name: PreProcess+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that preprocessors are run.++Library+    exposed-modules: Foo+    build-depends: base++Executable my-executable+    main-is: Main.hs+    other-modules: Foo+    build-depends: base++Test-Suite my-test-suite+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base++Benchmark my-benchmark+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/Foo.hsc view
@@ -0,0 +1,9 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Foo where++import Foreign.C.Types++#def int incr(int x) { return x + 1; }++foreign import ccall unsafe "Foo_hsc.h incr"+  incr :: CInt -> CInt
+ cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Foo++main :: IO ()+main = do+  let x = incr 4+  return ()
+ cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/my.cabal view
@@ -0,0 +1,32 @@+name: PreProcessExtraSources+version: 0.1+license: BSD3+author: Ian Ross+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that preprocessors that generate extra C sources are handled.++Library+    exposed-modules: Foo+    build-depends: base++Executable my-executable+    main-is: Main.hs+    other-modules: Foo+    build-depends: base++Test-Suite my-test-suite+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base++Benchmark my-benchmark+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/containers-dupe/Data/Map.hs view
@@ -0,0 +1,3 @@+module Data.Map where++conflict = True
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal view
@@ -0,0 +1,12 @@+name:                containers-dupe+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Data.Map+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/p/Private.hs view
@@ -0,0 +1,2 @@+module Private where+modname = "Private"
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/p/Public.hs view
@@ -0,0 +1,2 @@+module Public where+modname = "Public"
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-ambiguous.cabal view
@@ -0,0 +1,10 @@+name:                p+version:             0.1.0.0+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.21++library+  build-depends:       base, containers, containers-dupe+  reexported-modules:  Data.Map as Map
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-missing.cabal view
@@ -0,0 +1,10 @@+name:                p+version:             0.1.0.0+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.21++library+  build-depends:       base+  reexported-modules:  Missing as Foobar
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-other.cabal view
@@ -0,0 +1,12 @@+name:                p+version:             0.1.0.0+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.21++library+  exposed-modules:     Public+  other-modules:       Private+  build-depends:       base+  reexported-modules:  Private as Reprivate
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal view
@@ -0,0 +1,17 @@+name:                p+version:             0.1.0.0+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.21++library+  exposed-modules:     Public+  other-modules:       Private+  build-depends:       base, containers+  reexported-modules:  containers:Data.Map as DataMap,+                       Data.Graph,+                       Data.Set as Set,+                       containers:Data.Tree,+                       Public as Republic+                       -- NB: Private is not reexportable
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/q/A.hs view
@@ -0,0 +1,7 @@+module A where+import DataMap+import Data.Graph+import Set+import Data.Tree+import Public+import Republic
+ cabal/cabal-testsuite/PackageTests/ReexportedModules/q/q.cabal view
@@ -0,0 +1,12 @@+name:                q+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     A+  build-depends:       base, p+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Regression/T2971/p/include/T2971test.h view
+ cabal/cabal-testsuite/PackageTests/Regression/T2971/p/p.cabal view
@@ -0,0 +1,12 @@+name:                p+version:             0.1.0.0+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  include-dirs:        include+  install-includes:    T2971test.h+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Regression/T2971/q/Bar.hsc view
@@ -0,0 +1,3 @@+#include <T2971test.h>++main = putStrLn "hello world"
+ cabal/cabal-testsuite/PackageTests/Regression/T2971/q/Foo.hs view
@@ -0,0 +1,1 @@+main = return ()
+ cabal/cabal-testsuite/PackageTests/Regression/T2971/q/q.cabal view
@@ -0,0 +1,14 @@+name:                q+version:             0.1.0.0+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Custom+cabal-version:       >=1.10++executable bar+  main-is: Bar.hs+  build-depends: base++executable foo+  main-is: Foo.hs+  build-depends: base, p
+ cabal/cabal-testsuite/PackageTests/Regression/T2971a/Main.hsc view
@@ -0,0 +1,2 @@+#include <T2971a.h>+main = return ()
+ cabal/cabal-testsuite/PackageTests/Regression/T2971a/T2971a.cabal view
@@ -0,0 +1,16 @@+name:                T2971a+version:             0.1.0.0+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  include-dirs:        include+  install-includes:    T2971a.h+  default-language:    Haskell2010++executable exe+  main-is:             Main.hs+  build-depends:       base, T2971a
+ cabal/cabal-testsuite/PackageTests/Regression/T2971a/include/T2971a.h view
+ cabal/cabal-testsuite/PackageTests/Regression/T3294/.gitignore view
@@ -0,0 +1,1 @@+*.hs
+ cabal/cabal-testsuite/PackageTests/Regression/T3294/T3294.cabal view
@@ -0,0 +1,12 @@+name:                T3294+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++executable T3294+  main-is:             Main.hs+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/Regression/T3847/Main.hs view
@@ -0,0 +1,1 @@+main = return ()
+ cabal/cabal-testsuite/PackageTests/Regression/T3847/T3847.cabal view
@@ -0,0 +1,13 @@+name: T3847+version: 1.0+build-type: Simple+cabal-version: >= 1.8++library++test-suite tests+  other-extensions: ThisDoesNotExist+  type: exitcode-stdio-1.0+  main-is: Main.hs+  build-depends: base+
+ cabal/cabal-testsuite/PackageTests/Regression/T4025/A.hs view
@@ -0,0 +1,4 @@+module A where+{-# NOINLINE a #-}+a :: Int+a = 23
+ cabal/cabal-testsuite/PackageTests/Regression/T4025/T4025.cabal view
@@ -0,0 +1,13 @@+name: T4025+version: 1.0+build-type: Simple+cabal-version: >= 1.10++library+  build-depends: base+  exposed-modules: A++executable exe+  build-depends: T4025, base+  hs-source-dirs: exe+  main-is: Main.hs
+ cabal/cabal-testsuite/PackageTests/Regression/T4025/exe/Main.hs view
@@ -0,0 +1,2 @@+import A+main = print a
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ cabal/cabal-testsuite/PackageTests/TestNameCollision/child/Child.hs view
@@ -0,0 +1,2 @@+module Child where+import Parent
+ cabal/cabal-testsuite/PackageTests/TestNameCollision/child/child.cabal view
@@ -0,0 +1,19 @@+name:                child+version:             0.1+description:         This defines the colliding detailed-0.9 test suite+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Child+  build-depends:       base, parent+  default-language:    Haskell2010++test-suite parent+  type: detailed-0.9+  test-module:         Test+  hs-source-dirs: tests+  build-depends: base, Cabal, child
+ cabal/cabal-testsuite/PackageTests/TestNameCollision/child/tests/Test.hs view
@@ -0,0 +1,13 @@+module Test where++import Distribution.TestSuite+import Child++tests :: IO [Test]+tests = return $ [Test $ TestInstance+          { run = return (Finished Pass)+          , name = "test"+          , tags = []+          , options = []+          , setOption = \_ _-> Left "No Options"+          }]
+ cabal/cabal-testsuite/PackageTests/TestNameCollision/parent/Parent.hs view
@@ -0,0 +1,1 @@+module Parent where
+ cabal/cabal-testsuite/PackageTests/TestNameCollision/parent/parent.cabal view
@@ -0,0 +1,13 @@+name:                parent+version:             0.1+description:         This package is what the test suite is going to collide with+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Parent+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-testsuite/PackageTests/TestOptions/TestOptions.cabal view
@@ -0,0 +1,20 @@+name: TestOptions+version: 0.1+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >= 1.9.2++description:+    Check that Cabal passes the correct test options to test suites.++executable dummy+    main-is: test-TestOptions.hs+    build-depends: base++test-suite test-TestOptions+    main-is: test-TestOptions.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/TestOptions/test-TestOptions.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment ( getArgs )+import System.Exit ( exitFailure, exitSuccess )++main :: IO ()+main = do+    args <- getArgs+    if args == ["1", "2", "3"]+        then exitSuccess+        else putStrLn ("Got: " ++ show args) >> exitFailure
+ cabal/cabal-testsuite/PackageTests/TestStanza/Check.hs view
@@ -0,0 +1,28 @@+module PackageTests.TestStanza.Check where++import PackageTests.PackageTester++import Distribution.Version+import Distribution.Simple.LocalBuildInfo+import Distribution.Package+import Distribution.PackageDescription++suite :: TestM ()+suite = do+    assertOutputDoesNotContain "unknown section type"+        =<< cabal' "configure" []+    dist_dir <- distDir+    lbi <- liftIO $ getPersistBuildConfig dist_dir+    let anticipatedTestSuite = emptyTestSuite+            { testName = mkUnqualComponentName "dummy"+            , testInterface = TestSuiteExeV10 (mkVersion [1,0]) "dummy.hs"+            , testBuildInfo = emptyBuildInfo+                    { targetBuildDepends =+                            [ Dependency (mkPackageName "base") anyVersion ]+                    , hsSourceDirs = ["."]+                    }+            }+        gotTestSuite = head $ testSuites (localPkgDescr lbi)+    assertEqual "parsed test-suite stanza does not match anticipated"+                            anticipatedTestSuite gotTestSuite+    return ()
+ cabal/cabal-testsuite/PackageTests/TestStanza/my.cabal view
@@ -0,0 +1,19 @@+name: TestStanza+version: 0.1+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that Cabal recognizes the Test stanza defined below.++Library+    exposed-modules: MyLibrary+    build-depends: base++test-suite dummy+    main-is: dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/Check.hs view
@@ -0,0 +1,129 @@+module PackageTests.TestSuiteTests.ExeV10.Check (tests) where++import qualified Control.Exception as E (IOException, catch)+import Control.Monad (forM_, liftM4, when)+import Data.Maybe (catMaybes)+import System.FilePath+import Test.Tasty.HUnit (testCase)++import Distribution.Compiler (CompilerFlavor(..), CompilerId(..))+import Distribution.Simple.Compiler (compilerId)+import Distribution.Types.LocalBuildInfo (localPackage)+import Distribution.Simple.LocalBuildInfo (compiler, localCompatPackageKey)+import Distribution.Simple.Hpc+import Distribution.Simple.Program.Builtin (hpcProgram)+import Distribution.Simple.Program.Db+    ( emptyProgramDb, configureProgram, requireProgramVersion )+import Distribution.Text (display)+import qualified Distribution.Verbosity as Verbosity+import Distribution.Version (mkVersion, orLaterVersion)++import PackageTests.PackageTester++tests :: SuiteConfig -> TestTreeM ()+tests config = do+    -- TODO: hierarchy and subnaming is a little unfortunate+    tc "Test" "Default" $ do+        cabal_build ["--enable-tests"]+        -- This one runs both tests, including the very LONG Foo+        -- test which prints a lot of output+        cabal "test" ["--show-details=direct"]+    groupTests "WithHpc" $ hpcTestMatrix config+    groupTests "WithoutHpc" $ do+      -- Ensures that even if -fhpc is manually provided no .tix file is output.+      tc "NoTix" "NoHpcNoTix" $ do+            dist_dir <- distDir+            cabal_build+              [ "--enable-tests"+              , "--ghc-option=-fhpc"+              , "--ghc-option=-hpcdir"+              , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ]+            cabal "test" ["test-Short", "--show-details=direct"]+            lbi <- liftIO $ getPersistBuildConfig dist_dir+            let way = guessWay lbi+            shouldNotExist $ tixFilePath dist_dir way "test-Short"+      -- Ensures that even if a .tix file happens to be left around+      -- markup isn't generated.+      tc "NoMarkup" "NoHpcNoMarkup" $ do+            dist_dir <- distDir+            let tixFile = tixFilePath dist_dir Vanilla "test-Short"+            withEnv [("HPCTIXFILE", Just tixFile)] $ do+                cabal_build+                  [ "--enable-tests"+                  , "--ghc-option=-fhpc"+                  , "--ghc-option=-hpcdir"+                  , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ]+                cabal "test" ["test-Short", "--show-details=direct"]+            shouldNotExist $ htmlDir dist_dir Vanilla "test-Short" </> "hpc_index.html"+  where+    tc :: String -> String -> TestM a -> TestTreeM ()+    tc name subname m+        = testTree' $ testCase name+            (runTestM config "TestSuiteTests/ExeV10" (Just subname) m)++hpcTestMatrix :: SuiteConfig -> TestTreeM ()+hpcTestMatrix config = forM_ (choose4 [True, False]) $+                       \(libProf, exeProf, exeDyn, shared) -> do+    let name | null suffixes = "Vanilla"+             | otherwise = intercalate "-" suffixes+          where+            suffixes = catMaybes+                      [ if libProf then Just "LibProf" else Nothing+                      , if exeProf then Just "ExeProf" else Nothing+                      , if exeDyn then Just "ExeDyn" else Nothing+                      , if shared then Just "Shared" else Nothing+                      ]+        opts = catMaybes+            [ enable libProf "library-profiling"+            , enable exeProf "profiling"+            , enable exeDyn "executable-dynamic"+            , enable shared "shared"+            ]+          where+            enable cond flag+              | cond = Just $ "--enable-" ++ flag+              | otherwise = Nothing+    -- Ensure that both .tix file and markup are generated if coverage+    -- is enabled.+    testUnless ((exeDyn || shared) && not (hasSharedLibraries config)) $+      tc name ("WithHpc-" ++ name) $ do+        isCorrectVersion <- liftIO $ correctHpcVersion+        when isCorrectVersion $ do+            dist_dir <- distDir+            cabal_build ("--enable-tests" : "--enable-coverage" : opts)+            cabal "test" ["test-Short", "--show-details=direct"]+            lbi <- liftIO $ getPersistBuildConfig dist_dir+            let way = guessWay lbi+                CompilerId comp version = compilerId (compiler lbi)+                subdir+                  | comp == GHC && version >= mkVersion [7, 10] =+                      localCompatPackageKey lbi+                  | otherwise = display (localPackage lbi)+            mapM_ shouldExist+                [ mixDir dist_dir way "my-0.1" </> subdir </> "Foo.mix"+                , mixDir dist_dir way "test-Short" </> "Main.mix"+                , tixFilePath dist_dir way "test-Short"+                , htmlDir dist_dir way "test-Short" </> "hpc_index.html"+                ]+  where+    tc :: String -> String -> TestM a -> TestTreeM ()+    tc name subname m+        = testTree' $ testCase name+            (runTestM config "TestSuiteTests/ExeV10" (Just subname) m)++    choose4 :: [a] -> [(a, a, a, a)]+    choose4 xs = liftM4 (,,,) xs xs xs xs++-- | Checks for a suitable HPC version for testing.+correctHpcVersion :: IO Bool+correctHpcVersion = do+    let programDb' = emptyProgramDb+    let verbosity = Verbosity.normal+    let verRange  = orLaterVersion (mkVersion [0,7])+    programDb <- configureProgram verbosity hpcProgram programDb'+    (requireProgramVersion verbosity hpcProgram verRange programDb+     >> return True) `catchIO` (\_ -> return False)+  where+    -- Distribution.Compat.Exception is hidden.+    catchIO :: IO a -> (E.IOException -> IO a) -> IO a+    catchIO = E.catch
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/my.cabal view
@@ -0,0 +1,21 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++test-suite test-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is:    test-Foo.hs+    build-depends: base, my++test-suite test-Short+    type:   exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is:    test-Short.hs+    build-depends: base, my
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs view
@@ -0,0 +1,12 @@+module Main where++import Foo+import System.Exit+import Control.Monad++main :: IO ()+main | fooTest [] = do+        -- Make sure that the output buffer is drained+        replicateM 10000 $ putStrLn "The quick brown fox jumps over the lazy dog"+        exitSuccess+     | otherwise = exitFailure
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs view
@@ -0,0 +1,11 @@+module Main where++import Foo+import System.Exit+import Control.Monad++main :: IO ()+main | fooTest [] = do+        replicateM 5 $ putStrLn "The quick brown fox jumps over the lazy dog"+        exitSuccess+     | otherwise = exitFailure
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/Lib.hs view
@@ -0,0 +1,11 @@+module Lib where++import Distribution.TestSuite++nullt x = Test $ TestInstance+          { run = return $ Finished (Fail "no reason")+          , name = "test " ++ show x+          , tags = []+          , options = []+          , setOption = \_ _-> Left "No Options"+          }
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/LibV09.cabal view
@@ -0,0 +1,21 @@+name: LibV09+version: 0.1+cabal-version: >= 1.2+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >= 1.9.2++description: Check type detailed-0.9 test suites.++library+  exposed-modules: Lib+  build-depends: base, Cabal++test-suite LibV09-Deadlock+  type: detailed-0.9+  hs-source-dirs: tests+  test-module: Deadlock+  build-depends: base, Cabal, LibV09
+ cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs view
@@ -0,0 +1,8 @@+module Deadlock where++import Distribution.TestSuite++import Lib++tests :: IO [Test]+tests = return  [nullt x | x <- [1 .. 1000]]
+ cabal/cabal-testsuite/PackageTests/Tests.hs view
@@ -0,0 +1,750 @@+module PackageTests.Tests(tests) where++import PackageTests.PackageTester++import qualified PackageTests.AutogenModules.Package.Check+import qualified PackageTests.AutogenModules.SrcDist.Check+import qualified PackageTests.BenchmarkStanza.Check+import qualified PackageTests.CaretOperator.Check+import qualified PackageTests.TestStanza.Check+import qualified PackageTests.DeterministicAr.Check+import qualified PackageTests.TestSuiteTests.ExeV10.Check+import qualified PackageTests.ForeignLibs.Check++import Distribution.Types.TargetInfo+import Distribution.Types.LocalBuildInfo++import Distribution.Package+import Distribution.Simple.LocalBuildInfo+  ( absoluteComponentInstallDirs+  , InstallDirs (..)+  , ComponentLocalBuildInfo(componentUnitId), ComponentName(..) )+import Distribution.Simple.InstallDirs ( CopyDest(NoCopyDest) )+import Distribution.Simple.BuildPaths  ( mkLibName, mkSharedLibName )+import Distribution.Simple.Compiler    ( compilerId )+import Distribution.System (buildOS, OS(Windows))+import Distribution.Version++import Control.Monad+import System.Directory+import Test.Tasty (mkTimeout, localOption)++import qualified Data.Char as Char++tests :: SuiteConfig -> TestTreeM ()+tests config = do++  ---------------------------------------------------------------------+  -- * External tests++  -- Test that Cabal parses 'benchmark' sections correctly+  tc "BenchmarkStanza"  PackageTests.BenchmarkStanza.Check.suite++  -- Test that Cabal parses 'test' sections correctly+  tc "TestStanza"       PackageTests.TestStanza.Check.suite++  -- Test that Cabal parses '^>=' operator correctly.+  -- Don't run this for GHC 7.0/7.2, which doesn't have a recent+  -- enough version of pretty. (But this is pretty dumb.)+  tc "CaretOperator" . whenGhcVersion (>= mkVersion [7,3])$+    PackageTests.CaretOperator.Check.suite++  -- Test that Cabal determinstically generates object archives+  tc "DeterministicAr"  PackageTests.DeterministicAr.Check.suite++  -- Test that cabal shows all the 'autogen-modules' warnings.+  tc "AutogenModules/Package" PackageTests.AutogenModules.Package.Check.suite+  -- Test that Cabal parses and uses 'autogen-modules' fields correctly+  tc "AutogenModules/SrcDist" PackageTests.AutogenModules.SrcDist.Check.suite++  -- Test that foreign libraries work+  tc "ForeignLibs" PackageTests.ForeignLibs.Check.suite++  ---------------------------------------------------------------------+  -- * Test suite tests++  -- TODO: This shouldn't be necessary, but there seems to be some+  -- bug in the way the test is written.  Not going to lose sleep+  -- over this... but would be nice to fix.+  testWhen (hasCabalForGhc config)+   . groupTests "TestSuiteTests/ExeV10" $+      (PackageTests.TestSuiteTests.ExeV10.Check.tests config)++  -- Test if detailed-0.9 builds correctly+  testWhen (hasCabalForGhc config)+   . tcs "TestSuiteTests/LibV09" "Build" $ cabal_build ["--enable-tests"]++  -- Tests for #2489, stdio deadlock+  testWhen (hasCabalForGhc config)+   . mapTestTrees (localOption (mkTimeout $ 10 ^ (8 :: Int)))+   . tcs "TestSuiteTests/LibV09" "Deadlock" $ do+      cabal_build ["--enable-tests"]+      shouldFail $ cabal "test" []++  ---------------------------------------------------------------------+  -- * Inline tests++  -- Test if exitcode-stdio-1.0 benchmark builds correctly+  tc "BenchmarkExeV10" $ cabal_build ["--enable-benchmarks"]++  -- Test --benchmark-option(s) flags on ./Setup bench+  tc "BenchmarkOptions" $ do+      cabal_build ["--enable-benchmarks"]+      cabal "bench" [ "--benchmark-options=1 2 3" ]+      cabal "bench" [ "--benchmark-option=1"+                    , "--benchmark-option=2"+                    , "--benchmark-option=3"+                    ]++  -- Test --test-option(s) flags on ./Setup test+  tc "TestOptions" $ do+      cabal_build ["--enable-tests"]+      cabal "test" ["--test-options=1 2 3"]+      cabal "test" [ "--test-option=1"+                   , "--test-option=2"+                   , "--test-option=3"+                   ]++  -- Test attempt to have executable depend on internal+  -- library, but cabal-version is too old.+  tc "BuildDeps/InternalLibrary0" $ do+      r <- shouldFail $ cabal' "configure" []+      -- Should tell you how to enable the desired behavior+      let sb = "library which is defined within the same package."+      assertOutputContains sb r++  -- Test executable depends on internal library.+  tc "BuildDeps/InternalLibrary1" $ cabal_build []++  -- Test that internal library is preferred to an installed on+  -- with the same name and version+  tc "BuildDeps/InternalLibrary2" $ internal_lib_test "internal"++  -- Test that internal library is preferred to an installed on+  -- with the same name and LATER version+  tc "BuildDeps/InternalLibrary3" $ internal_lib_test "internal"++  -- On old versions of Cabal, an explicit dependency constraint which+  -- doesn't match the internal library causes us to use external+  -- library.  We got rid of this functionality in 1.25; now, we always+  -- use internal, and just emit an error if you check.+  tcs "BuildDeps/InternalLibrary4" "external" $ internal_lib_test "internal"++  -- On a previous buggy version of my patch, the test above passed only+  -- because the installed library caused Cabal to think that the+  -- dependency was fulfilled.  Make sure we ignore the dependency+  -- entirely.+  tcs "BuildDeps/InternalLibrary4" "ignore" $ cabal_build []++  -- Test "old build-dep behavior", where we should get the+  -- same package dependencies on all targets if cabal-version+  -- is sufficiently old.+  tc "BuildDeps/SameDepsAllRound" $ cabal_build []++  -- Test "new build-dep behavior", where each target gets+  -- separate dependencies.  This tests that an executable+  -- dep does not leak into the library.+  tc "BuildDeps/TargetSpecificDeps1" $ do+      cabal "configure" []+      r <- shouldFail $ cabal' "build" []+      assertRegex "error should be in MyLibrary.hs" "^MyLibrary.hs:" r+      assertRegex+        "error should be \"Could not find module `Text\\.PrettyPrint\""+        "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r++  -- This is a control on TargetSpecificDeps1; it should+  -- succeed.+  tc "BuildDeps/TargetSpecificDeps2" $ cabal_build []++  -- Test "new build-dep behavior", where each target gets+  -- separate dependencies.  This tests that an library+  -- dep does not leak into the executable.+  tc "BuildDeps/TargetSpecificDeps3" $ do+      cabal "configure" []+      r <- shouldFail $ cabal' "build" []+      assertRegex "error should be in lemon.hs" "^lemon.hs:" r+      assertRegex+        "error should be \"Could not find module `Text\\.PrettyPrint\""+        "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r++  -- Test that Paths module is generated and available for executables.+  tc "PathsModule/Executable" $ cabal_build []++  -- Test that Paths module is generated and available for libraries.+  tc "PathsModule/Library" $ cabal_build []++  -- Check that preprocessors (hsc2hs) are run+  tc "PreProcess" $ cabal_build ["--enable-tests", "--enable-benchmarks"]++  -- Check that preprocessors that generate extra C sources are handled+  tc "PreProcessExtraSources" $ cabal_build ["--enable-tests",+                                             "--enable-benchmarks"]++  -- Test building a vanilla library/executable which uses Template Haskell+  tc "TemplateHaskell/vanilla" $ cabal_build []++  -- Test building a profiled library/executable which uses Template Haskell+  -- (Cabal has to build the non-profiled version first)+  tc "TemplateHaskell/profiling" $ cabal_build ["--enable-library-profiling",+                                                "--enable-profiling"]++  -- Test building a dynamic library/executable which uses Template+  -- Haskell+  testWhen (hasSharedLibraries config) $+    tc "TemplateHaskell/dynamic" $ cabal_build ["--enable-shared",+                                                "--enable-executable-dynamic"]++  -- Test building an executable whose main() function is defined in a C+  -- file+  tc "CMain" $ cabal_build []++  -- Test build when the library is empty, for #1241+  tc "EmptyLib" $+      withPackage "empty" $ cabal_build []++  -- Test that "./Setup haddock" works correctly+  tc "Haddock" $ do+      dist_dir <- distDir+      let haddocksDir = dist_dir </> "doc" </> "html" </> "Haddock"+      cabal "configure" []+      cabal "haddock" []+      let docFiles+              = map (haddocksDir </>)+                    ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"]+      mapM_ (assertFindInFile "For hiding needles.") docFiles++  -- Test that Haddock with a newline in synopsis works correctly, #3004+  tc "HaddockNewline" $ do+        cabal "configure" []+        cabal "haddock" []++  -- Test that Cabal properly orders GHC flags passed to GHC (when+  -- there are multiple ghc-options fields.)+  tc "OrderFlags" $ cabal_build []++  -- Test that reexported modules build correctly+  tcs "ReexportedModules" "p" . whenGhcVersion (>= mkVersion [7,9]) $ do+      withPackageDb $ do+        withPackage "p" $ cabal_install ["--cabal-file", "p.cabal"]+        withPackage "q" $ do+            cabal_build []+  tcs "ReexportedModules" "fail-other" . whenGhcVersion (>= mkVersion [7,9]) $ do+      withPackage "p" $ do+          r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-other.cabal"]+          assertOutputContains "Private" r+  tcs "ReexportedModules" "fail-ambiguous" . whenGhcVersion (>= mkVersion [7,9]) $ do+      withPackageDb $ do+        withPackage "containers-dupe" $ cabal_install []+        withPackage "p" $ do+            r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-ambiguous.cabal"]+            assertOutputContains "Data.Map" r+  tcs "ReexportedModules" "fail-missing" . whenGhcVersion (>= mkVersion [7,9]) $ do+      withPackage "p" $ do+          r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-missing.cabal"]+          assertOutputContains "Missing" r++  -- Test that module name ambiguity can be resolved using package+  -- qualified imports.  (Paper Backpack doesn't natively support+  -- this but we must!)+  tcs "Ambiguity" "package-import" $ do+    withPackageDb $ do+        withPackage "p" $ cabal_install []+        withPackage "q" $ cabal_install []+        withPackage "package-import" $ do+            cabal_build []+            runExe' "package-import" [] >>= assertOutputContains "p q"++  -- Test that we can resolve a module name ambiguity when reexporting+  -- by explicitly specifying what package we want.+  tcs "Ambiguity" "reexport" . whenGhcVersion (>= mkVersion [7,9]) $ do+    withPackageDb $ do+        withPackage "p" $ cabal_install []+        withPackage "q" $ cabal_install []+        withPackage "reexport" $ cabal_install []+        withPackage "reexport-test" $ do+            cabal_build []+            runExe' "reexport-test" [] >>= assertOutputContains "p q"++  -- Test that Cabal computes different IPIDs when the source changes.+  tc "UniqueIPID" . withPackageDb $ do+      withPackage "P1" $ cabal "configure" []+      withPackage "P2" $ cabal "configure" []+      withPackage "P1" $ cabal "build" []+      withPackage "P1" $ cabal "build" [] -- rebuild should work+      r1 <- withPackage "P1" $ cabal' "register" ["--print-ipid", "--inplace"]+      withPackage "P2" $ cabal "build" []+      r2 <- withPackage "P2" $ cabal' "register" ["--print-ipid", "--inplace"]+      let exIPID s = takeWhile (/= '\n') $+               head . filter (isPrefixOf $ "UniqueIPID-0.1-") $ (tails s)+      when ((exIPID $ resultOutput r1) == (exIPID $ resultOutput r2)) $+        assertFailure $ "cabal has not calculated different Installed " +++          "package ID when source is changed."++  -- Test that if two components have the same module name, they do not+  -- clobber each other.+  testWhen (hasCabalForGhc config) $ -- uses library test suite+    tc "DuplicateModuleName" $ do+      cabal_build ["--enable-tests"]+      r1 <- shouldFail $ cabal' "test" ["foo"]+      assertOutputContains "test B" r1+      assertOutputContains "test A" r1+      r2 <- shouldFail $ cabal' "test" ["foo2"]+      assertOutputContains "test C" r2+      assertOutputContains "test A" r2++  -- Test that if test suite has a name which conflicts with a package+  -- which is in the database, we can still use the test case (they+  -- should NOT shadow).+  testWhen (hasCabalForGhc config)+   . tc "TestNameCollision" $ do+        withPackageDb $ do+          withPackage "parent" $ cabal_install []+          withPackage "child" $ do+            cabal_build ["--enable-tests"]+            cabal "test" []++  -- Test that '--allow-newer' works via the 'Setup.hs configure' interface.+  tc "AllowNewer" $ do+        shouldFail $ cabal "configure" []+        cabal "configure" ["--allow-newer"]+        shouldFail $ cabal "configure" ["--allow-newer=baz,quux"]+        cabal "configure" ["--allow-newer=base", "--allow-newer=baz,quux"]+        cabal "configure" ["--allow-newer=bar", "--allow-newer=base,baz"+                          ,"--allow-newer=quux"]+        shouldFail $ cabal "configure" ["--enable-tests"]+        cabal "configure" ["--enable-tests", "--allow-newer"]+        shouldFail $ cabal "configure" ["--enable-benchmarks"]+        cabal "configure" ["--enable-benchmarks", "--allow-newer"]+        shouldFail $ cabal "configure" ["--enable-benchmarks", "--enable-tests"]+        cabal "configure" ["--enable-benchmarks", "--enable-tests"+                          ,"--allow-newer"]+        shouldFail $ cabal "configure" ["--allow-newer=Foo:base"]+        shouldFail $ cabal "configure" ["--allow-newer=Foo:base"+                                       ,"--enable-tests", "--enable-benchmarks"]+        cabal "configure" ["--allow-newer=AllowNewer:base"]+        cabal "configure" ["--allow-newer=AllowNewer:base"+                          ,"--allow-newer=Foo:base"]+        cabal "configure" ["--allow-newer=AllowNewer:base"+                          ,"--allow-newer=Foo:base"+                          ,"--enable-tests", "--enable-benchmarks"]++  -- Test that '--allow-older' works via the 'Setup.hs configure' interface.+  tc "AllowOlder" $ do+        shouldFail $ cabal "configure" []+        cabal "configure" ["--allow-older"]+        shouldFail $ cabal "configure" ["--allow-older=baz,quux"]+        cabal "configure" ["--allow-older=base", "--allow-older=baz,quux"]+        cabal "configure" ["--allow-older=bar", "--allow-older=base,baz"+                          ,"--allow-older=quux"]+        shouldFail $ cabal "configure" ["--enable-tests"]+        cabal "configure" ["--enable-tests", "--allow-older"]+        shouldFail $ cabal "configure" ["--enable-benchmarks"]+        cabal "configure" ["--enable-benchmarks", "--allow-older"]+        shouldFail $ cabal "configure" ["--enable-benchmarks", "--enable-tests"]+        cabal "configure" ["--enable-benchmarks", "--enable-tests"+                          ,"--allow-older"]+        shouldFail $ cabal "configure" ["--allow-older=Foo:base"]+        shouldFail $ cabal "configure" ["--allow-older=Foo:base"+                                       ,"--enable-tests", "--enable-benchmarks"]+        cabal "configure" ["--allow-older=AllowOlder:base"]+        cabal "configure" ["--allow-older=AllowOlder:base"+                          ,"--allow-older=Foo:base"]+        cabal "configure" ["--allow-older=AllowOlder:base"+                          ,"--allow-older=Foo:base"+                          ,"--enable-tests", "--enable-benchmarks"]++  -- Test that Cabal can choose flags to disable building a component when that+  -- component's dependencies are unavailable. The build should succeed without+  -- requiring the component's dependencies or imports.+  tc "BuildableField" $ do+      r <- cabal' "configure" ["-v"]+      assertOutputContains "Flags chosen: build-exe=False" r+      cabal "build" []++  -- TODO: Enable these tests on Windows+  unlessWindows $ do+      tc "GhcPkgGuess/SameDirectory" $ ghc_pkg_guess "ghc"+      tc "GhcPkgGuess/SameDirectoryVersion" $ ghc_pkg_guess "ghc-7.10"+      tc "GhcPkgGuess/SameDirectoryGhcVersion" $ ghc_pkg_guess "ghc-7.10"++  unlessWindows $ do+      tc "GhcPkgGuess/Symlink" $ do+        -- We don't want to distribute a tarball with symlinks. See #3190.+        withSymlink "bin/ghc"+                    "PackageTests/GhcPkgGuess/Symlink/ghc" $+                    ghc_pkg_guess "ghc"++      tc "GhcPkgGuess/SymlinkVersion" $ do+        withSymlink "bin/ghc-7.10"+                    "PackageTests/GhcPkgGuess/SymlinkVersion/ghc" $+                    ghc_pkg_guess "ghc"++      tc "GhcPkgGuess/SymlinkGhcVersion" $ do+        withSymlink "bin/ghc-7.10"+                    "PackageTests/GhcPkgGuess/SymlinkGhcVersion/ghc" $+                    ghc_pkg_guess "ghc"++  -- Basic test for internal libraries (in p); package q is to make+  -- sure that the internal library correctly is used, not the+  -- external library.+  tc "InternalLibraries" $ do+      withPackageDb $ do+          withPackage "q" $ cabal_install []+          withPackage "p" $ do+              cabal_install []+              cabal "clean" []+              r <- runInstalledExe' "foo" []+              assertOutputContains "I AM THE ONE" r++  -- Test to see if --gen-script works.+  tcs "InternalLibraries" "gen-script" $ do+    withPackageDb $ do+      withPackage "p" $ do+        cabal_build []+        cabal "copy" []+        cabal "register" ["--gen-script"]+        _ <- if buildOS == Windows+                then shell "cmd" ["/C", "register.bat"]+                else shell "sh" ["register.sh"]+        return ()+      -- Make sure we can see p+      withPackage "r" $ cabal_install []++  -- Test to see if --gen-pkg-config works.+  tcs "InternalLibraries" "gen-pkg-config" $ do+    withPackageDb $ do+      withPackage "p" $ do+        cabal_build []+        cabal "copy" []+        let dir = "pkg-config.bak"+        cabal "register" ["--gen-pkg-config=" ++ dir]+        -- Infelicity! Does not respect CWD.+        pkg_dir <- packageDir+        let notHidden = not . isHidden+            isHidden name = "." `isPrefixOf` name+        confs <- fmap (sort . filter notHidden)+               . liftIO $ getDirectoryContents (pkg_dir </> dir)+        forM_ confs $ \conf -> ghcPkg "register" [pkg_dir </> dir </> conf]++      -- Make sure we can see p+      withPackage "r" $ cabal_install []++  -- Internal libraries used by a statically linked executable:+  -- no libraries should get installed or registered.  (Note,+  -- this does build shared libraries just to make sure they+  -- don't get installed, so this test doesn't work on Windows.)+  testWhen (hasSharedLibraries config) $+    tcs "InternalLibraries/Executable" "Static" $+      multiple_libraries_executable False++  -- Internal libraries used by a dynamically linked executable:+  -- ONLY the dynamic library should be installed, no registration+  testWhen (hasSharedLibraries config) $+    tcs "InternalLibraries/Executable" "Dynamic" $+      multiple_libraries_executable True++  -- Internal library used by public library; it must be installed and+  -- registered.+  tc "InternalLibraries/Library" $ do+      withPackageDb $ do+          withPackage "foolib" $ cabal_install []+          withPackage "fooexe" $ do+              cabal_build []+              runExe' "fooexe" []+                  >>= assertOutputContains "25"++  -- Test to ensure that cabal_macros.h are computed per-component.+  tc "Macros" $ do+      cabal_build []+      runExe' "macros-a" []+          >>= assertOutputContains "macros-a"+      runExe' "macros-b" []+          >>= assertOutputContains "macros-b"++  -- Test for 'build-type: Configure' example from the Cabal manual.+  -- Disabled on Windows since MingW doesn't ship with autoreconf by+  -- default.+  unlessWindows $ do+      tc "Configure" $ do+          _ <- shell "autoreconf" ["-i"]+          cabal_build []++  tc "ConfigureComponent/Exe" $ do+    withPackageDb $ do+      cabal_install ["goodexe"]+      runExe' "goodexe" [] >>= assertOutputContains "OK"++  tcs "ConfigureComponent/SubLib" "sublib-explicit" $ do+    withPackageDb $ do+      cabal_install ["sublib", "--cid", "sublib-0.1-abc"]+      cabal_install ["exe", "--dependency", "sublib=sublib-0.1-abc"]+      runExe' "exe" [] >>= assertOutputContains "OK"++  tcs "ConfigureComponent/SubLib" "sublib" $ do+    withPackageDb $ do+      cabal_install ["sublib"]+      cabal_install ["exe"]+      runExe' "exe" [] >>= assertOutputContains "OK"++  tcs "ConfigureComponent/Test" "test" $ do+    withPackageDb $ do+      cabal_install ["test-for-cabal"]+      withPackage "testlib" $ cabal_install []+      cabal "configure" ["testsuite"]+      cabal "build" []+      cabal "test" []++  -- Test that per-component copy works, when only building library+  tc "CopyComponent/Lib" $+      withPackageDb $ do+          cabal "configure" []+          cabal "build" ["lib:p"]+          cabal "copy" ["lib:p"]++  -- Test that per-component copy works, when only building one executable+  tc "CopyComponent/Exe" $+      withPackageDb $ do+          cabal "configure" []+          cabal "build" ["myprog"]+          cabal "copy" ["myprog"]++  -- Test internal custom preprocessor+  tc "CustomPreProcess" $ do+      cabal_build []+      runExe' "hello-world" []+        >>= assertOutputContains "hello from A"++  -- Test PATH-munging+  tc "BuildToolsPath" $ do+      cabal_build []+      runExe' "hello-world" []+        >>= assertOutputContains "1111"++  -- Test that executable recompilation works+  -- https://github.com/haskell/cabal/issues/3294+  tc "Regression/T3294" $ do+    pkg_dir <- packageDir+    liftIO $ writeFile (pkg_dir </> "Main.hs") "main = putStrLn \"aaa\""+    cabal "configure" []+    cabal "build" []+    runExe' "T3294" [] >>= assertOutputContains "aaa"+    ghcFileModDelay+    liftIO $ writeFile (pkg_dir </> "Main.hs") "main = putStrLn \"bbb\""+    cabal "build" []+    runExe' "T3294" [] >>= assertOutputContains "bbb"++  -- Test that other-extensions of disabled component do not+  -- effect configure step.+  tc "Regression/T3847" $ do+    cabal "configure" ["--disable-tests"]++  -- Test that we don't pick up include-dirs from libraries+  -- we didn't actually depend on.+  tc "Regression/T2971" $ do+    withPackageDb $ do+      withPackage "p" $ cabal_install []+      withPackage "q" $ do+        cabal "configure" []+        assertOutputContains "T2971test.h"+            =<< shouldFail (cabal' "build" [])++  -- Test that we pick up include dirs from internal library+  tc "Regression/T2971a" $ cabal_build []++  -- Test that we don't accidentally add the inplace directory to+  -- an executable RPATH.  Don't test on Windows, which doesn't+  -- support RPATH.+  unlessWindows $ do+    tc "Regression/T4025" $ do+      cabal "configure" ["--enable-executable-dynamic"]+      cabal "build" []+      -- This should fail as it we should NOT be able to find the+      -- dynamic library for the internal library (since we didn't+      -- install it).  If we incorrectly encoded our local dist+      -- dir in the RPATH, this will succeed.+      shouldFail $ runExe' "exe" []++  -- Test error message we report when a non-buildable target is+  -- requested to be built+  -- TODO: We can give a better error message here, see #3858.+  tcs "BuildTargetErrors" "non-buildable" $ do+    cabal "configure" []+    assertOutputContains "There is no component"+        =<< shouldFail (cabal' "build" ["not-buildable-exe"])++  tc "Backpack/Includes1" . whenGhcVersion (>= mkVersion [8,1]) $ do+      cabal "configure" []+      r <- shouldFail $ cabal' "build" []+      assertBool "error should be in B.hs" $+          resultOutput r =~ "^B.hs:"+      assertBool "error should be \"Could not find module Data.Set\"" $+          resultOutput r =~ "(Could not find module|Failed to load interface).*Data.Set"++  tcs "Backpack/Includes2" "internal" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      cabal_install ["--cabal-file", "Includes2.cabal"]+      -- TODO: haddock for internal method doesn't work+      runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql"++  tcs "Backpack/Includes2" "internal-fail" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail.cabal"]+      assertOutputContains "mysql" r++  tcs "Backpack/Includes2" "external" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      withPackage "mylib" $ cabal_install_with_docs ["--ipid", "mylib-0.1.0.0"]+      withPackage "mysql" $ cabal_install_with_docs ["--ipid", "mysql-0.1.0.0"]+      withPackage "postgresql" $ cabal_install_with_docs ["--ipid", "postgresql-0.1.0.0"]+      withPackage "mylib" $+        cabal_install_with_docs ["--ipid", "mylib-0.1.0.0",+                       "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"]+      withPackage "mylib" $+        cabal_install_with_docs ["--ipid", "mylib-0.1.0.0",+                       "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"]+      withPackage "src" $ cabal_install_with_docs []+      withPackage "exe" $ do+        cabal_install_with_docs []+        runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql"++  tcs "Backpack/Includes2" "per-component" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      let cabal_install' args = cabal_install_with_docs (["--cabal-file", "Includes2.cabal"] ++ args)+      cabal_install' ["mylib", "--cid", "mylib-0.1.0.0"]+      cabal_install' ["mysql", "--cid", "mysql-0.1.0.0"]+      cabal_install' ["postgresql", "--cid", "postgresql-0.1.0.0"]+      cabal_install' ["mylib", "--cid", "mylib-0.1.0.0",+                     "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"]+      cabal_install' ["mylib", "--cid", "mylib-0.1.0.0",+                     "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"]+      cabal_install' ["Includes2"]+      cabal_install' ["exe"]+      runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql"++  tcs "Backpack/Includes3" "internal" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      cabal_install []+      -- TODO: refactorize+      pkg_dir <- packageDir+      _ <- run (Just pkg_dir) "touch" ["indef/Foo.hs"]+      cabal "build" []+      runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]"++  tcs "Backpack/Includes3" "external-fail" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      withPackage "sigs" $ cabal_install []+      withPackage "indef" $ cabal_install []+      -- Forgot to build the instantiated versions!+      withPackage "exe" $ do+        r <- shouldFail $ cabal' "configure" []+        assertOutputContains "indef-0.1.0.0" r+        return ()++  tcs "Backpack/Includes3" "external-ok" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      containers_result <- ghcPkg' "field" ["--global", "containers", "id"]+      containers_id <- case stripPrefix "id: " (resultOutput containers_result) of+        Just x -> return (takeWhile (not . Char.isSpace) x)+        Nothing -> error "could not determine id of containers"+      withPackage "sigs" $ cabal_install_with_docs ["--ipid", "sigs-0.1.0.0"]+      withPackage "indef" $ cabal_install_with_docs ["--ipid", "indef-0.1.0.0"]+      withPackage "sigs" $ do+        -- NB: this REUSES the dist directory that we typechecked+        -- indefinitely, but it's OK; the recompile checker should get it.+        cabal_install_with_docs ["--ipid", "sigs-0.1.0.0",+                       "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"]+      withPackage "indef" $ do+        -- Ditto.+        cabal_install_with_docs ["--ipid", "indef-0.1.0.0",+                       "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"]+      withPackage "exe" $ do+        cabal_install []+        runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]"++  tcs "Backpack/Includes3" "external-explicit" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      withPackage "sigs" $ cabal_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"]+      withPackage "indef" $ cabal_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"]++  tc "Backpack/Includes4" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      cabal_install []+      runExe' "exe" [] >>= assertOutputContains "A (B (A (B"++  tc "Backpack/Includes5" . whenGhcVersion (>= mkVersion [8,1]) $ do+      cabal "configure" []+      r <- shouldFail $ cabal' "build" []+      assertOutputContains "Foobar" r+      assertOutputContains "Could not find" r+      return ()++  tc "Backpack/Reexport1" . whenGhcVersion (>= mkVersion [8,1]) $ do+    withPackageDb $ do+      withPackage "p" $ cabal_install_with_docs []+      withPackage "q" $ do+        cabal_build []+        cabal "haddock" []++  where+    ghc_pkg_guess bin_name = do+        cwd <- packageDir+        with_ghc <- getWithGhcPath+        r <- withEnv [("WITH_GHC", Just with_ghc)]+           . shouldFail $ cabal' "configure" ["-w", cwd </> bin_name]+        assertOutputContains "is version 9999999" r+        return ()++    -- Shared test function for BuildDeps/InternalLibrary* tests.+    internal_lib_test expect = withPackageDb $ do+        withPackage "to-install" $ cabal_install []+        cabal_build []+        r <- runExe' "lemon" []+        assertEqual+            ("executable should have linked with the " ++ expect ++ " library")+            ("foo foo myLibFunc " ++ expect)+            (concatOutput (resultOutput r))++    assertRegex :: String -> String -> Result -> TestM ()+    assertRegex msg regex r = let out = resultOutput r+                              in assertBool (msg ++ ",\nactual output:\n" ++ out)+                                 (out =~ regex)++    multiple_libraries_executable is_dynamic =+        withPackageDb $ do+            cabal_install $ [ if is_dynamic then "--enable-executable-dynamic"+                                            else "--disable-executable-dynamic"+                            , "--enable-shared"]+            dist_dir <- distDir+            lbi <- liftIO $ getPersistBuildConfig dist_dir+            let pkg_descr = localPkgDescr lbi+                compiler_id = compilerId (compiler lbi)+                cname = CSubLibName $ mkUnqualComponentName "foo-internal"+                [target] = componentNameTargets' pkg_descr lbi cname+                uid = componentUnitId (targetCLBI target)+                InstallDirs{libdir=dir,dynlibdir=dyndir} =+                  absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest+            assertBool "interface files should be installed"+                =<< liftIO (doesFileExist (dir </> "Foo.hi"))+            assertBool "static library should be installed"+                =<< liftIO (doesFileExist (dir </> mkLibName uid))+            if is_dynamic+              then+                assertBool "dynamic library MUST be installed"+                    =<< liftIO (doesFileExist (dyndir </> mkSharedLibName+                                               compiler_id uid))+              else+                assertBool "dynamic library should be installed"+                    =<< liftIO (doesFileExist (dyndir </> mkSharedLibName+                                               compiler_id uid))+            shouldFail $ ghcPkg "describe" ["foo"]+            -- clean away the dist directory so that we catch accidental+            -- dependence on the inplace files+            cabal "clean" []+            runInstalledExe' "foo" [] >>= assertOutputContains "46"++    tc :: FilePath -> TestM a -> TestTreeM ()+    tc name = testTree config name++    tcs :: FilePath -> FilePath -> TestM a -> TestTreeM ()+    tcs name sub_name m+        = testTreeSub config name sub_name m
+ cabal/cabal-testsuite/PackageTests/UniqueIPID/P1/M.hs view
@@ -0,0 +1,3 @@+module M(m) where++m = print "1"
+ cabal/cabal-testsuite/PackageTests/UniqueIPID/P1/my.cabal view
@@ -0,0 +1,15 @@+name: UniqueIPID+version: 0.1+license: BSD3+author: Vishal Agrawal+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that Cabal generates unique IPID based on source.++Library+    exposed-modules: M+    build-depends: base
+ cabal/cabal-testsuite/PackageTests/UniqueIPID/P2/M.hs view
@@ -0,0 +1,3 @@+module M(m) where++m = print "2"
+ cabal/cabal-testsuite/PackageTests/UniqueIPID/P2/my.cabal view
@@ -0,0 +1,15 @@+name: UniqueIPID+version: 0.1+license: BSD3+author: Vishal Agrawal+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that Cabal generates unique IPID based on source.++Library+    exposed-modules: M+    build-depends: base, containers
+ cabal/cabal-testsuite/PackageTests/multInst/my.cabal view
@@ -0,0 +1,16 @@+name: Haddock+version: 0.1+license: BSD3+author: Iain Nicol+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that Cabal successfully invokes Haddock.++Library+    exposed-modules: CPP, Literate, NoCPP, Simple+    other-extensions: CPP+    build-depends: base
+ cabal/cabal-testsuite/README.md view
@@ -0,0 +1,54 @@+cabal-testsuite is a suite of integration tests for Cabal-based+frameworks.  At the moment it only supports testing against+Setup scripts but we hope to make it more flexible.++Writing package tests+=====================++The tests under the [PackageTests] directory define and build packages+that exercise various components of Cabal. Each test case is an [HUnit]+test. The entry point for the test suite, where all the test cases are+listed, is [PackageTests.hs]. There are utilities for calling the stages+of Cabal's build process in [PackageTests/PackageTester.hs]; have a look+at an existing test case to see how they are used.++In order to run the tests, `PackageTests` needs to know where the inplace+copy of Cabal being tested is, as well as some information which was+used to configure it.  By default, `PackageTests` tries to look at the+`LocalBuildInfo`, but if the format of `LocalBuildInfo` has changed+between the version of Cabal which ran the configure step, and the+version of Cabal we are testing against, this may fail.  In that+case, you can manually specify the information we need using+the following environment variables:++* `CABAL_PACKAGETESTS_GHC` is the path to the GHC you compiled Cabal with+* `CABAL_PACKAGETESTS_WITH_GHC` is the path for the GHC you want to have+  Cabal use when running tests; i.e., you can change this to a different+  version of GHC to see how Cabal handles that version.  If omitted,+  it defaults to `CABAL_PACKAGETESTS_GHC`.+* `CABAL_PACKAGETESTS_DB_STACK` is a PATH-style list of package database paths,+  `clear`, `global` and `user`.  Each component of the list is+  interpreted the same way as Cabal's `-package-db` flag.  This list+  must contain the copy of Cabal you are planning to test against+  (as well as its transitive dependencies).  By default, we guess+  that it is just the global and user database.  However, if some of+  Cabal's dependencies were installed in a sandbox or other non-standard+  location, you will need to add it.  Most commonly, if you are are+  using 'new-build' you'll need to add+  dist-newstyle/packagedb/ghc-VERSION and $HOME/.cabal/store/ghc-VERSION/package.db+  to your database stack.  (In most situations, the actual inplace+  database Cabal was registered into is automatically detected.)++There are a few extra options to toggle (e.g. `CABAL_PACKAGETESTS_GHC_PKG`+lets you explicitly set ghc-pkg in case Cabal can't autodetect it) but+the three above.++If you can successfully run the test suite, we'll print out examples+of all of these values for you under "Environment".++[PackageTests]: PackageTests+[HUnit]: http://hackage.haskell.org/package/HUnit+[PackageTests.hs]: PackageTests.hs+[PackageTests/PackageTester.hs]: PackageTests/PackageTester.hs+[detailed]: ../Distribution/TestSuite.hs+[PackageTests/BuildTestSuiteDetailedV09/Check.hs]: PackageTests/BuildTestSuiteDetailedV09/Check.hs
+ cabal/cabal-testsuite/Setup.hs view
@@ -0,0 +1,10 @@+import Distribution.Simple+main :: IO ()+main = defaultMain++-- Although this looks like the Simple build type, it is in fact vital that+-- we use this Setup.hs because we need to compile against the very same+-- version of the Cabal library that the test suite will be compiled+-- against.  When this happens, it will mean that we'll be able to+-- read the LocalBuildInfo of our build environment, which we will+-- subsequently use to make decisions about PATHs etc.  Important!
+ cabal/cabal-testsuite/cabal-testsuite.cabal view
@@ -0,0 +1,350 @@+name:          cabal-testsuite+version:       1.25.0.0+copyright:     2003-2016, Cabal Development Team (see AUTHORS file)+license:       BSD3+license-file:  LICENSE+author:        Cabal Development Team <cabal-devel@haskell.org>+maintainer:    cabal-devel@haskell.org+homepage:      http://www.haskell.org/cabal/+bug-reports:   https://github.com/haskell/cabal/issues+synopsis:      Test suite for Cabal and cabal-install+description:+  This package defines a shared test suite for Cabal and cabal-install.+category:       Distribution+cabal-version:  >=1.10+build-type:     Custom++extra-source-files:+  README.md++  -- Generated with 'misc/gen-extra-source-files.sh'+  -- Do NOT edit this section manually; instead, run the script.+  -- BEGIN gen-extra-source-files+  PackageTests/AllowNewer/AllowNewer.cabal+  PackageTests/AllowNewer/benchmarks/Bench.hs+  PackageTests/AllowNewer/src/Foo.hs+  PackageTests/AllowNewer/tests/Test.hs+  PackageTests/AllowOlder/AllowOlder.cabal+  PackageTests/AllowOlder/benchmarks/Bench.hs+  PackageTests/AllowOlder/src/Foo.hs+  PackageTests/AllowOlder/tests/Test.hs+  PackageTests/Ambiguity/p/Dupe.hs+  PackageTests/Ambiguity/p/p.cabal+  PackageTests/Ambiguity/package-import/A.hs+  PackageTests/Ambiguity/package-import/package-import.cabal+  PackageTests/Ambiguity/q/Dupe.hs+  PackageTests/Ambiguity/q/q.cabal+  PackageTests/Ambiguity/reexport-test/Main.hs+  PackageTests/Ambiguity/reexport-test/reexport-test.cabal+  PackageTests/Ambiguity/reexport/reexport.cabal+  PackageTests/AutogenModules/Package/Dummy.hs+  PackageTests/AutogenModules/Package/MyBenchModule.hs+  PackageTests/AutogenModules/Package/MyExeModule.hs+  PackageTests/AutogenModules/Package/MyLibModule.hs+  PackageTests/AutogenModules/Package/MyLibrary.hs+  PackageTests/AutogenModules/Package/MyTestModule.hs+  PackageTests/AutogenModules/Package/my.cabal+  PackageTests/AutogenModules/SrcDist/Dummy.hs+  PackageTests/AutogenModules/SrcDist/MyBenchModule.hs+  PackageTests/AutogenModules/SrcDist/MyExeModule.hs+  PackageTests/AutogenModules/SrcDist/MyLibModule.hs+  PackageTests/AutogenModules/SrcDist/MyLibrary.hs+  PackageTests/AutogenModules/SrcDist/MyTestModule.hs+  PackageTests/AutogenModules/SrcDist/my.cabal+  PackageTests/Backpack/Includes1/A.hs+  PackageTests/Backpack/Includes1/B.hs+  PackageTests/Backpack/Includes1/Includes1.cabal+  PackageTests/Backpack/Includes2/Includes2.cabal+  PackageTests/Backpack/Includes2/exe/Main.hs+  PackageTests/Backpack/Includes2/exe/exe.cabal+  PackageTests/Backpack/Includes2/fail.cabal+  PackageTests/Backpack/Includes2/mylib/Mine.hs+  PackageTests/Backpack/Includes2/mylib/mylib.cabal+  PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs+  PackageTests/Backpack/Includes2/mysql/mysql.cabal+  PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs+  PackageTests/Backpack/Includes2/postgresql/postgresql.cabal+  PackageTests/Backpack/Includes2/src/App.hs+  PackageTests/Backpack/Includes2/src/src.cabal+  PackageTests/Backpack/Includes3/Includes3.cabal+  PackageTests/Backpack/Includes3/exe/Main.hs+  PackageTests/Backpack/Includes3/exe/exe.cabal+  PackageTests/Backpack/Includes3/indef/Foo.hs+  PackageTests/Backpack/Includes3/indef/indef.cabal+  PackageTests/Backpack/Includes3/sigs/sigs.cabal+  PackageTests/Backpack/Includes4/Includes4.cabal+  PackageTests/Backpack/Includes4/Main.hs+  PackageTests/Backpack/Includes4/impl/A.hs+  PackageTests/Backpack/Includes4/impl/B.hs+  PackageTests/Backpack/Includes4/impl/Rec.hs+  PackageTests/Backpack/Includes4/indef/C.hs+  PackageTests/Backpack/Includes5/A.hs+  PackageTests/Backpack/Includes5/B.hs+  PackageTests/Backpack/Includes5/Includes5.cabal+  PackageTests/Backpack/Includes5/impl/Foobar.hs+  PackageTests/Backpack/Includes5/impl/Quxbaz.hs+  PackageTests/Backpack/Indef1/Indef1.cabal+  PackageTests/Backpack/Indef1/Provide.hs+  PackageTests/Backpack/Reexport1/p/P.hs+  PackageTests/Backpack/Reexport1/p/p.cabal+  PackageTests/Backpack/Reexport1/q/Q.hs+  PackageTests/Backpack/Reexport1/q/q.cabal+  PackageTests/BenchmarkExeV10/Foo.hs+  PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs+  PackageTests/BenchmarkExeV10/my.cabal+  PackageTests/BenchmarkOptions/BenchmarkOptions.cabal+  PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs+  PackageTests/BenchmarkStanza/my.cabal+  PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal+  PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs+  PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal+  PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs+  PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary0/my.cabal+  PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs+  PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary1/my.cabal+  PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs+  PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary2/my.cabal+  PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs+  PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal+  PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary3/my.cabal+  PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs+  PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal+  PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary4/my.cabal+  PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs+  PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs+  PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal+  PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs+  PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal+  PackageTests/BuildDeps/SameDepsAllRound/lemon.hs+  PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs+  PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs+  PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs+  PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal+  PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs+  PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs+  PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal+  PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs+  PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs+  PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal+  PackageTests/BuildTargetErrors/BuildTargetErrors.cabal+  PackageTests/BuildTargetErrors/Main.hs+  PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs+  PackageTests/BuildToolsPath/A.hs+  PackageTests/BuildToolsPath/MyCustomPreprocessor.hs+  PackageTests/BuildToolsPath/build-tools-path.cabal+  PackageTests/BuildToolsPath/hello/Hello.hs+  PackageTests/BuildableField/BuildableField.cabal+  PackageTests/BuildableField/Main.hs+  PackageTests/CMain/Bar.hs+  PackageTests/CMain/foo.c+  PackageTests/CMain/my.cabal+  PackageTests/CaretOperator/my.cabal+  PackageTests/Configure/A.hs+  PackageTests/Configure/Setup.hs+  PackageTests/Configure/include/HsZlibConfig.h.in+  PackageTests/Configure/zlib.buildinfo.in+  PackageTests/Configure/zlib.cabal+  PackageTests/ConfigureComponent/Exe/Bad.hs+  PackageTests/ConfigureComponent/Exe/Exe.cabal+  PackageTests/ConfigureComponent/Exe/Good.hs+  PackageTests/ConfigureComponent/SubLib/Lib.cabal+  PackageTests/ConfigureComponent/SubLib/Lib.hs+  PackageTests/ConfigureComponent/SubLib/exe/Exe.hs+  PackageTests/ConfigureComponent/Test/Lib.hs+  PackageTests/ConfigureComponent/Test/Test.cabal+  PackageTests/ConfigureComponent/Test/testlib/TestLib.hs+  PackageTests/ConfigureComponent/Test/testlib/testlib.cabal+  PackageTests/ConfigureComponent/Test/tests/Test.hs+  PackageTests/CopyComponent/Exe/Main.hs+  PackageTests/CopyComponent/Exe/Main2.hs+  PackageTests/CopyComponent/Exe/myprog.cabal+  PackageTests/CopyComponent/Lib/Main.hs+  PackageTests/CopyComponent/Lib/p.cabal+  PackageTests/CopyComponent/Lib/src/P.hs+  PackageTests/CustomPreProcess/Hello.hs+  PackageTests/CustomPreProcess/MyCustomPreprocessor.hs+  PackageTests/CustomPreProcess/Setup.hs+  PackageTests/CustomPreProcess/internal-preprocessor-test.cabal+  PackageTests/DeterministicAr/Lib.hs+  PackageTests/DeterministicAr/my.cabal+  PackageTests/DuplicateModuleName/DuplicateModuleName.cabal+  PackageTests/DuplicateModuleName/src/Foo.hs+  PackageTests/DuplicateModuleName/tests/Foo.hs+  PackageTests/DuplicateModuleName/tests2/Foo.hs+  PackageTests/EmptyLib/empty/empty.cabal+  PackageTests/ForeignLibs/UseLib.c+  PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c+  PackageTests/ForeignLibs/my-foreign-lib.cabal+  PackageTests/ForeignLibs/src/MyForeignLib/AnotherVal.hs+  PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs+  PackageTests/ForeignLibs/src/MyForeignLib/SomeBindings.hsc+  PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal+  PackageTests/GhcPkgGuess/SameDirectory/ghc+  PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg+  PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal+  PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10+  PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10+  PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal+  PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10+  PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10+  PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal+  PackageTests/GhcPkgGuess/Symlink/bin/ghc+  PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg+  PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal+  PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10+  PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10+  PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal+  PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10+  PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10+  PackageTests/Haddock/CPP.hs+  PackageTests/Haddock/Literate.lhs+  PackageTests/Haddock/NoCPP.hs+  PackageTests/Haddock/Simple.hs+  PackageTests/Haddock/my.cabal+  PackageTests/HaddockNewline/A.hs+  PackageTests/HaddockNewline/HaddockNewline.cabal+  PackageTests/HaddockNewline/Setup.hs+  PackageTests/InternalLibraries/Executable/exe/Main.hs+  PackageTests/InternalLibraries/Executable/foo.cabal+  PackageTests/InternalLibraries/Executable/src/Foo.hs+  PackageTests/InternalLibraries/Library/fooexe/Main.hs+  PackageTests/InternalLibraries/Library/fooexe/fooexe.cabal+  PackageTests/InternalLibraries/Library/foolib/Foo.hs+  PackageTests/InternalLibraries/Library/foolib/foolib.cabal+  PackageTests/InternalLibraries/Library/foolib/private/Internal.hs+  PackageTests/InternalLibraries/p/Foo.hs+  PackageTests/InternalLibraries/p/p.cabal+  PackageTests/InternalLibraries/p/p/P.hs+  PackageTests/InternalLibraries/p/q/Q.hs+  PackageTests/InternalLibraries/q/Q.hs+  PackageTests/InternalLibraries/q/q.cabal+  PackageTests/InternalLibraries/r/R.hs+  PackageTests/InternalLibraries/r/r.cabal+  PackageTests/Macros/A.hs+  PackageTests/Macros/B.hs+  PackageTests/Macros/Main.hs+  PackageTests/Macros/macros.cabal+  PackageTests/Macros/src/C.hs+  PackageTests/Options.hs+  PackageTests/OrderFlags/Foo.hs+  PackageTests/OrderFlags/my.cabal+  PackageTests/PathsModule/Executable/Main.hs+  PackageTests/PathsModule/Executable/my.cabal+  PackageTests/PathsModule/Library/my.cabal+  PackageTests/PreProcess/Foo.hsc+  PackageTests/PreProcess/Main.hs+  PackageTests/PreProcess/my.cabal+  PackageTests/PreProcessExtraSources/Foo.hsc+  PackageTests/PreProcessExtraSources/Main.hs+  PackageTests/PreProcessExtraSources/my.cabal+  PackageTests/ReexportedModules/containers-dupe/Data/Map.hs+  PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal+  PackageTests/ReexportedModules/p/Private.hs+  PackageTests/ReexportedModules/p/Public.hs+  PackageTests/ReexportedModules/p/fail-ambiguous.cabal+  PackageTests/ReexportedModules/p/fail-missing.cabal+  PackageTests/ReexportedModules/p/fail-other.cabal+  PackageTests/ReexportedModules/p/p.cabal+  PackageTests/ReexportedModules/q/A.hs+  PackageTests/ReexportedModules/q/q.cabal+  PackageTests/Regression/T2971/p/include/T2971test.h+  PackageTests/Regression/T2971/p/p.cabal+  PackageTests/Regression/T2971/q/Bar.hsc+  PackageTests/Regression/T2971/q/Foo.hs+  PackageTests/Regression/T2971/q/q.cabal+  PackageTests/Regression/T2971a/Main.hsc+  PackageTests/Regression/T2971a/T2971a.cabal+  PackageTests/Regression/T2971a/include/T2971a.h+  PackageTests/Regression/T3294/T3294.cabal+  PackageTests/Regression/T3847/Main.hs+  PackageTests/Regression/T3847/T3847.cabal+  PackageTests/Regression/T4025/A.hs+  PackageTests/Regression/T4025/T4025.cabal+  PackageTests/Regression/T4025/exe/Main.hs+  PackageTests/TemplateHaskell/dynamic/Exe.hs+  PackageTests/TemplateHaskell/dynamic/Lib.hs+  PackageTests/TemplateHaskell/dynamic/TH.hs+  PackageTests/TemplateHaskell/dynamic/my.cabal+  PackageTests/TemplateHaskell/profiling/Exe.hs+  PackageTests/TemplateHaskell/profiling/Lib.hs+  PackageTests/TemplateHaskell/profiling/TH.hs+  PackageTests/TemplateHaskell/profiling/my.cabal+  PackageTests/TemplateHaskell/vanilla/Exe.hs+  PackageTests/TemplateHaskell/vanilla/Lib.hs+  PackageTests/TemplateHaskell/vanilla/TH.hs+  PackageTests/TemplateHaskell/vanilla/my.cabal+  PackageTests/TestNameCollision/child/Child.hs+  PackageTests/TestNameCollision/child/child.cabal+  PackageTests/TestNameCollision/child/tests/Test.hs+  PackageTests/TestNameCollision/parent/Parent.hs+  PackageTests/TestNameCollision/parent/parent.cabal+  PackageTests/TestOptions/TestOptions.cabal+  PackageTests/TestOptions/test-TestOptions.hs+  PackageTests/TestStanza/my.cabal+  PackageTests/TestSuiteTests/ExeV10/Foo.hs+  PackageTests/TestSuiteTests/ExeV10/my.cabal+  PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs+  PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs+  PackageTests/TestSuiteTests/LibV09/Lib.hs+  PackageTests/TestSuiteTests/LibV09/LibV09.cabal+  PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs+  PackageTests/UniqueIPID/P1/M.hs+  PackageTests/UniqueIPID/P1/my.cabal+  PackageTests/UniqueIPID/P2/M.hs+  PackageTests/UniqueIPID/P2/my.cabal+  PackageTests/multInst/my.cabal+  -- END gen-extra-source-files++source-repository head+  type:     git+  location: https://github.com/haskell/cabal/+  subdir:   cabal-testsuite++-- Large, system tests that build packages.+test-suite package-tests+  type: exitcode-stdio-1.0+  main-is: PackageTests.hs+  other-modules:+    PackageTests.AutogenModules.Package.Check+    PackageTests.AutogenModules.SrcDist.Check+    PackageTests.BenchmarkStanza.Check+    PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check+    PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check+    PackageTests.CaretOperator.Check+    PackageTests.DeterministicAr.Check+    PackageTests.ForeignLibs.Check+    PackageTests.TestStanza.Check+    PackageTests.TestSuiteTests.ExeV10.Check+    PackageTests.PackageTester+    PackageTests.Tests+  build-depends:+    base,+    containers,+    tagged,+    tasty,+    tasty-hunit,+    transformers,+    time,+    Cabal,+    process,+    directory,+    filepath,+    bytestring,+    regex-posix,+    old-time+  if !os(windows)+    build-depends: unix, exceptions+  ghc-options: -Wall -rtsopts+  default-extensions: CPP+  default-language: Haskell2010++custom-setup+  setup-depends: Cabal >= 1.25,+                 base
+ cabal/cabal.project view
@@ -0,0 +1,17 @@+packages: Cabal/ cabal-testsuite/ cabal-install/+constraints: unix >= 2.7.1.0++-- Uncomment to allow picking up extra local unpacked deps:+--optional-packages: */++program-options+  -- So us hackers get all the assertion failures early:+  -- NOTE: currently commented out, see https://github.com/haskell/cabal/issues/3911+  -- ghc-options: -fno-ignore-asserts+  -- as a workaround we specify it for each package individually:+package Cabal+  ghc-options: -fno-ignore-asserts+package cabal-testsuite+  ghc-options: -fno-ignore-asserts+package cabal-install+  ghc-options: -fno-ignore-asserts
+ cabal/cabal.project.travis view
@@ -0,0 +1,13 @@+-- Force error messages to be better+-- Parallel new-build error messages are non-existent.+-- Turn off parallelization to get good errors.+jobs: 1++-- The -fno-warn-orphans is a hack to make Cabal-1.24+-- build properly (unfortunately the flags here get applied+-- to the dependencies too!)+package Cabal+  ghc-options: -Werror -fno-warn-orphans++package cabal-install+  ghc-options: -Werror
+ cabal/id_rsa_cabal_website.aes256.enc view
binary file changed (absent → 3248 bytes)
− cabal/setup-dev.sh 
@@ -1,36 +0,0 @@-#!/bin/bash -x-SCRIPT_DIR="`dirname $0`"--die() {-    echo "$*"-    exit 1-}--setup() {-    # Extract parameters-    local NAME="$1"-    shift-    local DEPS="$@"-    # (Re-)create sandbox-    cabal sandbox delete # Ignore error status; probably just means sandbox doesn't exist-    cabal sandbox init || die "$NAME: Could not initialize sandbox"-    # Add dependencies-    for DEP in $DEPS; do-        cabal sandbox add-source "$DEP"-    done-    # Install dependencies-    cabal install --only-dependencies --enable-tests || die "$NAME: Could not install needed dependencies"-    # Build the 'Setup' executable-    ghc --make -threaded -i -i. Setup.hs || die "$NAME: Could not create 'Setup' executable"-    # Build the package-    local PACKAGEDB=`cabal exec -- sh -c 'echo $GHC_PACKAGE_PATH' | sed 's/:.*//'`-    echo "Cabal package DB location: $PACKAGEDB"-    ./Setup configure --enable-tests --package-db="$PACKAGEDB" || die "$NAME: 'configure' failed"-    ./Setup build || die "$NAME: 'build' failed"-    # Run tests-    ./Setup test || die "$1 'test' failed"-}--# Build-(cd ${SCRIPT_DIR}/Cabal         && setup "Cabal"                 ) || die "Failed to build Cabal"-(cd ${SCRIPT_DIR}/cabal-install && setup "cabal-install" ../Cabal) || die "Failed to build cabal-install"
cabal/stack.yaml view
@@ -1,39 +1,52 @@-flags:-  text:-    integer-simple: false+resolver: ghc-8.0.1 packages: - Cabal/ - cabal-install/ extra-deps:-- HTTP-4000.2.20+- ansi-terminal-0.6.2.3+- ansi-wl-pprint-0.6.7.3+- async-2.1.0+- base16-bytestring-0.1.1.6+- base64-bytestring-1.0.0.1+- clock-0.7.2+- cryptohash-sha256-0.11.100.1+- ed25519-0.0.5.0+- edit-distance-0.2.2.1+- exceptions-0.8.2.1+- hackage-security-0.5.2.2+- hashable-1.2.4.0+- haskell-lexer-1.0+- HTTP-4000.3.3 - mtl-2.2.1-- network-2.6.2.0-- network-uri-2.6.0.3+- network-2.6.2.1+- network-uri-2.6.1.0 - old-locale-1.0.0.7 - old-time-1.1.0.3-- parsec-3.1.9+- optparse-applicative-0.12.1.0+- parsec-3.1.11+- pretty-show-1.6.10+- primitive-0.6.1.0+- QuickCheck-2.8.2 - random-1.1-- stm-2.4.4-- text-1.2.1.1-- zlib-0.5.4.2--# test suite dependencies-- QuickCheck-2.8.1-- extensible-exceptions-0.1.1.4+- regex-base-0.93.2 - regex-posix-0.95.2-- tagged-0.8.0.1-- tasty-0.10.1.2+- regex-tdfa-1.2.2+- stm-2.4.4.1+- tagged-0.8.4+- tar-0.5.0.3+- tasty-0.11.0.3 - tasty-hunit-0.9.2-- tasty-quickcheck-0.8.3.2-- ansi-terminal-0.6.2.1-- async-2.0.2-- optparse-applicative-0.11.0.2-- regex-base-0.93.2-- regex-tdfa-rc-1.1.8.3+- tasty-quickcheck-0.8.4+- text-1.2.2.1 - tf-random-0.5+- transformers-compat-0.5.1.4 - unbounded-delays-0.1.0.9-- ansi-wl-pprint-0.6.7.2-- primitive-0.6-- transformers-compat-0.4.0.4--resolver: ghc-7.10+- zlib-0.6.1.1+flags: {}+nix:+  packages:+  - autoconf+  - automake+  - haskellPackages.happy+  - zlib+  - zlib.out
+ cabal/travis-bootstrap.sh view
@@ -0,0 +1,52 @@+#!/bin/sh++. ./travis-common.sh++# ---------------------------------------------------------------------+# Bootstrap cabal, to verify bootstrap.sh script works.+# ---------------------------------------------------------------------++bootstrap_jobs="-j"++(cd cabal-install && timed env EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh $bootstrap_jobs --no-doc)+timed $HOME/.cabal/bin/cabal --version+PATH=$HOME/.cabal/bin:$PATH++# ---------------------------------------------------------------------+# Verify that installation from tarball works.+# ---------------------------------------------------------------------++# The following scriptlet checks that the resulting source distribution can be+# built & installed.+install_from_tarball() {+   SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;+   export SRC_TGZ+   if [ -f "dist/$SRC_TGZ" ]; then+      cabal install --force-reinstalls $jobs "dist/$SRC_TGZ" -v2;+   else+      echo "expected 'dist/$SRC_TGZ' not found";+      exit 1;+   fi+}++timed cabal update++# NB: The cabal cleans here hack around an sdist bug where+# the bootstrapped Cabal/cabal-install may be built+# without a Paths_* module available.  Under some situations+# which I have not been able to reproduce except on Travis,+# cabal sdist will incorrectly pick up the left over dist+# directory from the bootstrap and then try to package+# up the Paths module, but to no avail because it is not+# available.  I ran out of patience trying to debug this+# issue, and it is easy enough to work around: clean first.++echo Cabal+(cd Cabal && timed cabal clean) || exit $?+(cd Cabal && timed cabal sdist) || exit $?+(cd Cabal && timed install_from_tarball) || exit $?++echo cabal-install+(cd cabal-install && timed cabal clean) || exit $?+(cd cabal-install && timed cabal sdist) || exit $?+(cd cabal-install && timed install_from_tarball) || exit $?
+ cabal/travis-common.sh view
@@ -0,0 +1,33 @@+set -e++CABAL_VERSION="1.25.0.0"++# ---------------------------------------------------------------------+# Timing / diagnostic output+# ---------------------------------------------------------------------++JOB_START_TIME=$(date +%s)++timed() {+    echo "\$ $*"+    start_time=$(date +%s)++	# Run the job+    $* || exit $?++	# Calculate the durations+    end_time=$(date +%s)+    duration=$((end_time - start_time))+	total_duration=$((end_time - JOB_START_TIME))++	# Print them+    echo "$* took $duration seconds."+    echo "whole job took $total_duration seconds so far."++	# Terminate on OSX+	if [ $total_duration -ge 2400 -a $(uname) = "Darwin" ]; then+		echo "Job taking over 40 minutes. Terminating"+		exit 1+	fi+    echo "----"+}
+ cabal/travis-deploy.sh view
@@ -0,0 +1,27 @@+#!/bin/sh+set -ex++deploy() {+    git config --global user.email "builds@travis-ci.org"+    git config --global user.name "Travis CI User"+    git clone https://github.com/haskell/cabal-website.git cabal-website+    (cd cabal-website && git checkout --track -b gh-pages origin/gh-pages)+    rm -rf cabal-website/doc+    mkdir -p cabal-website/doc/html+    mv dist-newstyle/build/Cabal-1.25.0.0/doc/html/Cabal \+       cabal-website/doc/html/Cabal+    (cd cabal-website && git add --all .)+    (cd cabal-website && \+            git commit --amend --reset-author -m "Deploy to GitHub ($(date)).")+    (cd cabal-website && \+            git push --force git@github.com:haskell/cabal-website.git \+                gh-pages:gh-pages)+}++if [ "x$TRAVIS_REPO_SLUG" = "xhaskell/cabal" \+                          -a "x$TRAVIS_PULL_REQUEST" = "xfalse" \+                          -a "x$TRAVIS_BRANCH" = "xmaster" \+                          -a "x$DEPLOY_DOCS" = "xYES" ]+then+    deploy+fi
+ cabal/travis-install.sh view
@@ -0,0 +1,79 @@+#!/bin/sh+set -ex++travis_retry () {+    $*  || (sleep 1 && $*) || (sleep 2 && $*)+}++if [ "$GHCVER" = "none" ]; then+    travis_retry sudo add-apt-repository -y ppa:hvr/ghc+    travis_retry sudo apt-get update+    travis_retry sudo apt-get install --force-yes ghc-$GHCVER+fi++if [ -z ${STACKAGE_RESOLVER+x} ]; then+    if [ "$TRAVIS_OS_NAME" = "linux" ]; then+        travis_retry sudo add-apt-repository -y ppa:hvr/ghc+        travis_retry sudo apt-get update+        travis_retry sudo apt-get install --force-yes cabal-install-1.24 happy-1.19.5 alex-3.1.7 ghc-$GHCVER-prof ghc-$GHCVER-dyn+        if [ "x$TEST_OTHER_VERSIONS" = "xYES" ]; then travis_retry sudo apt-get install --force-yes ghc-7.0.4-prof ghc-7.0.4-dyn ghc-7.2.2-prof ghc-7.2.2-dyn ghc-head-prof ghc-head-dyn; fi++    elif [ "$TRAVIS_OS_NAME" = "osx" ]; then++        case $GHCVER in+            8.0.1)+                GHCURL=http://downloads.haskell.org/~ghc/8.0.1/ghc-8.0.1-x86_64-apple-darwin.tar.xz;+                GHCXZ=YES+                ;;+            7.10.3)+                GHCURL=http://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3b-x86_64-apple-darwin.tar.xz+                GHCXZ=YES+                ;;+            7.8.4)+                GHCURL=https://www.haskell.org/ghc/dist/7.8.4/ghc-7.8.4-x86_64-apple-darwin.tar.xz+                GHCXZ=YES+                ;;+            7.6.3)+                GHCURL=https://www.haskell.org/ghc/dist/7.6.3/ghc-7.6.3-x86_64-apple-darwin.tar.bz2+                ;;+            7.4.2)+                GHCURL=https://www.haskell.org/ghc/dist/7.4.2/ghc-7.4.2-x86_64-apple-darwin.tar.bz2+                ;;+            *)+                echo "Unknown GHC: $GHCVER"+                false+                ;;+        esac++        travis_retry curl -OL $GHCURL+        if [ "$GHCXZ" = "YES" ]; then+            tar -xJf ghc-*.tar.*;+        else+            tar -xjf ghc-*.tar.*;+        fi++        cd ghc-*;+        ./configure --prefix=$HOME/.ghc-install/$GHCVER+        make install;+        cd ..;++        travis_retry curl -L https://www.haskell.org/cabal/release/cabal-install-1.24.0.0/cabal-install-1.24.0.0-x86_64-apple-darwin-yosemite.tar.gz -o cabal-install.tar.gz+        TAR=$PWD/cabal-install.tar.gz+        mkdir "${HOME}/bin"+        (cd "${HOME}/bin" && tar -xzf "$TAR")+        "${HOME}/bin/cabal" --version++    else+        echo "Not linux or osx: $TRAVIS_OS_NAME"+        false+    fi++else # Stack-based builds+    mkdir -p ~/.local/bin+    travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 \+        | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'+    stack setup --resolver "$STACKAGE_RESOLVER"++fi++git version
+ cabal/travis-meta.sh view
@@ -0,0 +1,20 @@+#!/bin/sh++. ./travis-common.sh++# ---------------------------------------------------------------------+# Check that auto-generated files/fields are up to date.+# ---------------------------------------------------------------------++# Regenerate the CONTRIBUTORS file.+# Currently doesn't work because Travis uses --depth=50 when cloning.+#./Cabal/misc/gen-authors.sh > AUTHORS++# Regenerate the 'extra-source-files' field in Cabal.cabal.+(cd Cabal && timed ./misc/gen-extra-source-files.hs Cabal.cabal) || exit $?++# Regenerate the 'extra-source-files' field in cabal-install.cabal.+(cd cabal-install && ../Cabal/misc/gen-extra-source-files.hs cabal-install.cabal) || exit $?++# Fail if the diff is not empty.+timed ./Cabal/misc/travis-diff-files.sh
cabal/travis-script.sh view
@@ -1,91 +1,137 @@-#!/usr/bin/env bash-set -ev+#!/bin/sh -# Initial working directory: base directory of Git repository+# ATTENTION! Before editing this file, maybe you can make a+# separate script to do your test?  We don't want individual+# Travis builds to take too long (they time out at 50min and+# it's generally unpleasant if the build takes that long.)+# If you make a separate matrix entry in .travis.yml it can+# be run in parallel. -# We depend on parsec nowadays, which isn't distributed with GHC <8.0-if [ "$PARSEC_BUNDLED" != "YES" ]; then-    cabal install parsec+. ./travis-common.sh++CABAL_STORE_DB="${HOME}/.cabal/store/ghc-${GHCVER}/package.db"+CABAL_LOCAL_DB="${PWD}/dist-newstyle/packagedb/ghc-${GHCVER}"+CABAL_BDIR="${PWD}/dist-newstyle/build/Cabal-${CABAL_VERSION}"+CABAL_TESTSUITE_BDIR="${PWD}/dist-newstyle/build/cabal-testsuite-${CABAL_VERSION}"+CABAL_INSTALL_BDIR="${PWD}/dist-newstyle/build/cabal-install-${CABAL_VERSION}"+CABAL_INSTALL_SETUP="${CABAL_INSTALL_BDIR}/setup/setup"+# --hide-successes uses terminal control characters which mess up+# Travis's log viewer.  So just print them all!+TEST_OPTIONS=""++# ---------------------------------------------------------------------+# Update the Cabal index+# ---------------------------------------------------------------------++timed cabal update++# ---------------------------------------------------------------------+# Install happy if necessary+# ---------------------------------------------------------------------++if ! command -v happy; then+    timed cabal install happy fi  # ---------------------------------------------------------------------+# Setup our local project+# ---------------------------------------------------------------------++cp cabal.project.travis cabal.project.local++# --------------------------------------------------------------------- # Cabal # --------------------------------------------------------------------- -cd Cabal+# Needed to work around some bugs in nix-local-build code.+export CABAL_BUILDDIR="${CABAL_BDIR}" -# Test if gen-extra-source-files.sh was run recently enough-./misc/gen-extra-source-files.sh Cabal.cabal-./misc/travis-diff-files.sh+# NB: Best to do everything for a single package together as it's+# more efficient (since new-build will uselessly try to rebuild+# Cabal otherwise).+if [ "x$PARSEC" = "xYES" ]; then+  timed cabal new-build -fparsec Cabal Cabal:unit-tests Cabal:parser-tests Cabal:parser-hackage-tests+else+  timed cabal new-build Cabal Cabal:unit-tests+fi -cd ../cabal-install-../Cabal/misc/gen-extra-source-files.sh cabal-install.cabal-../Cabal/misc/travis-diff-files.sh+# NB: the '|| exit $?' workaround is required on old broken versions of bash+# that ship with OS X. See https://github.com/haskell/cabal/pull/3624 and+# http://stackoverflow.com/questions/14970663/why-doesnt-bash-flag-e-exit-when-a-subshell-fails -cd ../Cabal+# Run tests+(cd Cabal && timed ${CABAL_BDIR}/build/unit-tests/unit-tests       $TEST_OPTIONS) || exit $? -# Build the setup script in the same way that cabal-install would:-mkdir -p ./dist/setup-cp Setup.hs ./dist/setup/setup.hs-ghc --make \-    -odir ./dist/setup -hidir ./dist/setup -i -i. \-    ./dist/setup/setup.hs -o ./dist/setup/setup \-    -Wall -Werror -threaded+if [ "x$PARSEC" = "xYES" ]; then+    # Parser unit tests+    (cd Cabal && timed ${CABAL_BDIR}/build/parser-tests/parser-tests $TEST_OPTIONS) || exit $? -# Install test dependencies only after setup is built-cabal install --only-dependencies --enable-tests --enable-benchmarks-./dist/setup/setup configure \-    --user --ghc-option=-Werror --enable-tests --enable-benchmarks \-    -v2 # -v2 provides useful information for debugging+    # Test we can parse Hackage+    (cd Cabal && timed ${CABAL_BDIR}/build/parser-tests/parser-hackage-tests $TEST_OPTIONS) | tail || exit $?+fi -# Build all libraries and executables (including tests/benchmarks)-./dist/setup/setup build-./dist/setup/setup haddock # see https://github.com/haskell/cabal/issues/2198-./dist/setup/setup test --show-details=streaming --test-option=--hide-successes+# Run haddock (hack: use the Setup script from package-tests!)+(cd Cabal && timed cabal act-as-setup --build-type=Simple -- haddock --builddir=${CABAL_BDIR}) || exit $? +# Check for package warnings+(cd Cabal && timed cabal check) || exit $?++unset CABAL_BUILDDIR++# Build and run the package tests++export CABAL_BUILDDIR="${CABAL_TESTSUITE_BDIR}"++timed cabal new-build cabal-testsuite:package-tests++(cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS) || exit $?+ # Redo the package tests with different versions of GHC-if [ "$TEST_OLDER" == "YES" ]; then-    CABAL_PACKAGETESTS_WITH_GHC=/opt/ghc/7.0.4/bin/ghc \-        ./dist/setup/setup test package-tests --show-details=streaming-    CABAL_PACKAGETESTS_WITH_GHC=/opt/ghc/7.2.2/bin/ghc \-        ./dist/setup/setup test package-tests --show-details=streaming+if [ "x$TEST_OTHER_VERSIONS" = "xYES" ]; then+    (export CABAL_PACKAGETESTS_WITH_GHC="/opt/ghc/7.0.4/bin/ghc"; \+        cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS)+    (export CABAL_PACKAGETESTS_WITH_GHC="/opt/ghc/7.2.2/bin/ghc"; \+        cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS)+    (export CABAL_PACKAGETESTS_WITH_GHC="/opt/ghc/head/bin/ghc"; \+        cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS) fi -cabal check-cabal sdist   # tests that a source-distribution can be generated--# The following scriptlet checks that the resulting source distribution can be-# built & installed.-function install_from_tarball {-   export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;-   if [ -f "dist/$SRC_TGZ" ]; then-      cabal install -j1 "dist/$SRC_TGZ" -v2;-   else-      echo "expected 'dist/$SRC_TGZ' not found";-      exit 1;-   fi-}+unset CABAL_BUILDDIR -install_from_tarball+if [ "x$CABAL_LIB_ONLY" = "xYES" ]; then+    exit 0;+fi  # --------------------------------------------------------------------- # cabal-install # --------------------------------------------------------------------- -cd ../cabal-install+# Needed to work around some bugs in nix-local-build code.+export CABAL_BUILDDIR="${CABAL_INSTALL_BDIR}" -cabal install happy-cabal install --only-dependencies --enable-tests --enable-benchmarks-cabal configure \-    --user --ghc-option=-Werror --enable-tests --enable-benchmarks \-    -v2 # -v2 provides useful information for debugging-cabal build-cabal haddock # see https://github.com/haskell/cabal/issues/2198-cabal test unit-tests --show-details=streaming --test-option=--hide-successes-cabal test integration-tests --show-details=streaming --test-option=--hide-successes-cabal check-./dist/setup/setup sdist-install_from_tarball+timed cabal new-build cabal-install:cabal \+                      cabal-install:integration-tests \+                      cabal-install:integration-tests2 \+                      cabal-install:unit-tests \+                      cabal-install:solver-quickcheck +# The integration-tests2 need the hackage index, and need it in the secure+# format, which is not necessarily the default format of the bootstrap cabal.+# If the format does match then this will be very quick.+timed ${CABAL_INSTALL_BDIR}/build/cabal/cabal update++# Run tests+(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/unit-tests/unit-tests         $TEST_OPTIONS) || exit $?+(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/solver-quickcheck/solver-quickcheck  $TEST_OPTIONS --quickcheck-tests=1000) || exit $?+(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/integration-tests/integration-tests  $TEST_OPTIONS) || exit $?+(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/integration-tests2/integration-tests2 $TEST_OPTIONS) || exit $?++# Haddock+(cd cabal-install && timed ${CABAL_INSTALL_SETUP} haddock --builddir=${CABAL_INSTALL_BDIR} ) || exit $?++(cd cabal-install && timed cabal check) || exit $?++unset CABAL_BUILDDIR+ # Check what we got-$HOME/.cabal/bin/cabal --version+${CABAL_INSTALL_BDIR}/build/cabal/cabal --version
+ cabal/travis-solver-debug-flags.sh view
@@ -0,0 +1,16 @@+#!/bin/sh++# Build cabal with solver debug flags enabled.+#+# We use a sandbox, because cabal-install-1.24.0.0's new-build command tries to+# build tracetree's dependencies with the inplace Cabal, which leads to compile+# errors. We also need to skip the tests, because debug-tracetree prints the+# whole solver tree as JSON.++cabal update+cd cabal-install+cabal sandbox init+cabal sandbox add-source ../Cabal+cabal install --dependencies-only --constraint "cabal-install +debug-tracetree +debug-conflict-sets"+cabal configure --ghc-option=-Werror --constraint "cabal-install +debug-tracetree +debug-conflict-sets"+cabal build
+ cabal/travis-stack.sh view
@@ -0,0 +1,17 @@+#!/bin/sh++if [ -z ${STACKAGE_RESOLVER+x} ]; then+    echo "STACKAGE_RESOLVER environment variable not set."+    echo "This build case is not configured correctly."+    exit 1+fi++. ./travis-common.sh++# ---------------------------------------------------------------------+# Build Cabal via Stack(age).+# ---------------------------------------------------------------------++stack build \+    --no-terminal \+    --resolver "$STACKAGE_RESOLVER"
+ cabal/update-cabal-files.sh view
@@ -0,0 +1,4 @@+#!/bin/sh+(cd Cabal; misc/gen-extra-source-files.hs Cabal.cabal)+(cd cabal-testsuite; ../Cabal/misc/gen-extra-source-files.hs cabal-testsuite.cabal)+(cd cabal-install; ../Cabal/misc/gen-extra-source-files.hs cabal-install.cabal)
hackage-security/.gitignore view
@@ -3,3 +3,4 @@ prototype-state/server/ prototype-state/offline/ .stack-work/+dist-newstyle
hackage-security/.travis.yml view
@@ -23,9 +23,12 @@     - env: CABALVER=1.18 GHCVER=7.8.4       compiler: ": #GHC 7.8.4"       addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}-    - env: CABALVER=1.22 GHCVER=7.10.2-      compiler: ": #GHC 7.10.2"-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}+    - env: CABALVER=1.22 GHCVER=7.10.3+      compiler: ": #GHC 7.10.3"+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}+    - env: CABALVER=1.24 GHCVER=8.0.1+      compiler: ": #GHC 8.0.1"+      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}  before_install:  - unset CC
hackage-security/hackage-repo-tool/hackage-repo-tool.cabal view
@@ -45,7 +45,7 @@                        filepath             >= 1.2  && < 1.5,                        optparse-applicative >= 0.11 && < 0.13,                        tar                  >= 0.4  && < 0.6,-                       time                 >= 1.2  && < 1.6,+                       time                 >= 1.2  && < 1.7,                        unix                 >= 2.5  && < 2.8,                        zlib                 >= 0.5  && < 0.7,                        hackage-security     >= 0.5  && < 0.6
hackage-security/hackage-root-tool/Main.hs view
@@ -32,6 +32,10 @@         file' <- makeAbsolute (fromFilePath file)         signFile key' file' +      GetKeyId key -> do+        key'  <- makeAbsolute (fromFilePath key)+        getKeyId key'+ -- | Top-level exception handler that uses 'displayException' -- -- Although base 4.8 introduces 'displayException', the top-level exception@@ -91,6 +95,17 @@     writeJSON_NoLayout (fp <.> "sig") newSig  {-------------------------------------------------------------------------------+  Retrieving the key id of a key+-------------------------------------------------------------------------------}++getKeyId :: KeyLoc -> IO ()+getKeyId keyLoc = do+    pubkey :: Some PublicKey <-+      throwErrors =<< readJSON_NoKeys_NoLayout keyLoc+    let keyid = keyIdString (someKeyId pubkey)+    logInfo $ "The keyid of this key is:\n  " ++ keyid++{-------------------------------------------------------------------------------   Logging -------------------------------------------------------------------------------} @@ -123,6 +138,9 @@     -- | Sign an individual file   | Sign FilePath FilePath +    -- | Get the key id of a key file+  | GetKeyId FilePath+ type KeyLoc = Path Absolute  {-------------------------------------------------------------------------------@@ -145,6 +163,10 @@   <$> argument str (metavar "KEY")   <*> argument str (metavar "FILE") +parseGetKeyId :: Parser Command+parseGetKeyId = GetKeyId+  <$> argument str (metavar "KEY")+ -- | Global options -- -- TODO: Make repo and keys layout configurable@@ -156,4 +178,6 @@             progDesc "Create keys"         , command "sign" $ info (helper <*> parseSign) $             progDesc "Sign a file"+        , command "keyid" $ info (helper <*> parseGetKeyId) $+            progDesc "Get the KeyId of a key file"         ])
hackage-security/hackage-root-tool/hackage-root-tool.cabal view
@@ -28,7 +28,7 @@   build-depends:       base                 >= 4.4  && < 5,                        filepath             >= 1.2  && < 1.5,                        optparse-applicative >= 0.11 && < 0.13,-                       hackage-security     >= 0.2  && < 0.6+                       hackage-security     >= 0.5  && < 0.6   default-language:    Haskell2010   other-extensions:    CPP, ScopedTypeVariables, RecordWildCards   ghc-options:         -Wall
hackage-security/hackage-security-http-client/hackage-security-http-client.cabal view
@@ -20,7 +20,7 @@   build-depends:       base               >= 4.4,                        bytestring         >= 0.9,                        data-default-class >= 0.0,-                       http-client        >= 0.4,+                       http-client        >= 0.4 && < 0.5,                        http-types         >= 0.8,                        hackage-security   >= 0.5 && < 0.6   hs-source-dirs:      src
hackage-security/hackage-security/ChangeLog.md view
@@ -1,3 +1,37 @@+0.5.2.2+-------++* Fix client in case where server provides MD5 hashes+  (ignore them, use only SHA256)+* Fix warnings with GHC 8++0.5.2.1+-------++* Fix accidental breakage with GHC 8++0.5.2.0+-------++* Change path handling to work on Windows (#162).+* Add new MD5 hash type (#163). This is not for security (only SHA256 is+  used for verification) but to provide as metadata to help with other+  services like mirroring (e.g. HTTP & S3 use MD5 checksum headers).+* Adjust reading of JSON maps to ignore unknown keys. This allows adding+  e.g. new hash types in future without breaking existing clients.+* Fix build warnings on GHC 8+++0.5.1.0+-------++* Fix for other local programs corrputing the 00-index.tar. Detect it+  and do a full rewrite rather than incremental append.+* New JSON pretty-printer (not canonical rendering)+* Round-trip tests for Canonical JSON parser and printers+* Minor fix for Canonical JSON parser+* Switch from cryptohash to cryptohash-sha256 to avoid new dependencies+ 0.5.0.2 ------- * Use tar 0.5.0
hackage-security/hackage-security/hackage-security.cabal view
@@ -1,5 +1,5 @@ name:                hackage-security-version:             0.5.0.2+version:             0.5.2.2 synopsis:            Hackage security library description:         The hackage security library provides both server and                      client utilities for securing the Hackage package server@@ -18,13 +18,11 @@                      clients (the typical example being @cabal@), and                      "Hackage.Security.Server" is the main entry point for                      servers (the typical example being @hackage-server@).-                     .-                     This is a beta release. license:             BSD3 license-file:        LICENSE author:              Edsko de Vries maintainer:          edsko@well-typed.com-copyright:           Copyright 2015 Well-Typed LLP+copyright:           Copyright 2015-2016 Well-Typed LLP category:            Distribution homepage:            https://github.com/well-typed/hackage-security bug-reports:         https://github.com/well-typed/hackage-security/issues@@ -46,6 +44,11 @@   description: Are we using network-uri?   manual: False +Flag old-directory+  description: Use directory < 1.2 and old-time+  manual:      False+  default:     False+ library   -- Most functionality is exported through the top-level entry points .Client   -- and .Server; the other exported modules are intended for qualified imports.@@ -93,6 +96,7 @@                        Prelude   -- We support ghc 7.4 (bundled with Cabal 1.14) and up   build-depends:       base              >= 4.5     && < 5,+                       base16-bytestring >= 0.1.1   && < 0.2,                        base64-bytestring >= 1.0     && < 1.1,                        bytestring        >= 0.9     && < 0.11,                        Cabal             >= 1.14    && < 1.26,@@ -102,7 +106,8 @@                        filepath          >= 1.2     && < 1.5,                        mtl               >= 2.2     && < 2.3,                        parsec            >= 3.1     && < 3.2,-                       cryptohash        >= 0.11    && < 0.12,+                       pretty            >= 1.0     && < 1.2,+                       cryptohash-sha256 >= 0.11    && < 0.12,                        -- 0.4.2 introduces TarIndex, 0.4.4 introduces more                        -- functionality, 0.5.0 changes type of serialise                        tar               >= 0.5     && < 0.6,@@ -112,6 +117,10 @@                        -- whatever versions are bundled with ghc:                        template-haskell,                        ghc-prim+  if flag(old-directory)+    build-depends:     directory <  1.2, old-time >= 1 && < 1.2+  else+    build-depends:     directory >= 1.2   hs-source-dirs:      src   default-language:    Haskell2010   default-extensions:  DefaultSignatures@@ -203,9 +212,11 @@ test-suite TestSuite   type:                exitcode-stdio-1.0   main-is:             TestSuite.hs-  other-modules:       TestSuite.InMemCache+  other-modules:       TestSuite.HttpMem+                       TestSuite.InMemCache                        TestSuite.InMemRepo                        TestSuite.InMemRepository+                       TestSuite.JSON                        TestSuite.PrivateKeys                        TestSuite.Util.StrictMVar   build-depends:       base,@@ -218,6 +229,8 @@                        tar,                        tasty,                        tasty-hunit,+                       tasty-quickcheck,+                       QuickCheck,                        temporary,                        time,                        zlib
hackage-security/hackage-security/src/Hackage/Security/Client.hs view
@@ -110,8 +110,7 @@     -- root information and start over. However, in order to prevent DoS attacks     -- we limit how often we go round this loop.     -- See als <https://github.com/theupdateframework/tuf/issues/287>.-    limitIterations :: (Throws VerificationError, Throws SomeRemoteError)-                    => VerificationHistory -> IO HasUpdates+    limitIterations :: VerificationHistory -> IO HasUpdates     limitIterations history | length history >= maxNumIterations =         throwChecked $ VerificationErrorLoop (reverse history)     limitIterations history = do@@ -333,7 +332,13 @@       DontCache  -> Nothing  -- | Get all cached info (if any)-getCachedInfo :: (Applicative m, MonadIO m) => Repository down -> m CachedInfo+getCachedInfo ::+#if __GLASGOW_HASKELL__ < 800+                 (Applicative m, MonadIO m)+#else+                 MonadIO m+#endif+              => Repository down -> m CachedInfo getCachedInfo rep = do     (cachedRoot, cachedKeyEnv) <- readLocalRoot rep     cachedTimestamp <- readLocalFile rep cachedKeyEnv CachedTimestamp@@ -354,8 +359,10 @@                     readCachedJSON rep KeyEnv.empty cachedPath     return (trustLocalFile signedRoot, rootKeys (signed signedRoot)) -readLocalFile :: ( FromJSON ReadJSON_Keys_Layout (Signed a)-                 , MonadIO m, Applicative m+readLocalFile :: ( FromJSON ReadJSON_Keys_Layout (Signed a), MonadIO m+#if __GLASGOW_HASKELL__ < 800+                 , Applicative m+#endif                  )               => Repository down -> KeyEnv -> CachedFile -> m (Maybe (Trusted a)) readLocalFile rep cachedKeyEnv file = do@@ -802,7 +809,9 @@         }   where     indexPath :: Tar.Entry -> IndexPath-    indexPath = rootPath . fromUnrootedFilePath . Tar.entryPath+    indexPath = rootPath . fromUnrootedFilePath+              . Tar.fromTarPathToPosixPath+              . Tar.entryTarPath      indexFile :: IndexPath -> Maybe (Some IndexFile)     indexFile = indexFileFromPath repIndexLayout
hackage-security/hackage-security/src/Hackage/Security/Client/Formats.hs view
@@ -113,4 +113,3 @@ formatsLookup (HFS hf)  (FsUn   _  ) = hasFormatAbsurd hf formatsLookup (HFS hf)  (FsGz     _) = hasFormatAbsurd hf formatsLookup (HFS hf)  (FsUnGz _ a) = formatsLookup hf (FsGz a)-formatsLookup _         _            = error "inaccessible"
hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs view
@@ -403,17 +403,17 @@  -- | Is a particular remote file cached? data IsCached :: * -> * where-    -- | This remote file should be cached, and we ask for it by name+    -- This remote file should be cached, and we ask for it by name     CacheAs :: CachedFile -> IsCached Metadata -    -- | We don't cache this remote file+    -- We don't cache this remote file     --     -- This doesn't mean a Repository should not feel free to cache the file     -- if desired, but it does mean the generic algorithms will never ask for     -- this file from the cache.     DontCache :: IsCached Binary -    -- | The index is somewhat special: it should be cached, but we never+    -- The index is somewhat special: it should be cached, but we never     -- ask for it directly.     --     -- Instead, we will ask the Repository for files _from_ the index, which it@@ -422,6 +422,7 @@     -- keep an index tarball index for quick access, others may scan the tarball     -- linearly, etc.     CacheIndex :: IsCached Binary+--TODO: ^^ older haddock doesn't support GADT doc comments :-(  deriving instance Eq   (IsCached typ) deriving instance Show (IsCached typ)
hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs view
@@ -16,6 +16,7 @@  import Control.Exception import Control.Monad+import Data.Maybe import Codec.Archive.Tar (Entries(..)) import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset) import qualified Codec.Archive.Tar       as Tar@@ -58,21 +59,51 @@       downloadedCopyTo downloaded fp      -- Whether or not we downloaded the compressed index incrementally, we can-    -- always update the uncompressed index incrementally.+    -- update the uncompressed index incrementally (assuming the local files+    -- have not been corrupted).     -- NOTE: This assumes we already updated the compressed file.-    unzipIndex :: typ ~ Binary => IO ()+    unzipIndex :: IO ()     unzipIndex = do         createDirectoryIfMissing True (takeDirectory indexUn)-        compressed <- readLazyByteString indexGz-        let uncompressed = GZip.decompress compressed-        withFile indexUn ReadWriteMode $ \h -> do-          currentSize <- hFileSize h-          let seekTo = 0 `max` (currentSize - tarTrailer)-          hSeek h AbsoluteSeek seekTo-          BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed+        shouldTryIncremenal <- cachedIndexProbablyValid+        if shouldTryIncremenal+          then unzipIncremenal+          else unzipNonIncremenal       where-        indexGz = cachedIndexPath cache FGz-        indexUn = cachedIndexPath cache FUn+        unzipIncremenal = do+          compressed <- readLazyByteString indexGz+          let uncompressed = GZip.decompress compressed+          withFile indexUn ReadWriteMode $ \h -> do+            currentSize <- hFileSize h+            let seekTo = 0 `max` (currentSize - tarTrailer)+            hSeek h AbsoluteSeek seekTo+            BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed++        unzipNonIncremenal = do+          compressed <- readLazyByteString indexGz+          let uncompressed = GZip.decompress compressed+          withFile indexUn WriteMode $ \h ->+            BS.L.hPut h uncompressed+          void . handleDoesNotExist $+            removeFile indexIdx -- Force a full rebuild of the index too++        -- When we update the 00-index.tar we also update the 00-index.tar.idx+        -- so the expected state is that the modification time for the tar.idx+        -- is the same or later than the .tar file. But if someone modified+        -- the 00-index.tar then the modification times will be reversed. So,+        -- if the modification times are reversed then we should not do an+        -- incremental update but should rewrite the whole file.+        cachedIndexProbablyValid :: IO Bool+        cachedIndexProbablyValid =+          fmap (fromMaybe False) $+          handleDoesNotExist $ do+            tsUn  <- getModificationTime indexUn+            tsIdx <- getModificationTime indexIdx+            return (tsIdx >= tsUn)++        indexGz  = cachedIndexPath cache FGz+        indexUn  = cachedIndexPath cache FUn+        indexIdx = cachedIndexIdxPath cache      tarTrailer :: Integer     tarTrailer = 1024
hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs view
@@ -92,8 +92,6 @@ verifyLocalFile (LocalFile fp) trustedInfo = do     -- Verify the file size before comparing the entire file info     sz <- FileLength <$> getFileSize fp-    if sz /= fileInfoLength+    if sz /= fileInfoLength (trusted trustedInfo)       then return False-      else knownFileInfoEqual info <$> computeFileInfo fp-  where-    info@FileInfo{..} = trusted trustedInfo+      else compareTrustedFileInfo (trusted trustedInfo) <$> computeFileInfo fp
hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs view
@@ -299,24 +299,25 @@  -- | Download method (downloading or updating) data DownloadMethod :: * -> * -> * where-    -- | Download this file (we never attempt to update this type of file)+    -- Download this file (we never attempt to update this type of file)     NeverUpdated :: {         neverUpdatedFormat :: HasFormat fs f       } -> DownloadMethod fs typ -    -- | Download this file (we cannot update this file right now)+    -- Download this file (we cannot update this file right now)     CannotUpdate :: {         cannotUpdateFormat :: HasFormat fs f       , cannotUpdateReason :: UpdateFailure       } -> DownloadMethod fs Binary -    -- | Attempt an (incremental) update of this file+    -- Attempt an (incremental) update of this file     Update :: {         updateFormat :: HasFormat fs f       , updateInfo   :: Trusted FileInfo       , updateLocal  :: Path Absolute       , updateTail   :: Int54       } -> DownloadMethod fs Binary+--TODO: ^^ older haddock doesn't support GADT doc comments :-(  pickDownloadMethod :: forall fs typ. RemoteConfig                    -> AttemptNr@@ -362,8 +363,7 @@ getFile cfg@RemoteConfig{..} attemptNr remoteFile method =     go method   where-    go :: Throws SomeRemoteError-       => DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)+    go :: DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)     go NeverUpdated{..} = do         cfgLogger $ LogDownloading remoteFile         download neverUpdatedFormat@@ -379,8 +379,7 @@     headers = httpRequestHeaders cfg attemptNr      -- Get any file from the server, without using incremental updates-    download :: Throws SomeRemoteError => HasFormat fs f-             -> Verify (Some (HasFormat fs), RemoteTemp typ)+    download :: HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)     download format = do         (tempPath, h) <- openTempFile (Cache.cacheRoot cfgCache) (uriTemplate uri)         liftIO $ do@@ -446,6 +445,12 @@                                 (mustCache remoteFile)         return (Some format, remoteTemp) +    httpGetRange :: forall a. Throws SomeRemoteError+                 => [HttpRequestHeader]+                 -> URI+                 -> (Int, Int)+                 -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+                 -> IO a     HttpLib{..} = cfgHttpLib  {-------------------------------------------------------------------------------@@ -598,15 +603,16 @@         wholeTemp :: Path Absolute       } -> RemoteTemp a -    -- | If we download only the delta, we record both the path to where the+    -- If we download only the delta, we record both the path to where the     -- "old" file is stored and the path to the temp file containing the delta.     -- Then:     ---    -- * When we verify the file, we need both of these paths if we compute+    --   When we verify the file, we need both of these paths if we compute     --   the hash from scratch, or only the path to the delta if we attempt     --   to compute the hash incrementally (TODO: incremental verification     --   not currently implemented).-    -- * When we copy a file over, we are additionally given a destination+    --+    --   When we copy a file over, we are additionally given a destination     --   path. In this case, we expect that destination path to be equal to     --   the path to the old file (and assert this to be the case).     DownloadedDelta :: {@@ -614,6 +620,8 @@       , deltaExisting :: Path Absolute       , deltaSeek     :: Int54       -- ^ How much of the existing file to keep       } -> RemoteTemp Binary+--TODO: ^^ older haddock doesn't support GADT doc comments :-(+--      and add the '*' bullet points back in  instance Pretty (RemoteTemp typ) where     pretty DownloadedWhole{..} = intercalate " " $ [@@ -650,9 +658,10 @@ verifyRemoteFile :: RemoteTemp typ -> Trusted FileInfo -> IO Bool verifyRemoteFile remoteTemp trustedInfo = do     sz <- FileLength <$> remoteSize remoteTemp-    if sz /= fileInfoLength+    if sz /= fileInfoLength (trusted trustedInfo)       then return False-      else withRemoteBS remoteTemp $ knownFileInfoEqual info . fileInfo+      else withRemoteBS remoteTemp $+             compareTrustedFileInfo (trusted trustedInfo) . fileInfo   where     remoteSize :: RemoteTemp typ -> IO Int54     remoteSize DownloadedWhole{..} = getFileSize wholeTemp@@ -676,8 +685,6 @@                 BS.L.take (fromIntegral deltaSeek) existing               , temp               ]--    info@FileInfo{..} = trusted trustedInfo  {-------------------------------------------------------------------------------   Auxiliary: multiple exit points
hackage-security/hackage-security/src/Hackage/Security/Key.hs view
@@ -29,9 +29,11 @@ import Data.Functor.Identity import Data.Typeable (Typeable) import Text.JSON.Canonical-import qualified Crypto.Hash          as CH+import qualified Crypto.Hash.SHA256   as SHA256 import qualified Crypto.Sign.Ed25519  as Ed25519 import qualified Data.ByteString      as BS+import qualified Data.ByteString.Char8 as BS.C8+import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as BS.L  #if !MIN_VERSION_base(4,7,0)@@ -151,7 +153,7 @@   toObjectKey = return . keyIdString  instance Monad m => FromObjectKey m KeyId where-  fromObjectKey = return . KeyId+  fromObjectKey = return . Just . KeyId  -- | Compute the key ID of a key class HasKeyId key where@@ -159,8 +161,9 @@  instance HasKeyId PublicKey where   keyId = KeyId-        . show-        . (CH.hashlazy :: BS.L.ByteString -> CH.Digest CH.SHA256)+        . BS.C8.unpack+        . Base16.encode+        . SHA256.hashlazy         . renderCanonicalJSON         . runIdentity         . toJSON
hackage-security/hackage-security/src/Hackage/Security/TUF/FileInfo.hs view
@@ -6,6 +6,7 @@     -- * Utility   , fileInfo   , computeFileInfo+  , compareTrustedFileInfo   , knownFileInfoEqual   , fileInfoSHA256     -- ** Re-exports@@ -14,9 +15,11 @@  import Prelude hiding (lookup) import Data.Map (Map)-import qualified Crypto.Hash          as CH+import qualified Crypto.Hash.SHA256   as SHA256 import qualified Data.Map             as Map+import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as BS.L+import qualified Data.ByteString.Char8 as BS.C8  import Hackage.Security.JSON import Hackage.Security.TUF.Common@@ -27,6 +30,7 @@ -------------------------------------------------------------------------------}  data HashFn = HashFnSHA256+            | HashFnMD5   deriving (Show, Eq, Ord)  -- | File information@@ -58,7 +62,10 @@ fileInfo bs = FileInfo {       fileInfoLength = FileLength . fromIntegral $ BS.L.length bs     , fileInfoHashes = Map.fromList [-          (HashFnSHA256, Hash $ show (CH.hashlazy bs :: CH.Digest CH.SHA256))+          -- Note: if you add or change hash functions here and you want to+          -- make them compulsory then you also need to update+          -- 'compareTrustedFileInfo' below.+          (HashFnSHA256, Hash $ BS.C8.unpack $ Base16.encode $ SHA256.hashlazy bs)         ]     } @@ -66,11 +73,34 @@ computeFileInfo :: FsRoot root => Path root -> IO FileInfo computeFileInfo fp = fileInfo <$> readLazyByteString fp --- | Compare known file info+-- | Compare the expected trusted file info against the actual file info of a+-- target file. ----- This should be used only when the FileInfo is already known. If we want to--- compare known FileInfo against a file on disk we should delay until we know--- have confirmed that the file lengths don't match (see 'verifyFileInfo').+-- This should be used only when the 'FileInfo' is already known. If we want+-- to compare known 'FileInfo' against a file on disk we should delay until we+-- have confirmed that the file lengths match (see 'downloadedVerify').+--+compareTrustedFileInfo :: FileInfo -- ^ expected (from trusted TUF files)+                       -> FileInfo -- ^ actual (from 'fileInfo' on target file)+                       -> Bool+compareTrustedFileInfo expectedInfo actualInfo =+    -- The expected trusted file info may have hashes for several hash+    -- functions, including ones we do not care about and do not want to+    -- check. In particular the file info may have an md5 hash, but this+    -- is not one that we want to check.+    --+    -- Our current policy is to check sha256 only and ignore md5:+    sameLength expectedInfo actualInfo+ && sameSHA256 expectedInfo actualInfo+  where+    sameLength a b = fileInfoLength a+                  == fileInfoLength b++    sameSHA256 a b = case (fileInfoSHA256 a,+                           fileInfoSHA256 b) of+                       (Just ha, Just hb) -> ha == hb+                       _                  -> False+ knownFileInfoEqual :: FileInfo -> FileInfo -> Bool knownFileInfoEqual a b = (==) (fileInfoLength a, fileInfoHashes a)                               (fileInfoLength b, fileInfoHashes b)@@ -85,10 +115,12 @@  instance Monad m => ToObjectKey m HashFn where   toObjectKey HashFnSHA256 = return "sha256"+  toObjectKey HashFnMD5    = return "md5"  instance ReportSchemaErrors m => FromObjectKey m HashFn where-  fromObjectKey "sha256" = return HashFnSHA256-  fromObjectKey str      = expected "valid hash function" (Just str)+  fromObjectKey "sha256" = return (Just HashFnSHA256)+  fromObjectKey "md5"    = return (Just HashFnMD5)+  fromObjectKey _        = return Nothing  instance Monad m => ToJSON m FileInfo where   toJSON FileInfo{..} = mkObject [
hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs view
@@ -127,8 +127,7 @@  instance ReportSchemaErrors m => FromObjectKey m TargetPath where   fromObjectKey ('<':'r':'e':'p':'o':'>':'/':path) =-    return . TargetPathRepo  . rootPath . fromUnrootedFilePath $ path+    return . Just . TargetPathRepo  . rootPath . fromUnrootedFilePath $ path   fromObjectKey ('<':'i':'n':'d':'e':'x':'>':'/':path) =-    return . TargetPathIndex . rootPath . fromUnrootedFilePath $ path-  fromObjectKey str =-    expected "target path" (Just str)+    return . Just . TargetPathIndex . rootPath . fromUnrootedFilePath $ path+  fromObjectKey _str = return Nothing
hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Index.hs view
@@ -9,8 +9,6 @@   , indexLayoutPkgPrefs   ) where -import qualified System.FilePath as FP- import Distribution.Package import Distribution.Text @@ -45,14 +43,15 @@ -- the global preferred-versions file. But supporting legacy Hackage will -- probably require more work anyway.. data IndexFile :: * -> * where-    -- | Package-specific metadata (@targets.json@)+    -- Package-specific metadata (@targets.json@)     IndexPkgMetadata :: PackageIdentifier -> IndexFile (Signed Targets) -    -- | Cabal file for a package+    -- Cabal file for a package     IndexPkgCabal :: PackageIdentifier -> IndexFile () -    -- | Preferred versions a package+    -- Preferred versions a package     IndexPkgPrefs :: PackageName -> IndexFile ()+--TODO: ^^ older haddock doesn't support GADT doc comments :-(  deriving instance Show (IndexFile dec) @@ -68,7 +67,7 @@ hackageIndexLayout :: IndexLayout hackageIndexLayout = IndexLayout {       indexFileToPath   = toPath-    , indexFileFromPath = fromPath . toUnrootedFilePath . unrootPath+    , indexFileFromPath = fromPath     }   where     toPath :: IndexFile dec -> IndexPath@@ -90,16 +89,16 @@     fromFragments :: [String] -> IndexPath     fromFragments = rootPath . joinFragments -    fromPath :: FilePath -> Maybe (Some IndexFile)-    fromPath fp = case FP.splitPath fp of-      [pkg, version, file] -> do-        pkgId <- simpleParse (init pkg ++ "-" ++ init version)-        case FP.takeExtension file of+    fromPath :: IndexPath -> Maybe (Some IndexFile)+    fromPath fp = case splitFragments (unrootPath fp) of+      [pkg, version, _file] -> do+        pkgId <- simpleParse (pkg ++ "-" ++ version)+        case takeExtension fp of           ".cabal"   -> return $ Some $ IndexPkgCabal    pkgId           ".json"    -> return $ Some $ IndexPkgMetadata pkgId           _otherwise -> Nothing       [pkg, "preferred-versions"] ->-        Some . IndexPkgPrefs <$> simpleParse (init pkg)+        Some . IndexPkgPrefs <$> simpleParse pkg       _otherwise -> Nothing  {-------------------------------------------------------------------------------
hackage-security/hackage-security/src/Hackage/Security/TUF/Paths.hs view
@@ -37,7 +37,7 @@ instance Pretty (Path RepoRoot) where   pretty (Path fp) = "<repo>/" ++ fp -anchorRepoPathLocally :: FsRoot root => Path root -> RepoPath -> Path root+anchorRepoPathLocally :: Path root -> RepoPath -> Path root anchorRepoPathLocally localRoot repoPath = localRoot </> unrootPath repoPath  anchorRepoPathRemotely :: Path Web -> RepoPath -> Path Web@@ -68,5 +68,5 @@     pretty (Path fp) = "<cache>/" ++ fp  -- | Anchor a cache path to the location of the cache-anchorCachePath :: FsRoot root => Path root -> CachePath -> Path root+anchorCachePath :: Path root -> CachePath -> Path root anchorCachePath cacheRoot cachePath = cacheRoot </> unrootPath cachePath
hackage-security/hackage-security/src/Hackage/Security/TUF/Patterns.hs view
@@ -27,7 +27,7 @@  import Control.Monad.Except import Language.Haskell.TH (Q, Exp)-import System.FilePath+import System.FilePath.Posix import qualified Language.Haskell.TH.Syntax as TH  import Hackage.Security.JSON
hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif  #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations     #-}
hackage-security/hackage-security/src/Hackage/Security/Util/JSON.hs view
@@ -24,6 +24,7 @@   ) where  import Control.Monad (liftM)+import Data.Maybe (catMaybes) import Data.Map (Map) import Data.Time import Text.JSON.Canonical@@ -54,7 +55,7 @@  -- | Used in the 'FromJSON' instance for 'Map' class FromObjectKey m a where-  fromObjectKey :: String -> m a+  fromObjectKey :: String -> m (Maybe a)  -- | Monads in which we can report schema errors class (Applicative m, Monad m) => ReportSchemaErrors m where@@ -85,13 +86,13 @@   toObjectKey = return  instance Monad m => FromObjectKey m String where-  fromObjectKey = return+  fromObjectKey = return . Just  instance Monad m => ToObjectKey m (Path root) where   toObjectKey (Path fp) = return fp  instance Monad m => FromObjectKey m (Path root) where-  fromObjectKey = liftM Path . fromObjectKey+  fromObjectKey = liftM (fmap Path) . fromObjectKey  {-------------------------------------------------------------------------------   ToJSON and FromJSON instances@@ -162,10 +163,13 @@          ) => FromJSON m (Map k a) where   fromJSON enc = do       obj <- fromJSObject enc-      Map.fromList <$> mapM aux obj+      Map.fromList . catMaybes <$> mapM aux obj     where-      aux :: (String, JSValue) -> m (k, a)-      aux (k, a) = (,) <$> fromObjectKey k <*> fromJSON a+      aux :: (String, JSValue) -> m (Maybe (k, a))+      aux (k, a) = knownKeys <$> fromObjectKey k <*> fromJSON a+      knownKeys :: Maybe k -> a -> Maybe (k, a)+      knownKeys Nothing  _ = Nothing+      knownKeys (Just k) a = Just (k, a)  instance Monad m => ToJSON m URI where   toJSON = toJSON . show
hackage-security/hackage-security/src/Hackage/Security/Util/Path.hs view
@@ -17,6 +17,7 @@   , takeFileName   , (<.>)   , splitExtension+  , takeExtension     -- * Unrooted paths   , Unrooted   , (</>)@@ -26,6 +27,7 @@   , fromUnrootedFilePath   , fragment   , joinFragments+  , splitFragments   , isPathPrefixOf     -- * File-system paths   , Relative@@ -53,6 +55,7 @@   , removeDirectory   , doesFileExist   , doesDirectoryExist+  , getModificationTime   , removeFile   , getTemporaryDirectory   , getDirectoryContents@@ -84,9 +87,15 @@ import Data.List (isPrefixOf) import System.IO (IOMode(..), BufferMode(..), Handle, SeekMode(..)) import System.IO.Unsafe (unsafeInterleaveIO)+#if MIN_VERSION_directory(1,2,0)+import Data.Time (UTCTime)+#else+import System.Time (ClockTime)+#endif import qualified Data.ByteString         as BS import qualified Data.ByteString.Lazy    as BS.L-import qualified System.FilePath         as FP+import qualified System.FilePath         as FP.Native+import qualified System.FilePath.Posix   as FP.Posix import qualified System.IO               as IO import qualified System.Directory        as Dir import qualified Codec.Archive.Tar       as Tar@@ -109,9 +118,21 @@ -- make sense to append two absolute paths together; instead, we can only append -- an unrooted path to another path. It also means we avoid bugs where we use -- one kind of path where we expect another.-newtype Path a = Path { unPath :: FilePath }+newtype Path a = Path FilePath -- always a Posix style path internally   deriving (Show, Eq, Ord) +mkPathNative :: FilePath -> Path a+mkPathNative = Path . FP.Posix.joinPath . FP.Native.splitDirectories++unPathNative :: Path a -> FilePath+unPathNative (Path fp) = FP.Native.joinPath . FP.Posix.splitDirectories $ fp++mkPathPosix :: FilePath -> Path a+mkPathPosix = Path++unPathPosix :: Path a -> FilePath+unPathPosix (Path fp) = fp+ -- | Reinterpret the root of a path -- -- This literally just changes the type-level tag; use with caution!@@ -123,19 +144,22 @@ -------------------------------------------------------------------------------}  takeDirectory :: Path a -> Path a-takeDirectory = liftFP FP.takeDirectory+takeDirectory = liftFP FP.Posix.takeDirectory  takeFileName :: Path a -> String-takeFileName = liftFromFP FP.takeFileName+takeFileName = liftFromFP FP.Posix.takeFileName  (<.>) :: Path a -> String -> Path a-fp <.> ext = liftFP (FP.<.> ext) fp+fp <.> ext = liftFP (FP.Posix.<.> ext) fp  splitExtension :: Path a -> (Path a, String) splitExtension (Path fp) = (Path fp', ext)   where-    (fp', ext) = FP.splitExtension fp+    (fp', ext) = FP.Posix.splitExtension fp +takeExtension :: Path a -> String+takeExtension (Path fp) = FP.Posix.takeExtension fp+ {-------------------------------------------------------------------------------   Unrooted paths -------------------------------------------------------------------------------}@@ -149,7 +173,7 @@   pretty (Path fp) = fp  (</>) :: Path a -> Path Unrooted -> Path a-(</>) = liftFP2 (FP.</>)+(</>) = liftFP2 (FP.Posix.</>)  -- | Reinterpret an unrooted path --@@ -163,19 +187,30 @@ unrootPath :: Path root -> Path Unrooted unrootPath (Path fp) = Path fp +-- | Convert a relative\/unrooted Path to a FilePath (using POSIX style+-- directory separators).+--+-- See also 'toAbsoluteFilePath'+-- toUnrootedFilePath :: Path Unrooted -> FilePath-toUnrootedFilePath = unPath+toUnrootedFilePath = unPathPosix +-- | Convert from a relative\/unrooted FilePath (using POSIX style directory+-- separators).+-- fromUnrootedFilePath :: FilePath -> Path Unrooted-fromUnrootedFilePath = Path+fromUnrootedFilePath = mkPathPosix  -- | A path fragment (like a single directory or filename) fragment :: String -> Path Unrooted-fragment = fromUnrootedFilePath+fragment = Path  joinFragments :: [String] -> Path Unrooted-joinFragments = liftToFP FP.joinPath+joinFragments = liftToFP FP.Posix.joinPath +splitFragments :: Path Unrooted -> [String]+splitFragments (Path fp) = FP.Posix.splitDirectories fp+ isPathPrefixOf :: Path Unrooted -> Path Unrooted -> Bool isPathPrefixOf = liftFromFP2 isPrefixOf @@ -198,30 +233,34 @@  -- | A file system root can be interpreted as an (absolute) FilePath class FsRoot root where+  -- | Convert a Path to an absolute FilePath (using native style directory separators).+  --   toAbsoluteFilePath :: Path root -> IO FilePath  instance FsRoot Relative where-    toAbsoluteFilePath (Path fp) = go fp+    toAbsoluteFilePath p = go (unPathNative p)       where         go :: FilePath -> IO FilePath #if MIN_VERSION_directory(1,2,2)         go = Dir.makeAbsolute #else         -- copied implementation from the directory package-        go = (FP.normalise <$>) . absolutize+        go = (FP.Native.normalise <$>) . absolutize         absolutize path -- avoid the call to `getCurrentDirectory` if we can-          | FP.isRelative path = (FP.</> path) . FP.addTrailingPathSeparator <$>-                                 Dir.getCurrentDirectory-          | otherwise          = return path+          | FP.Native.isRelative path+                      = (FP.Native.</> path)+                      . FP.Native.addTrailingPathSeparator <$>+                        Dir.getCurrentDirectory+          | otherwise = return path #endif  instance FsRoot Absolute where-    toAbsoluteFilePath (Path fp) = return fp+    toAbsoluteFilePath = return . unPathNative  instance FsRoot HomeDir where-    toAbsoluteFilePath (Path fp) = do+    toAbsoluteFilePath p = do       home <- Dir.getHomeDirectory-      return $ home FP.</> fp+      return $ home FP.Native.</> unPathNative p  -- | Abstract over a file system root --@@ -233,29 +272,29 @@ -------------------------------------------------------------------------------}  toFilePath :: Path Absolute -> FilePath-toFilePath (Path fp) = fp+toFilePath = unPathNative  fromFilePath :: FilePath -> FsPath fromFilePath fp-    | FP.isAbsolute      fp = FsPath (Path fp  :: Path Absolute)-    | Just fp' <- atHome fp = FsPath (Path fp' :: Path HomeDir)-    | otherwise             = FsPath (Path fp  :: Path Relative)+    | FP.Native.isAbsolute fp = FsPath (mkPathNative fp  :: Path Absolute)+    | Just fp' <- atHome fp   = FsPath (mkPathNative fp' :: Path HomeDir)+    | otherwise               = FsPath (mkPathNative fp  :: Path Relative)   where     -- TODO: I don't know if there a standard way that Windows users refer to     -- their home directory. For now, we'll only interpret '~'. Everybody else     -- can specify an absolute path if this doesn't work.     atHome :: FilePath -> Maybe FilePath     atHome "~" = Just ""-    atHome ('~':sep:fp') | FP.isPathSeparator sep = Just fp'+    atHome ('~':sep:fp') | FP.Native.isPathSeparator sep = Just fp'     atHome _otherwise = Nothing  makeAbsolute :: FsPath -> IO (Path Absolute)-makeAbsolute (FsPath p) = Path <$> toAbsoluteFilePath p+makeAbsolute (FsPath p) = mkPathNative <$> toAbsoluteFilePath p  fromAbsoluteFilePath :: FilePath -> Path Absolute fromAbsoluteFilePath fp-  | FP.isAbsolute fp = Path fp-  | otherwise        = error "fromAbsoluteFilePath: not an absolute path"+  | FP.Native.isAbsolute fp = mkPathNative fp+  | otherwise               = error "fromAbsoluteFilePath: not an absolute path"  {-------------------------------------------------------------------------------   Wrappers around System.IO@@ -331,6 +370,15 @@     filePath <- toAbsoluteFilePath path     Dir.doesDirectoryExist filePath +#if MIN_VERSION_directory(1,2,0)+getModificationTime :: FsRoot root => Path root -> IO UTCTime+#else+getModificationTime :: FsRoot root => Path root -> IO ClockTime+#endif+getModificationTime path = do+    filePath <- toAbsoluteFilePath path+    Dir.getModificationTime filePath+ removeFile :: FsRoot root => Path root -> IO () removeFile path = do     filePath <- toAbsoluteFilePath path@@ -348,7 +396,7 @@     fragments <$> Dir.getDirectoryContents filePath   where     fragments :: [String] -> [Path Unrooted]-    fragments = map fromUnrootedFilePath . filter (not . skip)+    fragments = map fragment . filter (not . skip)      skip :: String -> Bool     skip "."  = True@@ -374,7 +422,7 @@                        else return [path]      emptyPath :: Path Unrooted-    emptyPath = Path (FP.joinPath [])+    emptyPath = joinFragments []  renameFile :: (FsRoot root, FsRoot root')            => Path root  -- ^ Old@@ -416,7 +464,7 @@     Tar.append tarFile' baseDir' contents'   where     contents' :: [FilePath]-    contents' = map (toUnrootedFilePath . unrootPath) contents+    contents' = map (unPathNative . unrootPath) contents  {-------------------------------------------------------------------------------   Wrappers around Network.URI
hackage-security/hackage-security/src/Text/JSON/Canonical.hs view
@@ -9,7 +9,7 @@ -- -- <http://wiki.laptop.org/go/Canonical_JSON> ----- A "canonical JSON" format is provided in order to provide meaningful and+-- A \"canonical JSON\" format is provided in order to provide meaningful and -- repeatable hashes of JSON-encoded data. Canonical JSON is parsable with any -- full JSON parser, but security-conscious applications will want to verify -- that input is in canonical form before authenticating any hash or signature@@ -27,12 +27,18 @@   , Int54   , parseCanonicalJSON   , renderCanonicalJSON+  , prettyCanonicalJSON   ) where  import Text.ParserCombinators.Parsec          ( CharParser, (<|>), (<?>), many, between, sepBy          , satisfy, char, string, digit, spaces          , parse )+import Text.PrettyPrint hiding (char)+import qualified Text.PrettyPrint as Doc+#if !(MIN_VERSION_base(4,7,0))+import Control.Applicative ((<$>), (<$), pure, (<*>), (<*), (*>))+#endif import Control.Arrow (first) import Data.Bits (Bits) #if MIN_VERSION_base(4,7,0)@@ -68,8 +74,7 @@ -- probably define `fromInteger` to do bounds checking, give different instances -- for type classes such as `Bounded` and `FiniteBits`, etc. newtype Int54 = Int54 { int54ToInt64 :: Int64 }-  deriving ( Bounded-           , Enum+  deriving ( Enum            , Eq            , Integral            , Data@@ -86,6 +91,10 @@            , Typeable            ) +instance Bounded Int54 where+  maxBound = Int54 (  2^(53 :: Int) - 1)+  minBound = Int54 (-(2^(53 :: Int) - 1))+ instance Show Int54 where   show = show . int54ToInt64 @@ -93,9 +102,14 @@   readsPrec p = map (first Int54) . readsPrec p  ------------------------------------------------------------------------------+-- rendering flat+-- --- | Encode as \"Canonical\" JSON.+-- | Render a JSON value in canonical form. This rendered form is canonical+-- and so allows repeatable hashes. --+-- For pretty printing, see prettyCanonicalJSON.+-- -- NB: Canonical JSON's string escaping rules deviate from RFC 7159 -- JSON which requires --@@ -111,6 +125,7 @@ -- parser" -- -- Consequently, Canonical JSON is not a proper subset of RFC 7159.+-- renderCanonicalJSON :: JSValue -> BS.ByteString renderCanonicalJSON v = BS.pack (s_value v []) @@ -149,7 +164,15 @@                           . showl kvs  ------------------------------------------------------------------------------+-- parsing+-- +-- | Parse a canonical JSON format string as a JSON value. The input string+-- does not have to be in canonical form, just in the \"canonical JSON\"+-- format.+--+-- Use 'renderCanonicalJSON' to convert into canonical form.+-- parseCanonicalJSON :: BS.ByteString -> Either String JSValue parseCanonicalJSON = either (Left . show) Right                    . parse p_value ""@@ -213,7 +236,7 @@    \" -} p_string         :: CharParser () String-p_string          = between (tok (char '"')) (tok (char '"')) (many p_char)+p_string          = between (char '"') (tok (char '"')) (many p_char)   where p_char    =  (char '\\' >> p_esc)                  <|> (satisfy (\x -> x /= '"' && x /= '\\')) @@ -270,3 +293,63 @@ manyN 0 _ =  pure [] manyN n p =  ((:) <$> p <*> manyN (n-1) p)          <|> pure []++------------------------------------------------------------------------------+-- rendering nicely+--++-- | Render a JSON value in a reasonable human-readable form. This rendered+-- form is /not the canonical form/ used for repeatable hashes, use+-- 'renderCanonicalJSON' for that.++-- It is suitable however as an external form as any canonical JSON parser can+-- read it and convert it into the form used for repeatable hashes.+--+prettyCanonicalJSON :: JSValue -> String+prettyCanonicalJSON = render . jvalue++jvalue :: JSValue -> Doc+jvalue JSNull         = text "null"+jvalue (JSBool False) = text "false"+jvalue (JSBool True)  = text "true"+jvalue (JSNum n)      = integer (fromIntegral (int54ToInt64 n))+jvalue (JSString s)   = jstring s+jvalue (JSArray vs)   = jarray  vs+jvalue (JSObject fs)  = jobject fs++jstring :: String -> Doc+jstring = doubleQuotes . hcat . map jchar++jchar :: Char -> Doc+jchar '"'   = Doc.char '\\' <> Doc.char '"'+jchar '\\'  = Doc.char '\\' <> Doc.char '\\'+jchar c     = Doc.char c++jarray :: [JSValue] -> Doc+jarray = sep . punctuate' lbrack comma rbrack+       . map jvalue++jobject :: [(String, JSValue)] -> Doc+jobject = sep . punctuate' lbrace comma rbrace+        . map (\(k,v) -> sep [jstring k <> colon, nest 2 (jvalue v)])+++-- | Punctuate in this style:+--+-- > [ foo, bar ]+--+-- if it fits, or vertically otherwise:+--+-- > [ foo+-- > , bar+-- > ]+--+punctuate' :: Doc -> Doc -> Doc -> [Doc] -> [Doc]+punctuate' l _ r []     = [l <> r]+punctuate' l _ r [x]    = [l <+> x <+> r]+punctuate' l p r (x:xs) = l <+> x : go xs+  where+    go []     = []+    go [y]    = [p <+> y, r]+    go (y:ys) = (p <+> y) : go ys+
hackage-security/hackage-security/tests/TestSuite.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards, GADTs #-} module Main (main) where  -- stdlib@@ -8,14 +9,21 @@ import Network.URI (URI, parseURI) import Test.Tasty import Test.Tasty.HUnit+import Test.Tasty.QuickCheck hiding (label) import System.IO.Temp (withSystemTempDirectory)+import qualified Codec.Archive.Tar.Entry    as Tar+import qualified Data.ByteString.Lazy.Char8 as BS +-- Cabal+import Distribution.Package (PackageName(..))+ -- hackage-security import Hackage.Security.Client import Hackage.Security.Client.Repository import Hackage.Security.JSON (DeserializationError(..)) import Hackage.Security.Util.Checked import Hackage.Security.Util.Path+import Hackage.Security.Util.Some import Hackage.Security.Util.Pretty import qualified Hackage.Security.Client.Repository.Remote as Remote import qualified Hackage.Security.Client.Repository.Cache  as Cache@@ -27,6 +35,7 @@ import TestSuite.InMemRepository import TestSuite.PrivateKeys import TestSuite.Util.StrictMVar+import TestSuite.JSON as JSON  {-------------------------------------------------------------------------------   TestSuite driver@@ -43,6 +52,7 @@         , testCase "testInMemUpdatesAfterCron"     testInMemUpdatesAfterCron         , testCase "testInMemKeyRollover"          testInMemKeyRollover         , testCase "testInMemOutdatedTimestamp"    testInMemOutdatedTimestamp+        , testCase "testInMemIndex"                testInMemIndex         ]     , testGroup "HttpMem" [           testCase "testHttpMemInitialHasForUpdates" testHttpMemInitialHasUpdates@@ -50,7 +60,13 @@         , testCase "testHttpMemUpdatesAfterCron"     testHttpMemUpdatesAfterCron         , testCase "testHttpMemKeyRollover"          testHttpMemKeyRollover         , testCase "testHttpMemOutdatedTimestamp"    testHttpMemOutdatedTimestamp+        , testCase "testHttpMemIndex"                testHttpMemIndex         ]+    , testGroup "Canonical JSON" [+          testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical+        , testProperty "prop_roundtrip_pretty"    JSON.prop_roundtrip_pretty+        , testProperty "prop_canonical_pretty"    JSON.prop_canonical_pretty+        ]   ]  {-------------------------------------------------------------------------------@@ -124,6 +140,10 @@       withAssertLog "C" logMsgs [] $ do         assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater +testInMemIndex :: Assertion+testInMemIndex = inMemTest $ \inMemRepo _logMsgs repo ->+    testRepoIndex inMemRepo repo+ {-------------------------------------------------------------------------------   Same tests, but going through the "real" Remote repository and Cache, though   still using an in-memory repository (with a HttpLib bridge)@@ -194,6 +214,57 @@     catchVerificationLoop msgs $ do       withAssertLog "C" logMsgs [] $ do         assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater++testHttpMemIndex :: Assertion+testHttpMemIndex = httpMemTest $ \inMemRepo _logMsgs repo ->+    testRepoIndex inMemRepo repo++{-------------------------------------------------------------------------------+  Identical tests between the two variants+-------------------------------------------------------------------------------}++testRepoIndex :: (Throws SomeRemoteError, Throws VerificationError)+              => InMemRepo -> Repository down -> IO ()+testRepoIndex inMemRepo repo = do+    assertEqual "A" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    dir1 <- getDirectory repo+    directoryFirst dir1  @?= DirectoryEntry 0+    directoryNext  dir1  @?= DirectoryEntry 0+    length (directoryEntries dir1) @?= 0++    now <- getCurrentTime+    inMemRepoSetIndex inMemRepo now [testEntry1]++    assertEqual "B" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    dir2 <- getDirectory repo+    directoryFirst dir2  @?= DirectoryEntry 0+    directoryNext  dir2  @?= DirectoryEntry 2+    length (directoryEntries dir2) @?= 1+    directoryLookup dir2 testEntryIndexFile @?= Just (DirectoryEntry 0)+    withIndex repo $ \IndexCallbacks{..} -> do+      (sentry, next) <- indexLookupEntry (DirectoryEntry 0)+      next @?= Nothing+      case sentry of Some entry -> checkIndexEntry entry+  where+    checkIndexEntry :: IndexEntry dec -> Assertion+    checkIndexEntry entry = do+       toUnrootedFilePath (unrootPath (indexEntryPath entry))+         @?= "foo/preferred-versions"+       indexEntryContent entry @?= testEntrycontent+       case indexEntryPathParsed entry of+         Just (IndexPkgPrefs pkgname) -> do+           pkgname @?= PackageName "foo"+           case indexEntryContentParsed entry of+             Right () -> return ()+             _        -> fail "unexpected index entry content"+         _ -> fail "unexpected index path"++    testEntry1 = Tar.fileEntry path testEntrycontent+      where+        Right path = Tar.toTarPath False "foo/preferred-versions"+    testEntrycontent   = BS.pack "foo >= 1"+    testEntryIndexFile = IndexPkgPrefs (PackageName "foo")+  {-------------------------------------------------------------------------------   Log messages we expect when using the Remote repository
hackage-security/hackage-security/tests/TestSuite/InMemCache.hs view
@@ -8,8 +8,13 @@ import qualified Codec.Compression.GZip as GZip import qualified Data.ByteString.Lazy   as BS.L +-- tar+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Index as TarIndex+import           Codec.Archive.Tar.Index   (TarIndex)+ -- hackage-security-import Hackage.Security.Client+import Hackage.Security.Client hiding (withIndex) import Hackage.Security.Client.Formats import Hackage.Security.Client.Repository import Hackage.Security.JSON@@ -20,20 +25,25 @@ import TestSuite.InMemRepo  data InMemCache = InMemCache {-      inMemCacheGet     :: CachedFile -> IO (Maybe (Path Absolute))-    , inMemCacheGetRoot :: IO (Path Absolute)-    , inMemCacheClear   :: IO ()-    , inMemCachePut     :: forall f typ. InMemFile typ -> Format f -> IsCached typ -> IO ()+      inMemCacheGet         :: CachedFile -> IO (Maybe (Path Absolute))+    , inMemCacheGetRoot     :: IO (Path Absolute)+    , inMemCacheWithIndex   :: forall a. (Handle -> IO a) -> IO a+    , inMemCacheGetIndexIdx :: IO TarIndex+    , inMemCacheClear       :: IO ()+    , inMemCachePut         :: forall f typ. InMemFile typ -> Format f+                                          -> IsCached  typ -> IO ()     }  newInMemCache :: Path Absolute -> RepoLayout -> IO InMemCache newInMemCache tempDir layout = do     state <- newMVar $ initLocalState layout     return InMemCache {-        inMemCacheGet     = get     state tempDir-      , inMemCacheGetRoot = getRoot state tempDir-      , inMemCacheClear   = clear   state-      , inMemCachePut     = put     state+        inMemCacheGet         = get         state tempDir+      , inMemCacheGetRoot     = getRoot     state tempDir+      , inMemCacheWithIndex   = withIndex   state tempDir+      , inMemCacheGetIndexIdx = getIndexIdx state+      , inMemCacheClear       = clear       state+      , inMemCachePut         = put         state       }  {-------------------------------------------------------------------------------@@ -105,6 +115,26 @@ getRoot :: MVar LocalState -> Path Absolute -> IO (Path Absolute) getRoot state cacheTempDir =     needRoot `fmap` get state cacheTempDir CachedRoot++withIndex :: MVar LocalState -> Path Absolute -> (Handle -> IO a) -> IO a+withIndex state cacheTempDir action = do+    st <- readMVar state+    case cachedIndex st of+      Nothing -> error "InMemCache.withIndex: Could not read index."+      Just bs -> do+        (_, h) <- openTempFile' cacheTempDir "01-index.tar"+        BS.L.hPut h bs+        hSeek  h AbsoluteSeek 0+        x <- action h+        hClose h+        return x++getIndexIdx :: MVar LocalState -> IO TarIndex+getIndexIdx state = do+    st <- readMVar state+    case cachedIndex st of+      Nothing    -> error "InMemCache.getIndexIdx: Could not read index."+      Just index -> either throwIO return . TarIndex.build . Tar.read $ index  -- | Clear all cached data clear :: MVar LocalState -> IO ()
hackage-security/hackage-security/tests/TestSuite/InMemRepo.hs view
@@ -72,6 +72,9 @@      -- | Rollover the timestamp and snapshot keys   , inMemRepoKeyRollover :: UTCTime -> IO ()++    -- | Set the content of the repo tar index and resign+  , inMemRepoSetIndex :: UTCTime -> [Tar.Entry] -> IO ()   }  newInMemRepo :: RepoLayout@@ -86,6 +89,7 @@       , inMemRepoGetPath     = getPath     state       , inMemRepoCron        = cron        state       , inMemRepoKeyRollover = keyRollover state+      , inMemRepoSetIndex    = setIndex    state       }  {-------------------------------------------------------------------------------@@ -213,6 +217,41 @@     return st {         remoteTimestamp = signedTimestamp       , remoteSnapshot  = signedSnapshot+      }++setIndex :: MVar RemoteState -> UTCTime -> [Tar.Entry] -> IO ()+setIndex state now entries = modifyMVar_ state $ \st@RemoteState{..} -> do+    let snapshot, snapshot' :: Snapshot+        snapshot  = signed remoteSnapshot+        snapshot' = snapshot {+            snapshotVersion   = versionIncrement $ snapshotVersion snapshot+          , snapshotExpires   = expiresInDays now 3+          , snapshotInfoTarGz = fileInfo $ newTarGz+          , snapshotInfoTar   = Just $ fileInfo newTar+          }++        newTar :: BS.L.ByteString+        newTar = Tar.write entries++        newTarGz :: BS.L.ByteString+        newTarGz = GZip.compress newTar++        timestamp, timestamp' :: Timestamp+        timestamp  = signed remoteTimestamp+        timestamp' = Timestamp {+            timestampVersion      = versionIncrement $ timestampVersion timestamp+          , timestampExpires      = expiresInDays now 3+          , timestampInfoSnapshot = fileInfo $ renderJSON remoteLayout signedSnapshot+          }++        signedTimestamp = withSignatures remoteLayout [privateTimestamp remoteKeys] timestamp'+        signedSnapshot  = withSignatures remoteLayout [privateSnapshot  remoteKeys] snapshot'++    return st {+        remoteTimestamp = signedTimestamp+      , remoteSnapshot  = signedSnapshot+      , remoteTar       = newTar+      , remoteTarGz     = newTarGz       }  keyRollover :: MVar RemoteState -> UTCTime -> IO ()
hackage-security/hackage-security/tests/TestSuite/InMemRepository.hs view
@@ -31,8 +31,8 @@       , repGetCachedRoot = inMemCacheGetRoot  cache       , repClearCache    = inMemCacheClear    cache       , repLockCache     = withMVar cacheLock . const-      , repWithIndex     = error "newInMemRepository: repWithIndex TODO"-      , repGetIndexIdx   = error "newInMemRepository: repGetIndexIdx TODO"+      , repWithIndex     = inMemCacheWithIndex   cache+      , repGetIndexIdx   = inMemCacheGetIndexIdx cache       , repWithMirror    = withMirror       , repLog           = logger       , repLayout        = layout
+ hackage-security/hackage-security/tests/TestSuite/JSON.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module TestSuite.JSON (+    prop_roundtrip_canonical,+    prop_roundtrip_pretty,+    prop_canonical_pretty,+  ) where++-- stdlib+import Data.Int+import Data.List (sortBy, nubBy)+import Data.Function (on)+import Control.Applicative+import qualified Data.ByteString.Lazy.Char8 as BS+import Test.QuickCheck++-- hackage-security+import Text.JSON.Canonical+++prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty+  :: JSValue -> Bool++prop_roundtrip_canonical jsval =+    parseCanonicalJSON (renderCanonicalJSON jsval) == Right (canonicalise jsval)++prop_roundtrip_pretty jsval =+    parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)) == Right jsval++prop_canonical_pretty jsval =+    parseCanonicalJSON (renderCanonicalJSON jsval) ==+    fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)))++canonicalise :: JSValue -> JSValue+canonicalise v@JSNull        = v+canonicalise v@(JSBool    _) = v+canonicalise v@(JSNum     _) = v+canonicalise v@(JSString  _) = v+canonicalise   (JSArray  vs) = JSArray  [ canonicalise v | v <- vs]+canonicalise   (JSObject vs) = JSObject [ (k, canonicalise v)+                                        | (k,v) <- sortBy (compare `on` fst) vs ]++instance Arbitrary JSValue where+  arbitrary =+    sized $ \sz ->+    frequency+      [ (1, pure JSNull)+      , (1, JSBool   <$> arbitrary)+      , (2, JSNum    <$> arbitrary)+      , (2, JSString <$> arbitrary)+      , (3, JSArray                <$> resize (sz `div` 2) arbitrary)+      , (3, JSObject . noDupFields <$> resize (sz `div` 2) arbitrary)+      ]+    where+      noDupFields = nubBy (\(x,_) (y,_) -> x==y)++  shrink JSNull        = []+  shrink (JSBool    _) = []+  shrink (JSNum     n) = [ JSNum    n' | n' <- shrink n ]+  shrink (JSString  s) = [ JSString s' | s' <- shrink s ]+  shrink (JSArray  vs) = [ JSArray vs' | vs' <- shrink vs ]+  shrink (JSObject vs) = [ JSObject vs' | vs' <- shrinkList shrinkSnd vs ]+    where+      shrinkSnd (a,b) = [ (a,b') | b' <- shrink b ]+++instance Arbitrary Int54 where+  arbitrary = fromIntegral <$>+              frequency [ (1, pure lowerbound)+                        , (1, pure upperbound)+                        , (8, choose (lowerbound, upperbound))+                        ]+    where+      upperbound, lowerbound :: Int64+      upperbound =   999999999999999  -- 15 decimal digits+      lowerbound = (-999999999999999)+  shrink = shrinkIntegral+
hackport.cabal view
@@ -1,5 +1,5 @@ Name:           hackport-Version:        0.5+Version:        0.5.1 License:        GPL License-file:   LICENSE Author:         Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -50,7 +50,9 @@     stm,     unix,     -- cabal-install depends+    async,     --  hackage-security depends+    base16-bytestring,     base64-bytestring,     cryptohash,     ed25519,@@ -112,6 +114,9 @@     Paths_hackport     Portage.Version     Portage.Dependency+    Portage.EBuild+    Portage.EBuild.CabalFeature+    Portage.EBuild.Render     Portage.GHCCore     Portage.PackageId     Portage.Overlay
tests/resolveCat.hs view
@@ -20,7 +20,7 @@ test_resolveCategory cat pkg = TestCase $ do   portage_dir <- Portage.portage_dir `fmap` Portage.getInfo   portage <- Portage.loadLazy portage_dir-  let cabal = Cabal.PackageName pkg+  let cabal = Cabal.mkPackageName pkg       hits = Portage.resolveFullPortageName portage cabal       expected = Just (Portage.PackageName (Portage.Category cat) (Portage.normalizeCabalPackageName cabal))   assertEqual ("expecting to find package " ++ pkg) expected hits